add postulate, #[compile-scheme], #[main]
This commit is contained in:
parent
cc0bade747
commit
050346e344
14 changed files with 579 additions and 321 deletions
|
|
@ -323,35 +323,39 @@ liftTC tc = runEff tc $ with Union.(::)
|
|||
\g => send g]
|
||||
|
||||
private
|
||||
addDef : Has DefsState fs => Name -> GQty -> Term 0 0 -> Term 0 0 -> Loc ->
|
||||
Eff fs NDefinition
|
||||
addDef name gqty type term loc = do
|
||||
let def = mkDef gqty type term loc
|
||||
addDef : Has DefsState fs => Name -> Definition -> Eff fs NDefinition
|
||||
addDef name def = do
|
||||
modifyAt DEFS $ insert name def
|
||||
pure (name, def)
|
||||
|
||||
|
||||
export covering
|
||||
fromPDef : PDefinition -> Eff FromParserPure NDefinition
|
||||
fromPDef (MkPDef qty pname ptype pterm defLoc) = do
|
||||
fromPDef : PDefinition -> Maybe String -> Bool ->
|
||||
Eff FromParserPure NDefinition
|
||||
fromPDef (MkPDef qty pname pbody defLoc) scheme isMain = do
|
||||
name <- fromPBaseNameNS pname
|
||||
when !(getsAt DEFS $ isJust . lookup name) $ do
|
||||
throw $ AlreadyExists defLoc name
|
||||
gqty <- globalPQty qty.val qty.loc
|
||||
let sqty = globalToSubj gqty
|
||||
type <- traverse fromPTerm ptype
|
||||
term <- fromPTerm pterm
|
||||
case type of
|
||||
Just type => do
|
||||
ignore $ liftTC $ do
|
||||
checkTypeC empty type Nothing
|
||||
checkC empty sqty term type
|
||||
addDef name gqty type term defLoc
|
||||
Nothing => do
|
||||
let E elim = term
|
||||
| _ => throw $ AnnotationNeeded term.loc empty term
|
||||
res <- liftTC $ inferC empty sqty elim
|
||||
addDef name gqty res.type term defLoc
|
||||
case pbody of
|
||||
PConcrete ptype pterm => do
|
||||
type <- traverse fromPTerm ptype
|
||||
term <- fromPTerm pterm
|
||||
case type of
|
||||
Just type => do
|
||||
ignore $ liftTC $ do
|
||||
checkTypeC empty type Nothing
|
||||
checkC empty sqty term type
|
||||
addDef name $ mkDef gqty type term scheme isMain defLoc
|
||||
Nothing => do
|
||||
let E elim = term
|
||||
| _ => throw $ AnnotationNeeded term.loc empty term
|
||||
res <- liftTC $ inferC empty sqty elim
|
||||
addDef name $ mkDef gqty res.type term scheme isMain defLoc
|
||||
PPostulate ptype => do
|
||||
type <- fromPTerm ptype
|
||||
addDef name $ mkPostulate gqty type scheme isMain defLoc
|
||||
|
||||
|
||||
public export
|
||||
|
|
@ -359,31 +363,50 @@ data HasFail = NoFail | AnyFail | FailWith String
|
|||
|
||||
export
|
||||
hasFail : List PDeclMod -> HasFail
|
||||
hasFail [] = NoFail
|
||||
hasFail (PFail str _ :: _) = maybe AnyFail FailWith str
|
||||
hasFail [] = NoFail
|
||||
hasFail (PFail str :: _) = maybe AnyFail FailWith str
|
||||
hasFail (_ :: rest) = hasFail rest
|
||||
|
||||
export
|
||||
getScheme : List PDeclMod -> Maybe String
|
||||
getScheme [] = Nothing
|
||||
getScheme (PCompileScheme str :: _) = Just str
|
||||
getScheme (_ :: rest) = getScheme rest
|
||||
|
||||
export
|
||||
isMain : List PDeclMod -> Bool
|
||||
isMain [] = False
|
||||
isMain (PMain :: _) = True
|
||||
isMain (_ :: rest) = isMain rest
|
||||
|
||||
export covering
|
||||
fromPDecl : PDecl -> Eff FromParserPure (List NDefinition)
|
||||
|
||||
export covering
|
||||
fromPDeclBody : PDeclBody -> Eff FromParserPure (List NDefinition)
|
||||
fromPDeclBody (PDef def) = singleton <$> fromPDef def
|
||||
fromPDeclBody (PNs ns) =
|
||||
fromPDeclBody : PDeclBody -> Maybe String -> Bool -> Loc ->
|
||||
Eff FromParserPure (List NDefinition)
|
||||
fromPDeclBody (PDef def) scheme isMain loc =
|
||||
singleton <$> fromPDef def scheme isMain
|
||||
fromPDeclBody (PNs ns) scheme isMain loc = do
|
||||
when (isJust scheme) $ throw $ SchemeOnNamespace loc ns.name
|
||||
when isMain $ throw $ MainOnNamespace loc ns.name
|
||||
localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
|
||||
|
||||
export covering
|
||||
expectFail : PDeclBody -> Eff FromParserPure Error
|
||||
expectFail body =
|
||||
case fromParserPure !(getAt GEN) !(getAt DEFS) $ fromPDeclBody body of
|
||||
expectFail : PDeclBody -> Loc -> Eff FromParserPure Error
|
||||
expectFail body loc =
|
||||
let res = fromParserPure !(getAt GEN) !(getAt DEFS) $
|
||||
fromPDeclBody body Nothing False loc in
|
||||
case res of
|
||||
Left err => pure err
|
||||
Right _ => throw $ ExpectedFail body.loc
|
||||
|
||||
|
||||
fromPDecl (MkPDecl mods decl loc) = case hasFail mods of
|
||||
NoFail => fromPDeclBody decl
|
||||
AnyFail => expectFail decl $> []
|
||||
NoFail => fromPDeclBody decl (getScheme mods) (isMain mods) loc
|
||||
AnyFail => expectFail decl loc $> []
|
||||
FailWith str => do
|
||||
err <- expectFail decl
|
||||
err <- expectFail decl loc
|
||||
let msg = runPretty $ prettyError False err {opts = Opts 10_000} -- w/e
|
||||
if str `isInfixOf` renderInfinite msg
|
||||
then pure []
|
||||
|
|
|
|||
|
|
@ -35,6 +35,8 @@ data Error =
|
|||
| AlreadyExists Loc Name
|
||||
| LoadError Loc FilePath FileError
|
||||
| ExpectedFail Loc
|
||||
| SchemeOnNamespace Loc Mods
|
||||
| MainOnNamespace Loc Mods
|
||||
| WrongFail String Error Loc
|
||||
| WrapParseError String ParseError
|
||||
|
||||
|
|
@ -123,12 +125,22 @@ parameters {opts : LayoutOpts} (showContext : Bool)
|
|||
text $ show err]
|
||||
|
||||
prettyError (ExpectedFail loc) = pure $
|
||||
sep [!(prettyLoc loc), "expected error"]
|
||||
vsep [!(prettyLoc loc), "expected error"]
|
||||
|
||||
prettyError (SchemeOnNamespace loc ns) = pure $
|
||||
vsep [!(prettyLoc loc),
|
||||
hsep ["namespace", !(hl Free $ text $ joinBy "." $ toList ns),
|
||||
"cannot have #[compile-scheme] attached"]]
|
||||
|
||||
prettyError (MainOnNamespace loc ns) = pure $
|
||||
vsep [!(prettyLoc loc),
|
||||
hsep ["namespace", !(hl Free $ text $ joinBy "." $ toList ns),
|
||||
"cannot have #[main] attached"]]
|
||||
|
||||
prettyError (WrongFail str err loc) = pure $
|
||||
sep [!(prettyLoc loc),
|
||||
"wrong error, expected to match", !(hl Tag $ text "\"\{str}\""),
|
||||
"but got", !(prettyError err)]
|
||||
vsep [!(prettyLoc loc),
|
||||
"wrong error, expected to match", !(hl Tag $ text "\"\{str}\""),
|
||||
"but got", !(prettyError err)]
|
||||
|
||||
prettyError (WrapParseError file err) =
|
||||
prettyParseError file err
|
||||
|
|
|
|||
|
|
@ -227,6 +227,9 @@ reserved =
|
|||
Word1 "def",
|
||||
Word1 "def0",
|
||||
Word "defω" `Or` Word "def#",
|
||||
Word1 "postulate",
|
||||
Word1 "postulate0",
|
||||
Word "postulateω" `Or` Word "postulate#",
|
||||
Sym1 "=",
|
||||
Word1 "load",
|
||||
Word1 "namespace"]
|
||||
|
|
|
|||
|
|
@ -587,32 +587,60 @@ pragma : Grammar True a -> Grammar True a
|
|||
pragma p = resC "#[" *> p <* mustWork (resC "]")
|
||||
|
||||
export
|
||||
declMod : FileName -> Grammar True PDeclMod
|
||||
declMod fname = withLoc fname $ pragma $
|
||||
exactName "fail" *> [|PFail $ optional strLit|]
|
||||
declMod : Grammar True PDeclMod
|
||||
declMod = pragma $
|
||||
exactName "fail" *> [|PFail $ optional strLit|]
|
||||
<|> exactName "compile-scheme" *> [|PCompileScheme strLit|]
|
||||
<|> exactName "main" $> PMain
|
||||
<|> do other <- qname
|
||||
fatalError "unknown declaration flag \{show other}" {c = False}
|
||||
|
||||
export
|
||||
decl : FileName -> Grammar True PDecl
|
||||
|
||||
||| `def` alone means `defω`
|
||||
||| `def` alone means `defω`; same for `postulate`
|
||||
export
|
||||
defIntro : FileName -> Grammar True PQty
|
||||
defIntro fname =
|
||||
withLoc fname (PQ Zero <$ resC "def0")
|
||||
<|> withLoc fname (PQ Any <$ resC "defω")
|
||||
<|> do pos <- bounds $ resC "def"
|
||||
defIntro' : (bare, zero, omega : String) ->
|
||||
(0 _ : IsReserved bare) =>
|
||||
(0 _ : IsReserved zero) =>
|
||||
(0 _ : IsReserved omega) =>
|
||||
FileName -> Grammar True PQty
|
||||
defIntro' bare zero omega fname =
|
||||
withLoc fname (PQ Zero <$ resC zero)
|
||||
<|> withLoc fname (PQ Any <$ resC omega)
|
||||
<|> do pos <- bounds $ resC bare
|
||||
let any = PQ Any $ makeLoc fname pos.bounds
|
||||
option any $ qty fname <* needRes "."
|
||||
|
||||
export
|
||||
definition : FileName -> Grammar True PDefinition
|
||||
definition fname = withLoc fname $ do
|
||||
defIntro : FileName -> Grammar True PQty
|
||||
defIntro = defIntro' "def" "def0" "defω"
|
||||
|
||||
export
|
||||
postulateIntro : FileName -> Grammar True PQty
|
||||
postulateIntro = defIntro' "postulate" "postulate0" "postulateω"
|
||||
|
||||
export
|
||||
postulate : FileName -> Grammar True PDefinition
|
||||
postulate fname = withLoc fname $ Core.do
|
||||
qty <- postulateIntro fname
|
||||
name <- baseName
|
||||
type <- resC ":" *> mustWork (term fname)
|
||||
pure $ MkPDef qty name $ PPostulate type
|
||||
|
||||
export
|
||||
concrete : FileName -> Grammar True PDefinition
|
||||
concrete fname = withLoc fname $ do
|
||||
qty <- defIntro fname
|
||||
name <- baseName
|
||||
type <- optional $ resC ":" *> mustWork (term fname)
|
||||
term <- needRes "=" *> mustWork (term fname)
|
||||
optRes ";"
|
||||
pure $ MkPDef qty name type term
|
||||
pure $ MkPDef qty name $ PConcrete type term
|
||||
|
||||
export
|
||||
definition : FileName -> Grammar True PDefinition
|
||||
definition fname = try (postulate fname) <|> concrete fname
|
||||
|
||||
export
|
||||
namespace_ : FileName -> Grammar True PNamespace
|
||||
|
|
@ -629,7 +657,7 @@ export
|
|||
declBody : FileName -> Grammar True PDeclBody
|
||||
declBody fname = [|PDef $ definition fname|] <|> [|PNs $ namespace_ fname|]
|
||||
|
||||
decl fname = withLoc fname [|MkPDecl (many $ declMod fname) (declBody fname)|]
|
||||
decl fname = withLoc fname [|MkPDecl (many declMod) (declBody fname)|]
|
||||
|
||||
export
|
||||
load : FileName -> Grammar True PTopLevel
|
||||
|
|
|
|||
|
|
@ -141,13 +141,18 @@ Located PCaseBody where
|
|||
(CaseBox _ _ loc).loc = loc
|
||||
|
||||
|
||||
public export
|
||||
data PBody = PConcrete (Maybe PTerm) PTerm | PPostulate PTerm
|
||||
%name PBody body
|
||||
%runElab derive "PBody" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
|
||||
public export
|
||||
record PDefinition where
|
||||
constructor MkPDef
|
||||
qty : PQty
|
||||
name : PBaseName
|
||||
type : Maybe PTerm
|
||||
term : PTerm
|
||||
body : PBody
|
||||
loc_ : Loc
|
||||
%name PDefinition def
|
||||
%runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal]
|
||||
|
|
@ -156,7 +161,9 @@ export Located PDefinition where def.loc = def.loc_
|
|||
|
||||
public export
|
||||
data PDeclMod =
|
||||
PFail (Maybe String) Loc
|
||||
PFail (Maybe String)
|
||||
| PCompileScheme String
|
||||
| PMain
|
||||
%name PDeclMod mod
|
||||
%runElab derive "PDeclMod" [Eq, Ord, Show, PrettyVal]
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue