content: {-# LANGUAGE OverloadedStrings #-}
  
  -- |
  -- SPDX-License-Identifier: BSD-3-Clause
  --
  -- Parser for terms of the Swarm language.
  module Swarm.Language.Parser.Term where
  
  import Control.Lens (view, (^.))
  import Control.Monad (guard, join)
  import Control.Monad.Combinators.Expr
  import Data.Foldable (Foldable (..), asum)
  import Data.Functor (($>))
  import Data.Map (Map)
  import Data.Map qualified as M
  import Data.Maybe (mapMaybe)
  import Data.Set qualified as S
  import Data.Set.Lens (setOf)
  import Data.Text qualified as T
  import Swarm.Language.Parser.Core
  import Swarm.Language.Parser.Lex
  import Swarm.Language.Parser.Record (parseRecord)
  import Swarm.Language.Parser.Type
  import Swarm.Language.Syntax
  import Swarm.Language.Syntax.Direction
  import Swarm.Language.Types
  import Swarm.Util (failT, findDup)
  import Text.Megaparsec hiding (runParser)
  import Text.Megaparsec.Char
  import Prelude hiding (Foldable (..))
  
  -- Imports for doctests (cabal-docspec needs this)
  
  -- $setup
  -- >>> import qualified Data.Map.Strict as M
  
  --------------------------------------------------
  -- Parser
  
  parseDirection :: Parser Direction
  parseDirection = asum (map alternative allDirs) <?> "direction constant"
   where
    alternative d = d <$ (reserved . directionSyntax) d
  
  -- | Parse Const as reserved words (e.g. @Fail <$ reserved "fail"@)
  parseConst :: Parser Const
  parseConst = do
    ver <- view languageVersion
    asum (map (alternative ver) consts) <?> "built-in user function"
   where
    consts = filter isUserFunc allConst
    alternative ver c = c <$ reserved (syntax $ constInfo' ver c)
  
    -- Version 0.6 of the language had a constant named @return@, which
    -- is now renamed to @pure@
    constInfo' SwarmLang0_6 Pure = (constInfo Pure) {syntax = "return"}
    constInfo' _ c = constInfo c
  
  -- | Parse an atomic term, optionally trailed by record projections like @t.x.y.z@.
  --   Record projection binds more tightly than function application.
  parseTermAtom :: Parser Syntax
  parseTermAtom = do
    s1 <- parseTermAtom2
    ps <- many (symbol "." *> parseLocG tmVar)
    return $ foldl' (\(Syntax l1 t) (l2, x) -> Syntax (l1 <> l2) (TProj t x)) s1 ps
  
  -- | Parse an atomic term.
  parseTermAtom2 :: Parser Syntax
  parseTermAtom2 =
    parseLoc
      ( TUnit <$ symbol "()"
          <|> TConst <$> parseConst
          <|> TVar <$> tmVar
          <|> TDir <$> parseDirection
          <|> TInt <$> integer
          <|> TText <$> textLiteral
          <|> TBool <$> ((True <$ reserved "true") <|> (False <$ reserved "false"))
          <|> reserved "require" *> parseRequire
          <|> reserved "stock" *> parseStock
          <|> uncurry SRequirements <$> (reserved "requirements" *> match parseTerm)
          <|> SLam
            <$> (symbol "\\" *> locTmVar)
            <*> optional (symbol ":" *> parseType)
            <*> (symbol "." *> parseTerm)
          <|> sLet LSLet
            <$> (reserved "let" *> locTmVar)
            <*> optional (symbol ":" *> parsePolytype)
            <*> (symbol "=" *> parseTerm)
            <*> (reserved "in" *> parseTerm)
          <|> do
            reserved "def"
            locVar@(LV _srcLoc nameText) <- locTmVar
            mTy <- optional (symbol ":" *> parsePolytype)
            _ <- symbol "="
            body <- parseTerm
            reserved "end" <?> ("'end' keyword for definition of '" <> T.unpack nameText <> "'")
            rest <- optional (symbol ";") *> (parseTerm <|> (eof $> sNoop))
            return $ sLet LSDef locVar mTy body rest
          <|> STydef
            <$> (reserved "tydef" *> locTyName)
            <*> join (bindTydef <$> many tyVar <*> (symbol "=" *> parseType <* reserved "end"))
            <*> pure Nothing
            <*> (optional (symbol ";") *> (parseTerm <|> (eof $> sNoop)))
          <|> SRcd <$> brackets (parseRecord (optional (symbol "=" *> parseTerm)))
          <|> TType <$> (symbol "@" *> parseTypeAtom)
      )
      <|> parseLoc (mkTuple <$> parens (parseTerm `sepBy` symbol ","))
      <|> parseLoc (TDelay (TConst Noop) <$ try (symbol "{" *> symbol "}"))
      <|> parseLoc (SDelay <$> braces parseTerm)
      <|> parseLoc (view antiquoting >>= (guard . (== AllowAntiquoting)) >> parseAntiquotation)
  
  -- | Parse the contents of a @require@ statement: either requiring a device, or
  --   (if parsing v0.6) requiring inventory stock.
  parseRequire :: Parser Term
  parseRequire = do
    ver <- view languageVersion
    asum
      [ TRequire <$> (textLiteral <?> "device name in double quotes")
      , guard (ver == SwarmLang0_6) *> parseStock
      ]
  
  parseStock :: Parser Term
  parseStock =
    (TStock . fromIntegral <$> integer)
      <*> (textLiteral <?> "entity name in double quotes")
  
  -- | Construct an 'SLet', automatically filling in the Boolean field
  --   indicating whether it is recursive.
  sLet :: LetSyntax -> LocVar -> Maybe RawPolytype -> Syntax -> Syntax -> Term
  sLet ls x ty t1 = SLet ls (lvVar x `S.member` setOf freeVarsV t1) x ty Nothing mempty t1
  
  sNoop :: Syntax
  sNoop = STerm (TConst Noop)
  
  -- | Create a polytype from a list of variable binders and a type.
  --   Ensure that no binder is repeated, and all type variables in the
  --   type are present in the list of binders (/i.e./ the type contains
  --   no free type variables).
  bindTydef :: [Var] -> Type -> Parser Polytype
  bindTydef xs ty
    | Just repeated <- findDup xs =
        failT ["Duplicate variable on left-hand side of tydef:", repeated]
    | not (S.null free) =
        failT $
          "Undefined type variable(s) on right-hand side of tydef:" : S.toList free
    | otherwise = return . absQuantify $ mkPoly xs ty
   where
    free = tyVars ty `S.difference` S.fromList xs
  
  parseAntiquotation :: Parser Term
  parseAntiquotation =
    TAntiText <$> (lexeme . try) (symbol "$str:" *> tmVar)
      <|> TAntiInt <$> (lexeme . try) (symbol "$int:" *> tmVar)
      <|> TAntiSyn <$> (lexeme . try) (symbol "$syn:" *> tmVar)
  
  -- | Parse a Swarm language term.
  parseTerm :: Parser Syntax
  parseTerm = sepEndBy1 parseStmt (symbol ";") >>= mkBindChain
  
  mkBindChain :: [Stmt] -> Parser Syntax
  mkBindChain stmts = case last stmts of
    Binder x _ -> return $ foldr mkBind (STerm (TApp (TConst Pure) (TVar (lvVar x)))) stmts
    BareTerm t -> return $ foldr mkBind t (init stmts)
   where
    mkBind (BareTerm t1) t2 = loc Nothing t1 t2 $ SBind Nothing Nothing Nothing Nothing t1 t2
    mkBind (Binder x t1) t2 = loc (Just x) t1 t2 $ SBind (Just x) Nothing Nothing Nothing t1 t2
    loc mx a b = Syntax $ maybe NoLoc lvSrcLoc mx <> (a ^. sLoc) <> (b ^. sLoc)
  
  data Stmt
    = BareTerm Syntax
    | Binder LocVar Syntax
    deriving (Show)
  
  parseStmt :: Parser Stmt
  parseStmt =
    mkStmt <$> optional (try (locTmVar <* symbol "<-")) <*> parseExpr
  
  mkStmt :: Maybe LocVar -> Syntax -> Stmt
  mkStmt Nothing = BareTerm
  mkStmt (Just x) = Binder x
  
  parseExpr :: Parser Syntax
  parseExpr =
    parseLoc $ ascribe <$> parseExpr' <*> optional (symbol ":" *> parsePolytype)
   where
    ascribe :: Syntax -> Maybe RawPolytype -> Term
    ascribe s Nothing = s ^. sTerm
    ascribe s (Just ty) = SAnnotate s ty
  
  parseExpr' :: Parser Syntax
  parseExpr' = makeExprParser parseTermAtom table
   where
    table = snd <$> M.toDescList tableMap
    tableMap =
      M.unionsWith
        (++)
        [ M.singleton 9 [InfixL (exprLoc2 $ SApp <$ string "")]
        , binOps
        , unOps
        ]
  
    -- add location for ExprParser by combining all
    exprLoc2 :: Parser (Syntax -> Syntax -> Term) -> Parser (Syntax -> Syntax -> Syntax)
    exprLoc2 p = do
      (l, f) <- parseLocG p
      pure $ \s1 s2 -> Syntax (l <> (s1 ^. sLoc) <> (s2 ^. sLoc)) $ f s1 s2
  
  -- | Precedences and parsers of binary operators.
  --
  -- >>> M.map length binOps
  -- fromList [(0,1),(2,1),(3,1),(4,6),(6,3),(7,2),(8,1)]
  binOps :: Map Int [Operator Parser Syntax]
  binOps = M.unionsWith (++) $ mapMaybe binOpToTuple allConst
   where
    binOpToTuple c = do
      let ci = constInfo c
      ConstMBinOp assoc <- pure (constMeta ci)
      let assI = case assoc of
            L -> InfixL
            N -> InfixN
            R -> InfixR
      pure $
        M.singleton
          (fixity ci)
          [assI (mkOp c <$> parseLocG (operator (syntax ci)))]
  
  -- | Precedences and parsers of unary operators (currently only 'Neg').
  --
  -- >>> M.map length unOps
  -- fromList [(7,1)]
  unOps :: Map Int [Operator Parser Syntax]
  unOps = M.unionsWith (++) $ mapMaybe unOpToTuple allConst
   where
    unOpToTuple c = do
      let ci = constInfo c
      ConstMUnOp assoc <- pure (constMeta ci)
      let assI = case assoc of
            P -> Prefix
            S -> Postfix
      pure $
        M.singleton
          (fixity ci)
          [assI (exprLoc1 $ SApp (noLoc $ TConst c) <$ operator (syntax ci))]
  
    -- combine location for ExprParser
    exprLoc1 :: Parser (Syntax -> Term) -> Parser (Syntax -> Syntax)
    exprLoc1 p = do
      (l, f) <- parseLocG p
      pure $ \s -> Syntax (l <> s ^. sLoc) $ f s
  