diff --git a/lib/Elaborator.hs b/lib/Elaborator.hs index 6867a61..c855207 100644 --- a/lib/Elaborator.hs +++ b/lib/Elaborator.hs @@ -1,50 +1,97 @@ module Elaborator where +import Control.Monad.Except import Data.List (elemIndex) +import Data.List.NonEmpty ((<|)) +import Errors (Error (..), Result) import Expr (Expr) import qualified Expr as E -import IR (IRExpr) +import IR (IRDef (..), IRExpr) import qualified IR as I +import Relude.Extra.Lens type Binders = [Text] -saveBinders :: State Binders a -> State Binders a -saveBinders action = do - binders <- get - res <- action - put binders - pure res +data SectionContext = SectionContext + { sectionDefs :: [(Text, [Text])] -- name and list of variables it depends on + , sectionVars :: [(Text, IRExpr)] -- variables and their types + } -elaborate :: IRExpr -> Expr -elaborate ir = evalState (elaborate' ir) [] +type ElabMonad = StateT (NonEmpty SectionContext) Result + +sectionDefsL :: Lens' SectionContext [(Text, [Text])] +sectionDefsL = lens sectionDefs setter where - helper :: (Monad m) => Maybe a -> (a -> m b) -> m (Maybe b) - helper Nothing _ = pure Nothing - helper (Just x) f = Just <$> f x + setter ctxt newDefs = ctxt{sectionDefs = newDefs} - elaborate' :: IRExpr -> State Binders Expr - elaborate' (I.Var n) = do - binders <- get - pure $ E.Var n . fromIntegral <$> elemIndex n binders ?: E.Free n - elaborate' I.Star = pure E.Star - elaborate' (I.Level level) = pure $ E.Level level - elaborate' (I.App m n) = E.App <$> elaborate' m <*> elaborate' n - elaborate' (I.Abs x t a b) = saveBinders $ do - t' <- elaborate' t - a' <- helper a elaborate' - modify (x :) - E.Abs x t' a' <$> elaborate' b - elaborate' (I.Pi x t a b) = saveBinders $ do - t' <- elaborate' t - a' <- helper a elaborate' - modify (x :) - E.Pi x t' a' <$> elaborate' b - elaborate' (I.Let name Nothing val body) = saveBinders $ do - val' <- elaborate' val - modify (name :) - E.Let name Nothing val' <$> elaborate' body - elaborate' (I.Let name (Just ty) val body) = saveBinders $ do - val' <- elaborate' val - ty' <- elaborate' ty - modify (name :) - E.Let name (Just ty') val' <$> elaborate' body +sectionVarsL :: Lens' SectionContext [(Text, IRExpr)] +sectionVarsL = lens sectionVars setter + where + setter ctxt newVars = ctxt{sectionVars = newVars} + +saveState :: ElabMonad a -> ElabMonad a +saveState action = get >>= (action <*) . put + +elabSection :: Text -> [IRDef] -> ElabMonad [IRDef] +elabSection _name contents = saveState $ do + modify (SectionContext [] [] <|) + concat <$> forM contents elabDef + +pushVariable :: Text -> IRExpr -> NonEmpty SectionContext -> NonEmpty SectionContext +pushVariable name ty (SectionContext defs vars :| rest) = SectionContext defs ((name, ty) : vars) :| rest + +elabDef :: IRDef -> ElabMonad [IRDef] +elabDef (Def name ty body) = undefined +elabDef (Axiom name ty) = undefined +elabDef (Section name contents) = elabSection name contents +elabDef (Variable name ty) = [] <$ modify' (pushVariable name ty) + +traverseDef :: [Text] -> IRExpr -> ElabMonad [Text] +traverseDef seen (I.Var _) = pure seen +traverseDef seen I.Star = pure seen +traverseDef seen (I.Level _) = pure seen +traverseDef seen (I.App m n) = (++) <$> traverseDef seen m <*> traverseDef seen n + +-- game plan: +-- 1. add arguments to section local definitions + +-- saveBinders :: State Binders a -> State Binders a +-- saveBinders action = do +-- binders <- get +-- res <- action +-- put binders +-- pure res +-- +-- elaborate :: IRExpr -> Expr +-- elaborate ir = evalState (elaborate' ir) [] +-- where +-- helper :: (Monad m) => Maybe a -> (a -> m b) -> m (Maybe b) +-- helper Nothing _ = pure Nothing +-- helper (Just x) f = Just <$> f x +-- +-- elaborate' :: IRExpr -> State Binders Expr +-- elaborate' (I.Var n) = do +-- binders <- get +-- pure $ E.Var n . fromIntegral <$> elemIndex n binders ?: E.Free n +-- elaborate' I.Star = pure E.Star +-- elaborate' (I.Level level) = pure $ E.Level level +-- elaborate' (I.App m n) = E.App <$> elaborate' m <*> elaborate' n +-- elaborate' (I.Abs x t a b) = saveBinders $ do +-- t' <- elaborate' t +-- a' <- helper a elaborate' +-- modify (x :) +-- E.Abs x t' a' <$> elaborate' b +-- elaborate' (I.Pi x t a b) = saveBinders $ do +-- t' <- elaborate' t +-- a' <- helper a elaborate' +-- modify (x :) +-- E.Pi x t' a' <$> elaborate' b +-- elaborate' (I.Let name Nothing val body) = saveBinders $ do +-- val' <- elaborate' val +-- modify (name :) +-- E.Let name Nothing val' <$> elaborate' body +-- elaborate' (I.Let name (Just ty) val body) = saveBinders $ do +-- val' <- elaborate' val +-- ty' <- elaborate' ty +-- modify (name :) +-- E.Let name (Just ty') val' <$> elaborate' body diff --git a/lib/Errors.hs b/lib/Errors.hs index 5e2dda5..97629ff 100644 --- a/lib/Errors.hs +++ b/lib/Errors.hs @@ -9,6 +9,7 @@ data Error | NotEquivalent Expr Expr Expr | PNMissingType Text | DuplicateDefinition Text + | EmptySection Text deriving (Eq, Ord) instance ToText Error where @@ -18,6 +19,7 @@ instance ToText Error where toText (NotEquivalent a a' e) = "Cannot unify '" <> pretty a <> "' with '" <> pretty a' <> "' when evaluating '" <> pretty e <> "'" toText (PNMissingType x) = "Axiom '" <> x <> "' missing type ascription" toText (DuplicateDefinition n) = "'" <> n <> "' already defined" + toText (EmptySection var) = "Tried to declare variable " <> var <> " without a section" instance ToString Error where toString = toString . toText