content: {-
    Copyright (c) Meta Platforms, Inc. and affiliates.
    All rights reserved.
  
    This source code is licensed under the BSD-style license found in the
    LICENSE file in the root directory of this source tree.
  -}
  
  
  {-# LANGUAGE CPP #-}
  module Glean.Schema.Gen.HackJson
    ( genSchemaHackJson
    ) where
  
  import Control.Monad.Reader
  import Control.Monad.Writer.Strict
  import qualified Data.Aeson as Aeson
  import qualified Data.Aeson.Encode.Pretty as Aeson
  import qualified Data.Char as Char
  import Data.Graph
  import Data.Hashable
  import Data.HashMap.Strict (HashMap)
  import qualified Data.HashMap.Strict as HashMap
  import Data.Text (Text)
  import qualified Data.Text as Text
  import qualified Data.Text.Lazy as Text.Lazy
  import qualified Data.Text.Lazy.Builder as TextBuilder
  import GHC.Generics
  import Glean.Schema.Gen.Utils (Oncall)
  
  import Util.Text (textShow)
  
  import Glean.Angle.Types hiding (Struct, KeyValue)
  import Glean.Schema.Types
  
  data HackGenData = HackGenData
    { generated :: Text
    , namespace :: Text
    , genTypes :: HashMap Text GenType
    , enums :: HashMap Text [(Text, Text)]
    } deriving (Generic)
  
  instance Aeson.ToJSON HackGenData where
  
  data GenType
    = ClassType ClassGenType
    | EnumType [Text]
    | AliasType AngleTypeRepr
    deriving (Generic)
  
  instance Aeson.ToJSON GenType where
  
  data ReferenceTag
    = PredicateReference
    | TypeReference
    deriving (Generic,Eq)
  
  instance Hashable ReferenceTag where
  instance Aeson.ToJSON ReferenceTag where
  
  data VersionedReference
    = Reference
      { refTag :: ReferenceTag
      , refName :: Text
      , refVersion :: Version
      , refLatest :: Bool
      } deriving (Generic,Eq)
  
  instance Aeson.ToJSON VersionedReference where
  instance Hashable VersionedReference where
  
  data ClassGenType
    = Struct ClassGenTypeData
    | Union ClassGenTypeData
    | Wrapper ClassGenTypeData
    | KeyValue ClassGenTypeData
    deriving (Generic)
  
  instance Aeson.ToJSON ClassGenType where
  
  data ClassGenTypeData = ClassGenTypeData
    { classGenReference :: VersionedReference
    , classGenHasCycles :: Bool
    , classGenFieldInfos :: [FieldInfo]
    } deriving (Generic)
  instance Aeson.ToJSON ClassGenTypeData where
  
  data FieldInfo = FieldInfo
    { fieldInfoName :: Text
    , fieldInfoType :: AngleTypeRepr
    } deriving (Generic)
  
  instance Aeson.ToJSON FieldInfo where
  
  data Context = Context
    { contextCycles :: HashMap VersionedReference Bool
    , contextPredMap :: HashMap PredicateRef ResolvedPredicateDef
    , contextTypeMap :: HashMap TypeRef ResolvedTypeDef
    , contextPredLatest :: HashMap Text Version
    , contextTypeLatest :: HashMap Text Version
    }
  
  type HackEnum = (Text, [(Text, Text)])
  
  genSchemaHackJson
    :: Version
    -> [ResolvedPredicateDef]
    -> [ResolvedTypeDef]
    -> Maybe Oncall
    -> [(FilePath,Text)]
  genSchemaHackJson _version preddefs typedefs _ = HashMap.toList files
    where
      predMap = HashMap.fromList $ map (\p -> (predicateDefRef p, p)) preddefs
      typeMap = HashMap.fromList $ map (\t -> (typeDefRef t, t)) typedefs
      predLatest = HashMap.fromListWith max $
        flip map preddefs $
          \PredicateDef{predicateDefRef=PredicateRef{..}} ->
            (predicateRef_name , predicateRef_version)
      typeLatest = HashMap.fromListWith max $
        flip map typedefs $
          \TypeDef{typeDefRef=TypeRef{..}} ->
            (typeRef_name, typeRef_version)
      cyclesMap = HashMap.fromList $ cyclesInDefs ctx allDefs
      ctx = Context
        { contextCycles = cyclesMap
        , contextPredMap = predMap
        , contextTypeMap = typeMap
        , contextPredLatest = predLatest
        , contextTypeLatest = typeLatest
        }
      allDefs = (++)
        [Left preddef | preddef <- preddefs ]
        [Right typedef | typedef <- typedefs ]
      fileDefs = HashMap.fromListWith (++) $
        map (\def -> (defFile def, [def])) allDefs
      files = HashMap.mapWithKey f fileDefs
      f file defs = Text.Lazy.toStrict $ TextBuilder.toLazyText $
        Aeson.encodePrettyToTextBuilder genData
        where
          (genTypes, enums) = runWriter $ mapM (genTypeOfDef ctx) defs
          genData = HackGenData
            { generated = generatedMessage
            , namespace = namespaceFor file
            , genTypes = HashMap.fromList genTypes
            , enums = HashMap.fromList enums
            }
      generatedMessage =
        "\0064generated" <>
          " - To regenerate this file run fbcode//glean/schema/gen/sync-www"
  
  genTypeOfDef
    :: Context
    -> Either ResolvedPredicateDef ResolvedTypeDef
    -> Writer [HackEnum] (Text, GenType)
  genTypeOfDef ctx def@(Left PredicateDef{..}) = (,) (refClassname ref) <$>
    case (predicateDefKeyType, predicateDefValueType) of
      (RecordTy fields, RecordTy[]) -> ClassType . Struct . ClassGenTypeData
        ref cycles <$> mapM (fieldInfoFor (refClassname ref) ctx) fields
      (SumTy fields, RecordTy[]) -> ClassType . Union . ClassGenTypeData
        ref cycles <$> mapM (fieldInfoFor (refClassname ref) ctx) fields
      (ty, RecordTy[]) -> ClassType . Wrapper . ClassGenTypeData
        ref cycles <$> mapM (fieldInfoFor (refClassname ref) ctx)
          [FieldDef "key" ty]
      (tyKey, tyValue) -> ClassType . KeyValue . ClassGenTypeData
        ref cycles <$> mapM (fieldInfoFor (refClassname ref) ctx)
          [FieldDef "key" tyKey, FieldDef "value" tyValue]
    where
      ref = defRef ctx def
      cycles = HashMap.lookupDefault True ref $ contextCycles ctx
  genTypeOfDef ctx def@(Right TypeDef{..}) = (,) (refClassname ref) <$>
    case typeDefType of
      RecordTy fields ->
        ClassType . Struct . ClassGenTypeData ref cycles <$>
          mapM (fieldInfoFor (refClassname ref) ctx) fields
      SumTy fields ->
        ClassType . Union . ClassGenTypeData ref cycles <$>
          mapM (fieldInfoFor (refClassname ref) ctx) fields
      EnumeratedTy alts -> return $ EnumType alts
      ty -> AliasType . fieldInfoType <$>
        fieldInfoFor (refClassname ref) ctx (FieldDef "value" ty)
    where
      ref = defRef ctx def
      cycles = HashMap.lookupDefault True ref $ contextCycles ctx
  
  fieldInfoFor
    :: Text
    -> Context
    -> ResolvedFieldDef
    -> Writer [HackEnum] FieldInfo
  fieldInfoFor className Context{..} FieldDef{..} = do
    angleTypeRepr <- runReaderT (angleTypeReprFor fieldDefType) angleTypeReprCtx
    return FieldInfo
      { fieldInfoName = fieldDefName
      , fieldInfoType = angleTypeRepr
      }
    where
      angleTypeReprCtx = AngleTypeReprContext
        { ctxClassName=className
        , ctxFieldName=fieldDefName
        , ctxPredMap=contextPredMap
        , ctxTypeMap=contextTypeMap
        , ctxPredLatest=contextPredLatest
        , ctxTypeLatest=contextTypeLatest
        }
  
  data AngleTypeReprContext = AngleTypeReprContext
    { ctxClassName :: Text
    , ctxFieldName :: Text
    , ctxPredMap :: HashMap PredicateRef ResolvedPredicateDef
    , ctxTypeMap :: HashMap TypeRef ResolvedTypeDef
    , ctxPredLatest :: HashMap Text Version
    , ctxTypeLatest :: HashMap Text Version
    }
  
  -- There is not a simple relationship between the Angle type and
  -- what type is used to represent it in Hack. Both Bytes and Nats are
  -- represented as Ints. Predicates can be represented by both a Class
  -- and a primitive (for simple predicates). Most named types are stored
  -- as a class apart from Enumerations which get a Hack enum. This type
  -- contains information on both the Hack type and the Angle type
  data AngleTypeRepr
    = ByteTInt
    | NatTInt
    | StringTString
    | EnumeratedTEnum {alts::[Name], classname::Text}
    | BooleanTBool
    | ArrayTVec {inner::AngleTypeRepr}
    | SetTVec {inner::AngleTypeRepr}
    | RecordTShape {fields::[(Text, AngleTypeRepr)]}
    | SumTShape {fields::[(Text, AngleTypeRepr)]}
    | PredicateTKeyValue {pref::PredicateRef, classname::Text}
    | PredicateTNamed {pref::PredicateRef, classname::Text}
    | PredicateT {pref::PredicateRef, classname::Text, inner::AngleTypeRepr}
    | NamedTypeTNamed {tref::TypeRef, classname::Text}
    | NamedTypeTAlias {tref::TypeRef, classname::Text, inner::AngleTypeRepr}
    | NamedTypeTEnum {alts::[Name], tref::TypeRef, classname::Text}
    | MaybeTOption {inner::AngleTypeRepr}
    deriving (Generic, Show)
  
  instance Aeson.ToJSON AngleTypeRepr where
  
  -- Generating a class for Angle types that hold an Enumeration requires
  -- creating a definition for that enum which is what the state holds
  angleTypeReprFor
    :: ResolvedType
    -> ReaderT AngleTypeReprContext (Writer [HackEnum]) AngleTypeRepr
  angleTypeReprFor (PredicateTy _ ref) = do
    ctx <- ask
    case lookupPredDefKeyValue ctx ref of
      -- If the predicate has value of type {} and the key is a String
      -- avoid wrapping it in a class. This makes writing queries more
      -- concise
      Just (StringTy, RecordTy []) ->
        PredicateT ref (classname ctx) <$> angleTypeInnerReprFor StringTy
      _ -> angleTypeInnerReprFor (PredicateTy () ref)
      where
        lookupPredDefKeyValue ctx pref = do
          PredicateDef{..} <- HashMap.lookup pref $ ctxPredMap ctx
          return (predicateDefKeyType, predicateDefValueType)
        classname AngleTypeReprContext{..} =
          refClassname $ prefVref ctxPredLatest ref
  angleTypeReprFor ty = angleTypeInnerReprFor ty
  
  angleTypeInnerReprFor
    :: ResolvedType' s
    -> ReaderT AngleTypeReprContext (Writer [HackEnum]) AngleTypeRepr
  angleTypeInnerReprFor ByteTy = return ByteTInt
  angleTypeInnerReprFor NatTy = return NatTInt
  angleTypeInnerReprFor StringTy = return StringTString
  angleTypeInnerReprFor (ArrayTy ty) = ArrayTVec <$> angleTypeInnerReprFor ty
  angleTypeInnerReprFor (RecordTy fields) =
    RecordTShape <$> mapM f fields
    where
      f FieldDef{..} =
        (,) fieldDefName <$> angleTypeInnerReprFor fieldDefType
  angleTypeInnerReprFor (SumTy fields) =
    SumTShape <$> mapM f fields
    where
      f FieldDef{..} =
        (,) fieldDefName <$> angleTypeInnerReprFor fieldDefType
  angleTypeInnerReprFor (SetTy ty) = SetTVec <$> angleTypeInnerReprFor ty
  angleTypeInnerReprFor (PredicateTy _ ref) = do
    ctx <- ask
    case lookupPredDefKeyValue ctx ref of
      Nothing -> return $
        PredicateTNamed ref $ classname ctx
      Just (_k, RecordTy []) -> return $
        PredicateTNamed ref $ classname ctx
      Just (_k, _v) -> return $
        PredicateTKeyValue ref $ classname ctx
      where
        lookupPredDefKeyValue ctx pref = do
          PredicateDef{..} <- HashMap.lookup pref $ ctxPredMap ctx
          return (predicateDefKeyType, predicateDefValueType)
        classname AngleTypeReprContext{..} =
          refClassname $ prefVref ctxPredLatest ref
  angleTypeInnerReprFor (NamedTy _ ref) = do
    ctx <- ask
    case lookupTypeDefType ctx ref of
      Just (EnumeratedTy alts) ->
        return $ NamedTypeTEnum alts ref $ classname ctx
      Nothing -> return $ NamedTypeTNamed ref $ classname ctx
      Just RecordTy{} -> return $ NamedTypeTNamed ref $ classname ctx
      Just SumTy{} -> return $ NamedTypeTNamed ref $ classname ctx
      Just t ->
        NamedTypeTAlias ref (classname ctx) <$>
          angleTypeInnerReprFor t
    where
      lookupTypeDefType ctx tref = typeDefType <$>
        HashMap.lookup tref (ctxTypeMap ctx)
      classname AngleTypeReprContext{..} =
        refClassname $ trefVref ctxTypeLatest ref
  angleTypeInnerReprFor (MaybeTy t) = MaybeTOption <$> angleTypeInnerReprFor t
  angleTypeInnerReprFor (EnumeratedTy alts) = do
    AngleTypeReprContext{..} <- ask
    let
      enumName =
        ctxClassName <> "EnumFor_" <> ctxFieldName
      enum = (enumName, map f alts)
      f name = (name, name)
    tell [enum]
    return $ EnumeratedTEnum alts enumName
  angleTypeInnerReprFor BooleanTy = return BooleanTBool
  angleTypeInnerReprFor TyVar{} = error "angleTypeInnerReprFor: TyVar"
  angleTypeInnerReprFor HasTy{} = error "angleTypeInnerReprFor: HasTy"
  angleTypeInnerReprFor HasKey{} = error "angleTypeInnerReprFor: HasKey"
  angleTypeInnerReprFor ElementsOf{} = error "angleTypeInnerReprFor: ElementsOf"
  
  defFile :: Either ResolvedPredicateDef ResolvedTypeDef -> FilePath
  defFile (Left p) = fileFor $ predicateDefName p
  defFile (Right t) = fileFor $ typeDefName t
  
  refClassname :: VersionedReference -> Text
  refClassname Reference{..} | refLatest = "GS" <> hackCase refName
  refClassname Reference{..} =
    "GS" <> hackCase refName <> "_DEPRECATED" <> textShow refVersion
  
  defRef
    :: Context
    -> Either ResolvedPredicateDef ResolvedTypeDef
    -> VersionedReference
  defRef Context{..} (Left PredicateDef{..}) =
    prefVref contextPredLatest predicateDefRef
  defRef Context{..} (Right TypeDef{..}) =
    trefVref contextTypeLatest typeDefRef
  
  prefVref :: HashMap Text Version -> PredicateRef -> VersionedReference
  prefVref ctxPredLatest PredicateRef{..} = Reference
    { refTag = PredicateReference
    , refName = predicateRef_name
    , refVersion = predicateRef_version
    , refLatest =
        HashMap.lookup predicateRef_name ctxPredLatest ==
          Just predicateRef_version
    }
  
  trefVref :: HashMap Text Version -> TypeRef -> VersionedReference
  trefVref ctxTypeLatest TypeRef{..} = Reference
    { refTag = TypeReference
    , refName = typeRef_name
    , refVersion = typeRef_version
    , refLatest =
        HashMap.lookup typeRef_name ctxTypeLatest == Just typeRef_version
    }
  
  predicateDefName :: ResolvedPredicateDef -> Text
  predicateDefName = predicateRef_name . predicateDefRef
  
  typeDefName :: ResolvedTypeDef -> Text
  typeDefName = typeRef_name . typeDefRef
  
  hackCase :: Text -> Text
  hackCase s =
    Text.pack $ concatMap (pascalCase . Text.unpack) $ Text.splitOn "." s
    where
      pascalCase (x:xs) = Char.toUpper x : xs
      pascalCase [] = []
  
  fileFor :: Text -> FilePath
  fileFor s = Text.unpack file <> ".json"
    where file = Text.intercalate "-" $ init $ Text.splitOn "." s
  
  namespaceFor :: FilePath -> Text
  namespaceFor file = (<>) "GS" $
    hackCase $
    Text.intercalate "." $
    Text.splitOn "-" $
    Text.pack $
    takeWhile ('.' /=) file
  
  -- What counts as a cycle here is Hack specific. We report anything that
  -- would cause a recursive shape to be generated (these are not allowed in Hack)
  cyclesInDefs
    :: Context
    -> [Either ResolvedPredicateDef ResolvedTypeDef]
    -> [(VersionedReference, Bool)]
  cyclesInDefs ctx defs = concatMap hasCycles sccs
   where
    hasCycles (AcyclicSCC one) = [(defRef ctx one, False)]
    hasCycles (CyclicSCC defs) = map (\def -> (defRef ctx def, True)) defs
  
    sccs = stronglyConnComp
      [ (def, defNode def, outEdges def) | def <- defs ]
  
    defNode :: Either ResolvedPredicateDef ResolvedTypeDef -> (Name,Version)
    defNode (Left PredicateDef{..}) =
      (predicateRef_name predicateDefRef, predicateRef_version predicateDefRef)
    defNode (Right TypeDef{..}) =
      (typeRef_name typeDefRef, typeRef_version typeDefRef)
  
    outEdges :: Either ResolvedPredicateDef ResolvedTypeDef -> [(Name,Version)]
    outEdges d = case d of
      Left PredicateDef{..} ->
        outEdgesTs [predicateDefKeyType, predicateDefValueType]
      Right TypeDef{..} ->
        outEdgesT typeDefType
  
    outEdgesTs = concatMap outEdgesT
    outEdgesFields fields = outEdgesTs [ ty | FieldDef _ ty <- fields ]
  
    outEdgesT :: ResolvedType -> [(Name,Version)]
    outEdgesT ByteTy{} = []
    outEdgesT NatTy{} = []
    outEdgesT BooleanTy{} = []
    outEdgesT StringTy{} = []
    outEdgesT (ArrayTy ty) = outEdgesT ty
    outEdgesT (MaybeTy ty) = outEdgesT ty
    outEdgesT (RecordTy fields)  = outEdgesFields fields
    outEdgesT (SumTy fields)  = outEdgesFields fields
    outEdgesT (SetTy ty) = outEdgesT ty
    outEdgesT (NamedTy _ (TypeRef name ver)) = [(name,ver)]
    outEdgesT (PredicateTy _ (PredicateRef name ver)) = [(name,ver)]
    outEdgesT EnumeratedTy{} = []
    outEdgesT TyVar{} = error "outEdgesT: TyVar"
    outEdgesT HasTy{} = error "outEdgesT: HasTy"
    outEdgesT HasKey{} = error "outEdgesT: HasKey"
    outEdgesT ElementsOf{} = error "outEdgesT: ElementsOf"
  