radicle-surf 0.29.0

module Radicle.Lang.Eval
    ( eval
    , baseEval
    , callFn
    , ($$)
    , createModule
    ) where

import           Protolude hiding (Constructor, Handle, TypeError, (<>))

import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import           Data.Semigroup ((<>))
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified GHC.Exts as GhcExts

import           Radicle.Lang.Core
import qualified Radicle.Lang.Doc as Doc
import           Radicle.Lang.Identifier (Ident(..))
import           Radicle.Lang.Internal.Orphans ()

-- | The built-in, original, eval.
baseEval :: Monad m => Value -> Lang m Value
baseEval val = logValPos val $ case val of
    Atom i -> lookupAtom i
    List (f:vs) -> f $$ vs
    List xs -> throwErrorHere
        $ WrongNumberOfArgs ("application: " <> show xs)
                            2
                            (length xs)
    Vec xs -> Vec <$> traverse baseEval xs
    Dict mp -> do
        let evalBoth (a,b) = (,) <$> baseEval a <*> baseEval b
        kvs <- traverse evalBoth (Map.toList mp)
        dict $ Map.fromList kvs
    autoquote -> pure autoquote


-- | The buck-passing eval. Uses whatever 'eval' is in scope.
eval :: Monad m => Value -> Lang m Value
eval val = do
    e <- lookupAtom (Ident "eval")
    logValPos e $ do
        st <- gets bindingsToRadicle
        result <- callFn e [val, st]
        case result of
            List [val', newSt] -> do
                setBindings newSt
                pure val'
            _ -> throwErrorHere
               $ OtherError "eval: should return list with value and new env"



specialForms :: forall m. (Monad m) => Map Ident ([Value] -> Lang m Value)
specialForms = Map.fromList $ first Ident <$>
  [ ( "fn"
    , \case
          args : b : bs -> do
            e <- gets bindingsEnv
            let toLambda argNames = pure (Lambda argNames (b :| bs) e)
            case args of
              Vec atoms_ -> do
                atoms <- traverse isAtom (toList atoms_) ?? toLangError (SpecialForm "fn" "One of the arguments was not an atom")
                toLambda (PosArgs atoms)
              Atom name -> do
                toLambda (VarArgs name)
              _ -> throwErrorHere $ SpecialForm "fn" "Function parameters must be one atom or a vector of atoms"
          _ -> throwErrorHere $ SpecialForm "fn" "Function needs parameters (one atom or a vector of atoms) and a body"
      )
  , ( "module", createModule )
  , ("quote", \case
          [v] -> pure v
          xs  -> throwErrorHere $ WrongNumberOfArgs "quote" 1 (length xs))
  , ("def", \case
          [Atom name, val] -> def name Nothing val
          [_, _]           -> throwErrorHere $ OtherError "def expects atom for first arg"
          [Atom name, String d, val] -> def name (Just d) val
          xs -> throwErrorHere $ WrongNumberOfArgs "def" 2 (length xs))
    , ( "def-rec"
      , \case
          [Atom name, val] -> defRec name Nothing val
          [_, _]           -> throwErrorHere $ OtherError "def-rec expects atom for first arg"
          [Atom name, String d, val] -> defRec name (Just d) val
          xs               -> throwErrorHere $ WrongNumberOfArgs "def-rec" 2 (length xs)
      )
    , ("do", (lastDef nil <$>) . traverse baseEval)
    , ("catch", \case
          [l, form, handler] -> do
              mlabel <- baseEval l
              s <- get
              case mlabel of
                  -- TODO reify stack
                  Atom label -> baseEval form `catchError` \err@(LangError _stack e) -> do
                     (thrownLabel, thrownValue) <- errorDataToValue e
                     if thrownLabel == label || label == Ident "any"
                         then do
                            put s
                            handlerclo <- baseEval handler
                            callFn handlerclo [thrownValue]
                         else throwError err
                  _ -> throwErrorHere $ SpecialForm "catch" "first argument must be atom"
          xs -> throwErrorHere $ WrongNumberOfArgs "catch" 3 (length xs))
    , ("if", \case
          [condition, t, f] -> do
            b <- baseEval condition
            -- I hate this as much as everyone that might ever read Haskell, but
            -- in Lisps a lot of things that one might object to are True...
            if b == Boolean False then baseEval f else baseEval t
          xs -> throwErrorHere $ WrongNumberOfArgs "if" 3 (length xs))
    , ( "cond", (cond =<<) . evenArgs "cond" )
    , ( "match", match )
  ]
  where
    cond = \case
      [] -> pure nil
      (c,e):ps -> do
        b <- baseEval c
        if b /= Boolean False
          then baseEval e
          else cond ps

    match = \case
      v : cases -> do
        cs <- evenArgs "match" cases
        v' <- baseEval v
        goMatches v' cs
      _ -> throwErrorHere $ PatternMatchError NoValue

    goMatches _ [] = throwErrorHere (PatternMatchError NoMatch)
    goMatches v ((m, body):cases) = do
      patFn <- baseEval m
      matchPat <- lookupAtom (Ident "match-pat")
      res <- callFn matchPat [patFn, v]
      let res_ = fromRad res
      case res_ of
        Right (Just (Dict binds)) -> do
          b <- bindsToEnv m binds
          addBinds b *> baseEval body
        Right Nothing -> goMatches v cases
        _ -> throwErrorHere $ PatternMatchError (BadBindings m)

    bindsToEnv pat m = do
        is <- traverse isBind (Map.toList m)
        pure $ Env (Map.fromList is)
      where
        isBind (Atom x, v) = pure (x, Doc.Docd Nothing v)
        isBind _ = throwErrorHere $ PatternMatchError (BadBindings pat)

    addBinds e = modify (\s -> s { bindingsEnv = e <> bindingsEnv s })

    def name doc_ val = do
      val' <- baseEval val
      defineAtom name doc_ val'
      pure nil

    defRec name doc_ val = do
      val' <- baseEval val
      case val' of
        Lambda is b e -> do
          defineAtom name doc_ $ LambdaRec name is b e
          pure nil
        LambdaRec{} -> throwErrorHere $
            OtherError "'def-rec' cannot be used to alias functions. Use 'def' instead"
        _ -> throwErrorHere $ OtherError "'def-rec' can only be used to define functions"

data ModuleMeta = ModuleMeta
  { name    :: Ident
  , exports :: [Ident]
  , doc     :: Text
  }

-- | Given a list of forms, the first of which should be module declaration,
-- runs the rest of the forms in a new scope, and then defs the module value
-- according to the name in the declaration.
createModule :: forall m. Monad m => [Value] -> Lang m Value
createModule = \case
    (m : forms) -> do
      m' <- baseEval m >>= meta
      e <- withEnv identity $ traverse_ eval forms *> gets bindingsEnv
      let exportsSet = Set.fromList (exports m')
      let undefinedExports = Set.difference exportsSet (Map.keysSet (fromEnv e))
      env <- if null undefinedExports
               then pure . VEnv . Env $ Map.restrictKeys (fromEnv e) exportsSet
               else throwErrorHere (ModuleError (UndefinedExports (name m') (Set.toList undefinedExports)))
      let modu = Dict $ Map.fromList
                  [ (Keyword (Ident "module"), Atom (name m'))
                  , (Keyword (Ident "env"), env)
                  , (Keyword (Ident "exports"), Vec (Seq.fromList (Atom <$> exports m')))
                  ]
      defineAtom (name m') (Just (doc m')) modu
      pure modu
    _ ->  throwErrorHere (ModuleError MissingDeclaration)
  where
    meta v@(Dict d) = do
      name <- modLookup v "module" d "missing `:module` key"
      doc  <- modLookup v "doc" d "missing `:doc` key"
      exports <- modLookup v "exports" d "Missing `:exports` key"
      case (name, doc, exports) of
        (Atom n, String ds, Vec es) -> do
          is <- traverse isAtom es ?? toLangError (ModuleError (InvalidDeclaration "`:exports` must be a vector of atoms" v))
          pure $ ModuleMeta n (toList is) ds
        _ -> throwErrorHere (ModuleError (InvalidDeclaration "`:module` must be an atom, `:doc` must be a string and `:exports` must be a vector" v))
    meta v = throwErrorHere (ModuleError (InvalidDeclaration "must be dict" v))
    modLookup v k d e = kwLookup k d ?? toLangError (ModuleError (InvalidDeclaration e v))


-- | Call a lambda or primitive function @f@ with @arguments@. @f@ and
-- @argumenst@ are not evaluated.
callFn :: forall m. Monad m => Value -> [Value] -> Lang m Value
callFn f arguments = case f of
    Lambda argNames body closure -> do
        args <- argumentBindings argNames
        evalManyWithEnv (args <> closure) body
    LambdaRec self argNames body closure -> do
        args <- argumentBindings argNames
        let selfBinding = GhcExts.fromList (Doc.noDocs [(self, f)])
        evalManyWithEnv (args <> selfBinding <> closure) body
    PrimFn i -> do
        fn <- lookupPrimop i
        fn arguments
    _ -> throwErrorHere $ NonFunctionCalled f
  where
    evalManyWithEnv :: Env Value -> NonEmpty Value -> Lang m Value
    evalManyWithEnv env exprs =
        NonEmpty.last <$> withEnv (const env) (traverse baseEval exprs)
    argumentBindings :: LambdaArgs -> Lang m (Env Value)
    argumentBindings argNames = case argNames of
      PosArgs names ->
        if length names /= length arguments
        then throwErrorHere $ WrongNumberOfArgs "lambda" (length names) (length arguments)
        else toArgs $ zip names arguments
      VarArgs name ->
        toArgs [(name, Vec $ Seq.fromList arguments)]
      where toArgs = pure . GhcExts.fromList . Doc.noDocs

-- | Process special forms or call function. If @f@ is an atom that
-- indicates a special form that special form is processed. Otherwise
-- @f@ and @vs@ are evaluated in 'callFn' is called.
infixr 1 $$
($$) :: Monad m => Value -> [Value] -> Lang m Value
f $$ vs = case f of
    Atom i ->
      case Map.lookup i specialForms of
        Just form -> form vs
        Nothing   -> fnApp
    _ -> fnApp
  where
    fnApp = do
      f' <- baseEval f
      vs' <- traverse baseEval vs
      callFn f' vs'