{-
  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.
-}

-- | Generate C++ client types from the Glean schema

{-# LANGUAGE OverloadedStrings #-}
module Glean.Schema.Gen.Cpp
  ( genSchemaCpp
  ) where

import Control.Monad
import Control.Monad.Reader
import Control.Monad.State
import Data.List (intercalate)
import qualified Data.Map as Map
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import TextShow

import Glean.Schema.Gen.Utils hiding (pushDefs, popDefs)
import Glean.Angle.Types hiding (schemaName)
import Glean.Schema.Types
import Glean.Types (SchemaId(..))


genSchemaCpp
  :: SchemaId
  -> Version
  -> [ResolvedPredicateDef]
  -> [ResolvedTypeDef]
  -> Maybe Oncall
  -> [(FilePath,Text)]
genSchemaCpp hash version preddefs typedefs _ =
  [("", leading <> newline <> newline <> body)]
  where
    namePolicy = mkNamePolicy preddefs typedefs
    someDecls = map PredicateDecl preddefs ++
      map (\TypeDef{..} -> TypeDecl typeDefRef typeDefType) typedefs
    ordered = orderDecls someDecls
    ((ds,schema), extra) = runM [] namePolicy typedefs $ do
      ds <- mapM genDecl ordered
      sc <- defineSchema ordered hash
      return (ds, sc)
    decls = concat ds ++ reverse extra
    pieces = withNS $
      [(schemaNamespace, "constexpr int version = " <> showt version <> ";")]
      ++ forwardDeclare decls
      ++ [(schemaNamespace, schema)]

    body = Text.intercalate (newline <> newline) pieces

-- Check against hardcoded list of what glean.h provides
provided :: (NameSpaces, Text) -> Maybe ResolvedType
provided (_,ident) = Map.lookup ident known
  where known = Map.fromList [("Unit", unitT)]

leading :: Text
leading = Text.unlines
  ["#pragma once"
  ,"// \x40generated"
  ,"// Glean.Schema.Gen.Cpp definitions for fbcode/glean/lang/clang/schema.h"
  ,"// by //glean/hs:predicates using --cpp"
  ,""
  ,"#include <tuple>"
  ,"#include <boost/variant.hpp>"
  ,"#include \"glean/cpp/glean.h\""
  ,""
  ]

forwardDeclare
  :: [(NameSpaces, (Text,Text))]
  -> [(NameSpaces, Text)]
forwardDeclare xs =
  declarations xs
  ++ definitions xs
  where
    declarations = filter (not . Text.null . snd) . map (fmap fst)
    definitions = map (fmap snd)

defineSchema :: [SomeDecl] -> SchemaId -> CppGen Text
defineSchema ds hash = do
  let preds = [ p | PredicateDecl p <- ds ]
  pnames <- forM preds $ \PredicateDef{..} -> do
    cppNameIn schemaNamespace . schemaName <$> predicateName predicateDefRef
  return $ Text.unlines $ concat
    [ ["struct SCHEMA {"]
    , indentLines [
        "template<typename P> struct index;",
        "static constexpr size_t count = "
          <> Text.pack (show $ length pnames)
          <> ";",
        "static constexpr char schemaId[] = \"" <> unSchemaId hash <> "\";",
        "template<size_t i> struct predicate;"
      ]
    , ["};"]
    , [""]
    {-
       we would like to do:

         struct SCHEMA {
           template<typename P> struct index;

           template<> struct index<Predicate> { ... }
         }

       but declaring a template specialisation inside a struct is
       not currently supported by gcc, see
          https://gcc.gnu.org/bugzilla/show_bug.cgi?id=85282

       so instead we declare the specialisation outside the struct:

         template<> struct SCHEMA::index<Predicate> { ... }
    -}
    , ["template<> struct SCHEMA::index<"
        <> p
        <> "> { static constexpr size_t value = "
        <> Text.pack (show i)
        <> "; };" | (i,p) <- zip [0::Int ..] pnames]
    , [""]
    , ["template<> struct SCHEMA::predicate<"
        <> Text.pack (show i)
        <> "> { using type = "
        <> p
        <> "; };" | (i,p) <- zip [0::Int ..] pnames]
    ]

-- Insert all the namespace opening and closing around declaration regions
withNS :: [(NameSpaces, Text)] -> [Text]
withNS [] = []
withNS (h@(start, _):t) = catMaybes (transNS [] start : addNS h t)
  where addNS (end, x) [] = [ Just x, transNS end [] ]
        addNS (ns, x) (h'@(ns', _): t') =
          Just x : transNS ns ns' : addNS h' t'

        transNS :: NameSpaces -> NameSpaces -> Maybe Text
        transNS xs ys =
          let common = length . takeWhile (True==) $ zipWith (==) xs ys
              toClose = reverse (drop common xs)
              toOpen = drop common ys
              close t = "} // namespace " <> t
              open t = "namespace " <> t <> " {"
              pieces = map close toClose ++ map open toOpen
          in if null pieces then Nothing
              else Just $ Text.intercalate (newline <> newline) pieces

withExtra
  :: CppGen [(NameSpaces, (Text, Text))]
  -> CppGen [(NameSpaces, (Text, Text))]
withExtra act = do
  most <- act
  extra <- popDefs
  return (extra ++ most)


-- ----------------------------------------------------------------------------
-- Naming & namespaces

-- safety pass looking for bad characters, etc
safe :: Text -> Text
safe s
  | s `elem` keywords = s <> "_"
  | otherwise = s
  where
    keywords = [
       "asm", "auto", "bool", "break", "case", "catch", "char", "class",
       "const", "const_cast", "continue", "default", "delete", "do",
       "double", "dynamic_cast", "else", "enum", "explicit", "export",
       "extern", "false", "float", "for", "friend", "goto", "if",
       "inline", "int", "long", "mutable", "namespace", "new", "operator",
       "private", "protected", "public", "register", "reinterpret_cast",
       "return", "short", "signed", "sizeof", "static", "static_cast",
       "struct", "switch", "template", "this", "throw", "true", "try",
       "typedef", "typeid", "typename", "union", "unsigned", "using",
       "virtual", "void", "volatile", "wchar_t", "while",

       -- avoid clashing with glean.h types
       "Alt",
       "Array",
       "Bool",
       "Byte",
       "Enum",
       "Maybe",
       "Nat",
       "Predicate",
       "Repr",
       "Sum",
       "Tuple"
     ]



-- Upper-case the namespaces. We could change this.
schemaName :: (NameSpaces,Text) -> (NameSpaces,Text)
schemaName (spaces,ident) = (schemaNamespace ++ map cap1 spaces, ident)

builtinName :: Text -> (NameSpaces,Text)
builtinName name = (builtinNamespace, snd $ splitDot name)

schemaNamespace :: NameSpaces
schemaNamespace = ["facebook", "glean", "cpp", "schema"]

-- The namespace within which we must declare Repr<T> specializations
reprNamespace :: NameSpaces
reprNamespace = builtinNamespace

builtinNamespace :: NameSpaces
builtinNamespace = ["facebook", "glean", "cpp"]

cppIdent :: Text -> Text
cppIdent = safe

-- | Glue the cpp names together. We qualify everything except things in the
-- same namespace. Here's why:
--
-- namespace foo {
--   struct A {...};
--   namespace bar {
--     struct A {...};
--     struct B { foo::A x; };
--   }
-- }
--
-- FIXME: What we're currently doing still isn't enough. Consider this:
--
-- namespace foo {
--   struct A {...};
--   namespace bar {
--     namespace foo {
--       struct A {...};
--     }
--     struct B { foo::A x; /* should have been ::foo::A */ };
--   }
-- }
--
-- So we need to fully qualify things but for that, we need to know which
-- namespace(s) the generated code is wrapped in and we aren't threading that
-- information at the moment.
cppNameIn :: NameSpaces -> (NameSpaces, Text) -> Text
cppNameIn here (ns, t)
  | here == ns = cppIdent t
  | otherwise = cppName (ns, t)
  where
    -- | Glue the cpp names together
    cppName :: (NameSpaces, Text) -> Text
    cppName (ns, t) = Text.intercalate "::" (map cppIdent (ns ++ [t]))


-- ----------------------------------------------------------------------------
-- Monad

type CppGen a = ReaderT Env (State [(NameSpaces, (Text,Text))]) a

pushDefs :: [(NameSpaces, (Text,Text))] -> CppGen ()
pushDefs defs = modify (defs++)

popDefs :: CppGen [(NameSpaces, (Text,Text))]
popDefs = state $ \s -> (reverse s, [])

-- ----------------------------------------------------------------------------
-- Types

-- | Generate a representation type
reprTy :: NameSpaces -> ResolvedType -> CppGen Text
reprTy here t = case t of
  -- Leaves
  ByteTy{} -> return "Byte" -- glean.h hardcoded here
  NatTy{} -> return "Nat"   -- glean.h hardcoded here
  BooleanTy{} -> return "Bool"
  StringTy{} -> return "String"
  -- Containers
  ArrayTy ty -> do
    rTy <- reprTy here ty
    return $ "Array<" <> rTy <> ">"
  RecordTy fields -> do
    ts <- mapM (reprTy here . fieldDefType) fields
    return $ "Tuple<" <> Text.intercalate ", " ts <> ">"
  SumTy fields -> do
    ts <- mapM (reprTy here . fieldDefType) fields
    return $ "Sum<" <> Text.intercalate ", " ts <> ">"
  SetTy ty -> do
    rTy <- reprTy here ty
    return $ "Set<" <> rTy <> ">"
  MaybeTy ty -> do
    rTy <- reprTy here ty
    return $ "Maybe<" <> rTy <> ">"
  -- References
  PredicateTy _ pref -> do
    name <- schemaName <$> predicateName pref
    return (cppNameIn here name)
  NamedTy _ tref -> do
    name <- schemaName <$> typeName tref
    if isJust (provided name)
      then return $ cppNameIn here (builtinName (snd name))
      else return $ "Repr<" <> cppNameIn here name <> ">"
  EnumeratedTy elts -> return $ "Enum<" <> showt (length elts) <> ">"
  TyVar{} -> error "reprTy: TyVar"
  HasTy{} -> error "reprTy: HasTy"
  HasKey{} -> error "reprTy: HasKey"
  ElementsOf{} -> error "reprTy: ElementsOf"

shareTypeDef :: NameSpaces -> ResolvedType -> CppGen Text
shareTypeDef here t = do
  (no, name) <- nameThisType t
  case no of
    Old -> return ()
    New -> do
      -- getting the namespace for the generated type right is a bit of a hack,
      -- because we've already mangled the namespace that we're passing around.
      let qname = joinDot (drop (length schemaNamespace) here, name)
          tref = TypeRef qname 0
      pushDefs =<< genDecl (TypeDecl tref t)
  return name

-- | Generate a value type
valueTy :: NameSpaces -> ResolvedType -> CppGen Text
valueTy here t = case t of
  -- Leaves
  ByteTy{} -> return "uint8_t" -- glean.h hardcoded here
  NatTy{} -> return "uint64_t" -- glean.h hardcoded here
  BooleanTy{} -> return "bool" -- glean.h hardcoded here
  StringTy{} -> return "std::string"
  -- Containers
  ArrayTy ty -> do
    vTy <- valueTy here ty
    return $ "std::vector<" <> vTy <> ">"
  RecordTy fields -> do
    ts <- mapM (valueTy here . fieldDefType) fields
    return $ "std::tuple<" <> Text.intercalate ", " ts <> ">"
  SumTy fields -> do
    ts <- mapM (valueTy here .fieldDefType) fields
    return $ "boost::variant<" <> Text.intercalate ", " (altsOf ts) <> ">"
  SetTy ty -> do
    vTy <- valueTy here ty
    return $ "std::set<" <> vTy <> ">"
  MaybeTy ty ->
    valueTy here $ SumTy
      [ FieldDef "^Nothing^" unitT
      , FieldDef "^Just^" ty ]
  EnumeratedTy{} -> shareTypeDef here t
  -- References, Fact is a phantom-typed Id
  PredicateTy _ pref -> do
    name <- schemaName <$> predicateName pref
    return $ "Fact<" <> cppNameIn here name <> ">"
  NamedTy _ tref -> do
    name <- schemaName <$> typeName tref
    case provided name of
      Just ty -> valueTy here ty
      Nothing -> return (cppNameIn here name)
  TyVar{} -> error "valueTy: TyVar"
  HasTy{} -> error "valueTy: HasTy"
  HasKey{} -> error "valueTy: HasKey"
  ElementsOf{} -> error "valueTy: ElementsOf"


-- ----------------------------------------------------------------------------
-- Definitions

genDecl :: SomeDecl -> CppGen [(NameSpaces, (Text,Text))]
genDecl (PredicateDecl PredicateDef{..}) = withExtra $ do
  (spaces,name) <- schemaName <$> predicateName predicateDefRef
  withPredicateDefHint name $ do
  kTy <- valueTy spaces predicateDefKeyType
  vTy <- valueTy spaces predicateDefValueType
  let
    ident = cppIdent name
    value'
      | predicateDefValueType == unitT = ""
      | otherwise = ", " <> vTy
    declare = "struct " <> ident <> ";"
    define = myUnlines
      [ "struct " <> ident <> " : Predicate<" <> kTy
                                             <> value' <> "> {"
      , "  static const char* GLEAN_name() {"
      , "    return \"" <> predicateRef_name predicateDefRef <> "\";"
      , "  }"
      , ""
      , "  static constexpr size_t GLEAN_version() {"
      ,"     return " <> showt (predicateRef_version predicateDefRef) <> ";"
      , "  }"
      , "}; // struct " <> ident
      ]
  return [(spaces, (declare, define))]
genDecl (TypeDecl tref ty) = withExtra $ do
  name@(_,base) <- schemaName <$> typeName tref
  withTypeDefHint base $ do
  if isJust (provided name)
    then return []
    else do
      case ty of
        RecordTy fields -> recordDef name fields
        SumTy fields -> unionDef name fields
        EnumeratedTy vals -> enumDef name vals
        _other -> aliasDef name ty


aliasDef :: (NameSpaces,Text) -> ResolvedType -> CppGen [(NameSpaces, (Text, Text))]
aliasDef name@(spaces,ident) aTy
  | isJust (provided name) = return []
  | otherwise = do
  cppTy <- valueTy spaces aTy
  let define = "using " <> ident <> " = " <> cppTy <> ";"
  return [(spaces, ("", define))]

mkAlt :: Int -> Text -> Text
mkAlt i t = "Alt<" <> showt i <> ", " <> t <> ">"

altsOf :: [Text] -> [Text]
altsOf = zipWith mkAlt [0..]

indentLines :: [Text] -> [Text]
indentLines = map (\t -> if Text.null t then t else "  " <> t)

relops :: Text -> [Text] -> [Text]
relops name fields = concatMap relop ["==","!=","<","<=",">",">="]
  where
    relop op = concat
      [ ["bool operator" <> op <> "(const " <> name <> "& other) const {"]
      , indentLines
          ["return " <> tie fields
          ,"         " <> op <> " " <> tie (map ("other."<>) fields) <> ";"]
      , ["}"] ]
    tie xs = "std::tie(" <> Text.intercalate "," xs <> ")"

mkReprDecl :: (NameSpaces,Text) -> ResolvedType -> CppGen (NameSpaces, (Text,Text))
mkReprDecl name typ = do
  rTy <- reprTy reprNamespace typ
  let
    decl = Text.unlines
      [ "template<> struct Repr_<" <> cppNameIn reprNamespace name <> "> {"
      , "  using Type = " <> rTy <> ";"
      , "};"
      ]
  return (reprNamespace, ("", decl))

recordDef
  :: (NameSpaces, Text)
  -> [ResolvedFieldDef]
  -> CppGen [(NameSpaces, (Text, Text))]
recordDef (spaces,name) fields = do
  rDecl <- mkReprDecl (spaces,name) (RecordTy fields)
  fieldTys <- mapM field fields
  return [rDecl, (spaces, (declare, define fieldTys))]
  where
    ident = cppIdent name
    field (FieldDef param t) = do
      vTy <- withRecordFieldHint param $ valueTy spaces t
      return $ vTy <> " " <> cppIdent param <> ";"
    field_names = map (cppIdent . fieldDefName) fields
    names = Text.intercalate ", " field_names
    outputRepr =
      [ "void outputRepr(Output<Repr<" <> ident <> ">> out) const {"
      , "  outputValue(out, std::make_tuple(" <> names <> "));"
      , "}"
      ]
    declare = "struct " <> ident <> ";"
    define fieldTys = myUnlines $ concat
      [ [ "struct " <> ident <> " {" ]
      , indentLines $ concat
          [ fieldTys
          , [""]
          , relops ident field_names
          , outputRepr ]
      , [ "}; // struct " <> ident ]
      ]


-- Would really prefer std::variant from later C++ standard
unionDef
  :: (NameSpaces,Text)
  -> [ResolvedFieldDef]
  -> CppGen [(NameSpaces, (Text, Text))]
unionDef (spaces,name) fields = do
  let
    ident = cppIdent name

    makeFieldTy (FieldDef param t) =
      withUnionFieldHint param $ valueTy spaces t

  theTypes <- mapM makeFieldTy fields
  let
    theTs = map fieldDefType fields
    theAlts = altsOf theTypes :: [Text]
    variant = "boost::variant<" <> Text.intercalate ", " theAlts <> ">"
    field = variant <> " GLEAN_value;"

    static_constructor (field, ty, altTy) = do
      let
        tuple fields = do
          let
            doField ty param = do
              vTy <- valueTy spaces ty
              return $ "const " <> vTy <> "& " <> cppIdent param
          tys <- sequence [ doField ty param | FieldDef param ty <- fields ]
          return
            ( Text.intercalate ", " tys
            , "std::make_tuple("
                <> Text.intercalate ", " (map (cppIdent . fieldDefName) fields)
                <> ")")
      (args, ret) <- case ty of
          -- special case, Unit is not a concrete type
        NamedTy _ (TypeRef "builtin.Unit" _) -> tuple []
        RecordTy fields -> tuple fields
        _ -> do
          vTy <- valueTy spaces ty
          return ("const " <> vTy <> "& a", "a")
      return
        [ "static " <> ident <> " " <> field <> "(" <> args <> ") {"
         , "  return " <> ident <> "{" <> altTy <> "(" <> ret <> ")};"
         , "}"]

    field_names = map (cppIdent . fieldDefName) fields

  static_constructors <-
    concat <$> mapM static_constructor (zip3 field_names theTs theAlts)
  rDecl <- mkReprDecl (spaces,name) (SumTy fields)
  let
    outputRepr =
      [ "void outputRepr(Output<Repr<" <> ident <> ">> out) const {"
      , "  outputValue(out, GLEAN_value);"
      , "}" ]

    declare = "struct " <> ident <> ";"
    define = myUnlines $ concat
      [ [ "struct " <> ident <> " {" ]
      , indentLines $ intercalate [""]
          [ [field]
          , static_constructors
          , relops ident ["GLEAN_value"]
          , outputRepr ]
      , [ "}; // struct " <> ident ]
      ]

  return [ rDecl, (spaces, (declare, define)) ]


enumDef
  :: (NameSpaces,Text)
  -> [Name]
  -> CppGen [(NameSpaces, (Text, Text))]
enumDef (spaces,name) eVals = do
  rDecl <- mkReprDecl (spaces,name) (EnumeratedTy eVals)
  return  [ rDecl, (spaces, (declare, define)) ]
  where
    ident = cppIdent name
    declare = "enum class " <> ident <> ";"
    define = "enum class " <> ident <> " { "
      <> Text.intercalate ", " (map cppIdent eVals) <> " };"