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 DeriveGeneric #-}
  
  module Glean.Glass.SymbolId.Cxx.Parse (
      validateSymbolId,
      compileSymbolEnv, -- valid symbol ids can be compiled to a search term
      SymbolEnv(..),
      SymbolTag(..),
      Name(..),
      Qualifier(..),
      RefQualifier(..),
      unName,
      unNames,
      CxxTaggedSymbolExpr(..),
      CxxSymbolExpr(..),
  
      -- testing
      toQualifier
    ) where
  
  import Control.Monad.State.Strict
  import Data.Aeson.Types ( ToJSON )
  import Data.Set ( Set )
  import Data.Text ( Text )
  import GHC.Generics
  import Util.Text ( textShow )
  import qualified Data.Set as Set
  import qualified Data.Text as Text
  
  -- "lexer"
  
  -- | Tokenize each fragment
  data Token
    = TName !Text
    | TDecl
    | TCtor
    | TDtor
    | TCtorSignature
    | TFunction
    | TOperator
    | TConversionOperator
    deriving Show
  
  tokenize :: Text -> Token
  tokenize ".decl" = TDecl
  tokenize ".ctor" = TCtor
  tokenize ".d" = TDtor
  tokenize ".c" = TCtorSignature
  tokenize ".f" = TFunction
  tokenize ".o" = TOperator
  tokenize ".t" = TConversionOperator
  tokenize n = TName n
  
  name :: Text -> Name
  name = Name
  
  -- | in type signatures literal "," (as in std::pair<a, b>) is replaced with " "
  -- to avoid the "," param seperator
  --
  -- And spaces are replaced with +
  --
  sig :: Text -> Name
  sig = Name . Text.replace "+" " " . Text.replace " " ","
  
  -- "parser"
  
  type Parse a = State SymbolEnv a
  
  -- | Process the symbol id left to right accumulating information
  data SymbolEnv = SymbolEnv {
    path :: Text,
    scopes :: [Name], -- accumulated scope terms
    localname :: Maybe Name, -- the local name of the identifier
    declaration :: Bool, -- .decl tag occurs
    tag :: Maybe SymbolTag,
    params :: [Name], -- maybe parameter signature
    returns :: Maybe Name, -- return type name where present
    qualifiers :: Set Qualifier, -- optional list of qualifiers (const, &&, etc)
    errors :: [Text] -- any errors we find
  } deriving (Eq, Ord, Show, Generic)
  
  newtype Name = Name Text
    deriving (Eq, Ord, Show, Generic)
  
  data Qualifier
    = Virtual
    | Const
    | Volatile
    | RefQual RefQualifier
    deriving (Eq, Ord, Show, Generic)
  
  data RefQualifier = LValue | RValue
    deriving (Eq, Ord, Show, Generic)
  
  -- standalone to avoid having it appear in the generic JSON writer
  unName :: Name -> Text
  unName (Name n) = n
  
  -- Any tags that help to classify the sort of symbol we have
  -- These will be variants of an ADT
  data SymbolTag
    = Constructor
    | CTorSignature -- .ctor with type signature of params
    | Destructor
    | Function
    | Operator
    | TypeConversionOperator
    deriving (Eq, Ord, Show, Generic)
  
  -- for regression testing
  instance ToJSON Name
  instance ToJSON SymbolTag
  instance ToJSON SymbolEnv
  instance ToJSON Qualifier
  instance ToJSON RefQualifier
  
  data CxxTaggedSymbolExpr
    = CxxDecl CxxSymbolExpr
    | CxxDefn CxxSymbolExpr
  
  tagged :: Bool -> CxxSymbolExpr -> CxxTaggedSymbolExpr
  tagged True = CxxDecl
  tagged False = CxxDefn
  
  -- Compile SymbolEnv to a typed ADT that makes bugs harder
  data CxxSymbolExpr
    = CxxConstructor {
        cPath :: Text,
        cScope :: [Name],
        cParams :: [Name]
      }
    | CxxDestructor {
        cPath :: Text,
        cScope :: [Name]
      }
    | CxxFunction {
        cPath :: Text,
        cScope :: [Name],
        cName :: Name,
        cParams :: [Name],
        cQuals :: Set Qualifier
      }
    | CxxOperator {
        cPath :: Text,
        cScope :: [Name],
        cName :: Name,
        cParams :: [Name],
        cQuals :: Set Qualifier
  
      }
    | CxxTypeConversionOperator {
        cPath :: Text,
        cScope :: [Name],
        cReturns :: Name,
        cQuals :: Set Qualifier
    }
    -- Legacy: constructor params (TODO replace with general local var case)
    | CxxLegacyCTorParams {
        cPath :: Text,
        cScope :: [Name],
        cName :: Name
      }
    -- Fall back: any symbol
    | CxxAny {
        cPath :: Text,
        cScope :: [Name],
        cName :: Name
      }
  
  unNames :: [Name] -> [Text]
  unNames = map unName
  
  --
  -- Refine the parsed symbol tokens into a more precise symbol id query ADT
  --
  compileSymbolEnv :: SymbolEnv -> Either Text CxxTaggedSymbolExpr
  compileSymbolEnv env@SymbolEnv{..} = case tag of
    Just CTorSignature ->
      Right $ tagged declaration $ CxxConstructor { -- .c
          cPath = path,
          cScope = scopes,
          cParams = params
      }
    Just Destructor -> -- .d
      Right $ tagged declaration $ CxxDestructor {
          cPath = path,
          cScope = scopes
      }
    Just Function  -- .f
      | Just name <- localname ->
        Right $ tagged declaration $ CxxFunction {
            cPath = path,
            cScope = scopes,
            cName = name,
            cParams = params,
            cQuals = qualifiers
        }
      | otherwise ->
        Left $ "compileSymbolEnv: Function missing local name: " <> textShow env
  
    Just Operator -- .o
      | Just name <- localname ->
        Right $ tagged declaration $ CxxOperator {
            cPath = path,
            cScope = scopes,
            cName = name,
            cParams = params,
            cQuals = qualifiers
        }
      | otherwise ->
        Left $ "compileSymbolEnv: Operator missing name: " <> textShow env
  
    Just TypeConversionOperator -- .t
      | Just returnTy <- returns ->
        Right $ tagged declaration $ CxxTypeConversionOperator {
            cPath = path,
            cScope = scopes,
            cReturns = returnTy,
            cQuals = qualifiers
        }
      | otherwise ->
        Left $ "compileSymbolEnv: Type conversion operator: missing type: "
          <> textShow env
  
    Just Constructor -- legacy .ctor params, aka local vars in ctor scope
      | Just name <- localname ->
      Right $ tagged declaration $ CxxLegacyCTorParams {
          cPath = path,
          cScope = scopes,
          cName = name
      }
      | otherwise ->
        Left "compileSymbolEnv: constructor params missing local name"
    Nothing
      | Just name <- localname ->
        Right $ tagged declaration $ CxxAny {
            cPath = path,
            cScope = scopes,
            cName = name
        }
      | otherwise ->
        Left "compileSymbolEnv: CxxAny: missing local name for entity"
  
  initState :: Text -> SymbolEnv
  initState p = SymbolEnv {
      path = p,
      scopes = mempty,
      localname = Nothing,
      declaration = False,
      tag = Nothing,
      params = [],
      returns = Nothing,
      qualifiers = mempty,
      errors = []
    }
  
  pushScope :: Text -> Parse ()
  pushScope s = modify' $ \env -> env { scopes = name s : scopes env }
  
  pushParam :: Text -> Parse ()
  pushParam s = modify' $ \env -> env { params = sig s : params env }
  
  setReturnType :: Text -> Parse ()
  setReturnType s = modify' $ \env -> env { returns = Just (sig s) }
  
  setName :: Text -> Parse ()
  setName n = modify' $ \env -> env { localname = Just (name n) }
  
  pushQualifier :: Qualifier -> Parse ()
  pushQualifier q = modify' $ \env ->
      env { qualifiers = Set.insert q (qualifiers env)
    }
  
  setTag :: SymbolTag -> Parse ()
  setTag t = modify' $ \env -> env { tag = Just t }
  
  setDecl :: Parse ()
  setDecl = modify' $ \env -> env { declaration = True }
  
  setErr :: Text -> Parse ()
  setErr s = modify' $ \env -> env { errors = s : errors env }
  
  --
  -- | Parse the symbol id term
  --
  validateSymbolId :: [Text] -> Either [Text] SymbolEnv
  validateSymbolId toks = case toks of
    [] -> Left ["Cxx.parseSymbolId: empty symbol"]
    [_] -> Left ["Cxx.parseSymbolId: incomplete symbol:" <> textShow toks]
    path:name:rest ->
      let env = execState
                 (parseOneName (tokenize name) (map tokenize rest))
                 (initState path)
      in case errors env of
          [] -> Right $ env { scopes = reverse (scopes env)
                            , params = reverse (params env)
                            }
          errs -> Left errs
  
  -- | at least one name is required
  parseOneName :: Token -> [Token] -> Parse ()
  parseOneName (TName name) rest = parseScopeOrName name rest
  parseOneName tok _ = setErr $
    "Cxx.parseScopedSymbol: expected identifier, found tag:" <> textShow tok
  
  -- | scope* name (tag*)
  parseScopeOrName :: Text -> [Token] -> Parse ()
  parseScopeOrName name [] = setName name -- last identifier is always name
  parseScopeOrName name (n : ns) = case n of
    TName n -> pushScope name >> parseScopeOrName n ns
    TCtor -> pushScope name >> setTag Constructor >> parseCtor ns
    TDtor -> pushScope name >> setTag Destructor >> parseDtor ns
    TCtorSignature -> pushScope name >> setTag CTorSignature >> parseCtorSig ns
    TFunction -> setName name >> setTag Function >> parseFunctionSig ns
    TOperator -> setName name >> setTag Operator >> parseFunctionSig ns
    TConversionOperator ->
      pushScope name >> setTag TypeConversionOperator >> parseTypeOperatorSig ns
    TDecl -> do
      setName name >> setDecl
      case ns of
        [] -> pure ()
        _ -> setErr $
          "Cxx.parseScopedSymbol: unexpected tokens after .decl in symbol id: "
            <> textShow ns
  
  -- | following /.ctor/ can only be:
  --
  -- > name
  -- > name / .decl
  -- > .
  --
  parseCtor :: [Token] -> Parse ()
  parseCtor [] = return () -- ctor definition occurence
  parseCtor [TDecl] = setDecl -- a ctor decl . subsumed by CtorSig.
  parseCtor [TName name, TDecl] = setName name >> setDecl -- ctor parameter decl
  parseCtor rest = setErr $
    "Cxx.parseCtor: unexpected trailing tokens in .ctor signature: " <>
      textShow rest
  
  parseDtor :: [Token] -> Parse ()
  parseDtor [] = return ()
  parseDtor [TDecl] = setDecl
  parseDtor rest = setErr $
    "Cxx.parseDtor: unexpected trailing tokens in destructor: " <>
      textShow rest
  
  parseCtorSig :: [Token] -> Parse ()
  -- constructor with no params
  parseCtorSig [] = return ()
  -- one or more param signatures
  parseCtorSig [TName name] = mapM_ pushParam params
    where
      params = splitCommas name
  
  -- nullary construct decl
  parseCtorSig [TDecl] = setDecl
  
  -- one or more param signatures decl
  parseCtorSig [TName name, TDecl] =
      mapM_ pushParam params >> setDecl
    where
      params = splitCommas name
  parseCtorSig rest = setErr $
    "Cxx.parseCtorSig: unexpected trailing tokens in .ctor signature: " <>
      textShow rest
  
  --
  -- Type conversion operators: a single return type and optional qualifiers
  --
  parseTypeOperatorSig :: [Token] -> Parse ()
  parseTypeOperatorSig [] = setErr $
    "Cxx.parseTypeOperatorSig: missing type name for conversion symbol"
  parseTypeOperatorSig [TDecl] = setErr $
    "Cxx.parseTypeOperatorSig: missing type name for conversion decl symbol"
  parseTypeOperatorSig [TName name] = -- return type only, no qualifiers
    setReturnType name
  parseTypeOperatorSig [TName name, TDecl] =
    setReturnType name >> setDecl
  parseTypeOperatorSig [TName name, TName quals] = -- return type and quals
    setReturnType name >> mapM_ parseQualifier (splitCommas quals)
  parseTypeOperatorSig [TName name, TName quals, TDecl] = do -- decl variant
    setReturnType name
    mapM_ parseQualifier (splitCommas quals)
    setDecl
  parseTypeOperatorSig rest = setErr $
    "Cxx.parseTypeOperatorSig: unexpected trailing tokens in operator: " <>
      textShow rest
  
  --
  -- Function signatures always have parameter types if non-nullary
  --
  parseFunctionSig :: [Token] -> Parse ()
  -- nullary definition
  parseFunctionSig [] = pure ()
  -- nullary construct decl
  parseFunctionSig [TDecl] =
    setDecl
  
  parseFunctionSig [TName name] = do -- single set of params (or trailing "/")
    mapM_ pushParam (splitCommas name)
  parseFunctionSig [TName name, TDecl] = do -- decl variant
    mapM_ pushParam (splitCommas name) >> setDecl
  
  parseFunctionSig [TName name, TName quals] = do -- set of params and quals
    mapM_ pushParam (splitCommas name)
    mapM_ parseQualifier (splitCommas quals)
  parseFunctionSig [TName name, TName quals, TDecl] = do -- decl variant
    mapM_ pushParam (splitCommas name)
    mapM_ parseQualifier (splitCommas quals)
    setDecl
  
  parseFunctionSig rest = setErr $
    "Cxx.parseCtorSig: unexpected trailing tokens in .ctor signature: " <>
      textShow rest
  
  -- | type signatures are a single token separated by commas
  splitCommas :: Text -> [Text]
  splitCommas "" = []
  splitCommas xs = Text.splitOn "," xs
  
  parseQualifier :: Text -> Parse ()
  parseQualifier s = case toQualifier s of
    Just x -> pushQualifier x
    Nothing -> setErr $ "parseQualifier: invalid qualifier: " <> s
  
  -- | Parse cv qualfier encodings
  toQualifier :: Text -> Maybe Qualifier
  toQualifier s = case s of
    "virtual" -> Just Virtual
    "const" -> Just Const
    "volatile" -> Just Volatile
    "lvalue" -> Just (RefQual LValue)
    "rvalue" -> Just (RefQual RValue)
    _ -> Nothing
  