rhi/quox
rhi/quox
1
0
Fork 0
Code Issues 15 Pull requests 1 Releases Wiki Activity

add check for #[main] type

Browse source
This commit is contained in:
rhiannon morris 2024-04-14 16:20:40 +02:00
parent dd697ba56e
commit b7dc5ffdc4
1 changed files with 15 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
lib/Quox/Parser/FromParser.idr
View file

@ -8,6 +8,7 @@ import Quox.Parser.Syntax
import Quox.Parser.Parser import Quox.Parser.Parser
import public Quox.Parser.LoadFile import public Quox.Parser.LoadFile
import Quox.Typechecker import Quox.Typechecker
import Quox.CheckBuiltin
import Data.List import Data.List
import Data.Maybe import Data.Maybe
@ -333,6 +334,13 @@ liftTC tc = runEff tc $ with Union.(::)
\g => send g, \g => send g,
\g => send g] \g => send g]
private
liftWhnf : Eff Whnf a -> Eff FromParserPure a
liftWhnf tc = runEff tc $ with Union.(::)
[handleExcept $ \e => throw $ WrapTypeError e,
\g => send g,
\g => send g]
private private
addDef : Has DefsState fs => Name -> Definition -> Eff fs NDefinition addDef : Has DefsState fs => Name -> Definition -> Eff fs NDefinition
addDef name def = do addDef name def = do
@ -344,7 +352,8 @@ export covering
fromPDef : PDefinition -> Eff FromParserPure NDefinition fromPDef : PDefinition -> Eff FromParserPure NDefinition
fromPDef def = do fromPDef def = do
name <- fromPBaseNameNS def.name name <- fromPBaseNameNS def.name
when !(getsAt DEFS $ isJust . lookup name) $ do defs <- getAt DEFS
when (isJust $ lookup name defs) $ do
throw $ AlreadyExists def.loc name throw $ AlreadyExists def.loc name
gqty <- globalPQty def.qty gqty <- globalPQty def.qty
let sqty = globalToSubj gqty let sqty = globalToSubj gqty
@ -352,17 +361,19 @@ fromPDef def = do
PConcrete ptype pterm => do PConcrete ptype pterm => do
type <- traverse fromPTerm ptype type <- traverse fromPTerm ptype
term <- fromPTerm pterm term <- fromPTerm pterm
case type of type <- case type of
Just type => do Just type => do
ignore $ liftTC $ do ignore $ liftTC $ do
checkTypeC empty type Nothing checkTypeC empty type Nothing
checkC empty sqty term type checkC empty sqty term type
addDef name $ mkDef gqty type term def.scheme def.main def.loc pure type
Nothing => do Nothing => do
let E elim = term let E elim = term
| _ => throw $ AnnotationNeeded term.loc empty term | _ => throw $ AnnotationNeeded term.loc empty term
res <- liftTC $ inferC empty sqty elim res <- liftTC $ inferC empty sqty elim
addDef name $ mkDef gqty res.type term def.scheme def.main def.loc pure res.type
when def.main $ liftWhnf $ expectMainType defs type
addDef name $ mkDef gqty type term def.scheme def.main def.loc
PPostulate ptype => do PPostulate ptype => do
type <- fromPTerm ptype type <- fromPTerm ptype
addDef name $ mkPostulate gqty type def.scheme def.main def.loc addDef name $ mkPostulate gqty type def.scheme def.main def.loc