add source locations to inner syntax
This commit is contained in:
parent
30fa93ab4e
commit
d5f4a012c5
35 changed files with 3210 additions and 2482 deletions
|
|
@ -1,4 +1,4 @@
|
|||
||| take freshly-parsed input, translate it to core, and check it
|
||||
||| take freshly-parsed input, scope check, type check, add to env
|
||||
module Quox.Parser.FromParser
|
||||
|
||||
import Quox.Parser.Syntax
|
||||
|
|
@ -41,19 +41,19 @@ data StateTag = NS | SEEN
|
|||
public export
|
||||
FromParserPure : List (Type -> Type)
|
||||
FromParserPure =
|
||||
[Except Error, StateL DEFS Definitions, StateL NS Mods]
|
||||
[Except Error, DefsState, StateL NS Mods, NameGen]
|
||||
|
||||
public export
|
||||
FromParserEff : List (Type -> Type)
|
||||
FromParserEff =
|
||||
[Except Error, StateL DEFS Definitions, StateL NS Mods,
|
||||
Reader IncludePath, StateL SEEN SeenFiles, IO]
|
||||
LoadFile' : List (Type -> Type)
|
||||
LoadFile' = [IO, StateL SEEN SeenFiles, Reader IncludePath]
|
||||
|
||||
public export
|
||||
FromParser : Type -> Type
|
||||
FromParser = Eff FromParserEff
|
||||
LoadFile : List (Type -> Type)
|
||||
LoadFile = LoadFile' ++ [Except Error]
|
||||
|
||||
-- [todo] put the locs in the core ast, obv
|
||||
public export
|
||||
FromParserIO : List (Type -> Type)
|
||||
FromParserIO = FromParserPure ++ LoadFile'
|
||||
|
||||
|
||||
parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a)
|
||||
|
|
@ -70,31 +70,32 @@ parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a)
|
|||
export
|
||||
fromPDimWith : Has (Except Error) fs =>
|
||||
Context' PatVar d -> PDim -> Eff fs (Dim d)
|
||||
fromPDimWith ds (K e _) = pure $ K e
|
||||
fromPDimWith ds (V i _) =
|
||||
fromBaseName (pure . B) (const $ throw $ DimNotInScope i) ds i
|
||||
fromPDimWith ds (K e loc) = pure $ K e loc
|
||||
fromPDimWith ds (V i loc) =
|
||||
fromBaseName (\i => pure $ B i loc)
|
||||
(const $ throw $ DimNotInScope loc i) ds i
|
||||
|
||||
private
|
||||
avoidDim : Has (Except Error) fs =>
|
||||
Context' PatVar d -> PName -> Eff fs Name
|
||||
avoidDim ds x =
|
||||
fromName (const $ throw $ DimNameInTerm x.base) (pure . fromPName) ds x
|
||||
Context' PatVar d -> Loc -> PName -> Eff fs Name
|
||||
avoidDim ds loc x =
|
||||
fromName (const $ throw $ DimNameInTerm loc x.base) (pure . fromPName) ds x
|
||||
|
||||
private
|
||||
resolveName : Mods -> Name -> Eff FromParserPure (Term d n)
|
||||
resolveName ns x =
|
||||
resolveName : Mods -> Loc -> Name -> Eff FromParserPure (Term d n)
|
||||
resolveName ns loc x =
|
||||
let here = addMods ns x in
|
||||
if isJust $ lookup here !(getAt DEFS) then
|
||||
pure $ FT here
|
||||
pure $ FT here loc
|
||||
else do
|
||||
let ns :< _ = ns
|
||||
| _ => throw $ TermNotInScope x
|
||||
resolveName ns x
|
||||
| _ => throw $ TermNotInScope loc x
|
||||
resolveName ns loc x
|
||||
|
||||
export
|
||||
fromPatVar : PatVar -> BaseName
|
||||
fromPatVar (Unused _) = Unused
|
||||
fromPatVar (PV x _) = UN x
|
||||
fromPatVar : PatVar -> BindName
|
||||
fromPatVar (Unused loc) = BN Unused loc
|
||||
fromPatVar (PV x loc) = BN (UN x) loc
|
||||
|
||||
export
|
||||
fromPQty : PQty -> Qty
|
||||
|
|
@ -110,93 +111,112 @@ mutual
|
|||
fromPTermWith : Context' PatVar d -> Context' PatVar n ->
|
||||
PTerm -> Eff FromParserPure (Term d n)
|
||||
fromPTermWith ds ns t0 = case t0 of
|
||||
TYPE k _ =>
|
||||
pure $ TYPE k
|
||||
TYPE k loc =>
|
||||
pure $ TYPE k loc
|
||||
|
||||
Pi pi x s t _ =>
|
||||
Pi pi x s t loc =>
|
||||
Pi (fromPQty pi)
|
||||
<$> fromPTermWith ds ns s
|
||||
<*> fromPTermTScope ds ns [< x] t
|
||||
<*> pure loc
|
||||
|
||||
Lam x s _ =>
|
||||
Lam <$> fromPTermTScope ds ns [< x] s
|
||||
Lam x s loc =>
|
||||
Lam <$> fromPTermTScope ds ns [< x] s <*> pure loc
|
||||
|
||||
App s t _ =>
|
||||
map E $ (:@) <$> fromPTermElim ds ns s <*> fromPTermWith ds ns t
|
||||
App s t loc =>
|
||||
map E $ App
|
||||
<$> fromPTermElim ds ns s
|
||||
<*> fromPTermWith ds ns t
|
||||
<*> pure loc
|
||||
|
||||
Sig x s t _ =>
|
||||
Sig <$> fromPTermWith ds ns s <*> fromPTermTScope ds ns [< x] t
|
||||
Sig x s t loc =>
|
||||
Sig <$> fromPTermWith ds ns s
|
||||
<*> fromPTermTScope ds ns [< x] t
|
||||
<*> pure loc
|
||||
|
||||
Pair s t _ =>
|
||||
Pair <$> fromPTermWith ds ns s <*> fromPTermWith ds ns t
|
||||
Pair s t loc =>
|
||||
Pair <$> fromPTermWith ds ns s <*> fromPTermWith ds ns t <*> pure loc
|
||||
|
||||
Case pi pair (r, ret) (CasePair (x, y) body _) _ =>
|
||||
Case pi pair (r, ret) (CasePair (x, y) body _) loc =>
|
||||
map E $ CasePair (fromPQty pi)
|
||||
<$> fromPTermElim ds ns pair
|
||||
<*> fromPTermTScope ds ns [< r] ret
|
||||
<*> fromPTermTScope ds ns [< x, y] body
|
||||
<*> pure loc
|
||||
|
||||
Case pi tag (r, ret) (CaseEnum arms _) _ =>
|
||||
Case pi tag (r, ret) (CaseEnum arms _) loc =>
|
||||
map E $ CaseEnum (fromPQty pi)
|
||||
<$> fromPTermElim ds ns tag
|
||||
<*> fromPTermTScope ds ns [< r] ret
|
||||
<*> assert_total fromPTermEnumArms ds ns arms
|
||||
<*> pure loc
|
||||
|
||||
Nat _ => pure Nat
|
||||
Zero _ => pure Zero
|
||||
Succ n _ => [|Succ $ fromPTermWith ds ns n|]
|
||||
Nat loc => pure $ Nat loc
|
||||
Zero loc => pure $ Zero loc
|
||||
Succ n loc => [|Succ (fromPTermWith ds ns n) (pure loc)|]
|
||||
|
||||
Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) _ =>
|
||||
Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) loc =>
|
||||
map E $ CaseNat (fromPQty pi) (fromPQty pi')
|
||||
<$> fromPTermElim ds ns nat
|
||||
<*> fromPTermTScope ds ns [< r] ret
|
||||
<*> fromPTermWith ds ns zer
|
||||
<*> fromPTermTScope ds ns [< s, ih] suc
|
||||
<*> pure loc
|
||||
|
||||
Enum strs _ =>
|
||||
Enum strs loc =>
|
||||
let set = SortedSet.fromList strs in
|
||||
if length strs == length (SortedSet.toList set) then
|
||||
pure $ Enum set
|
||||
pure $ Enum set loc
|
||||
else
|
||||
throw $ DuplicatesInEnum strs
|
||||
throw $ DuplicatesInEnum loc strs
|
||||
|
||||
Tag str _ => pure $ Tag str
|
||||
Tag str loc => pure $ Tag str loc
|
||||
|
||||
Eq (i, ty) s t _ =>
|
||||
Eq (i, ty) s t loc =>
|
||||
Eq <$> fromPTermDScope ds ns [< i] ty
|
||||
<*> fromPTermWith ds ns s
|
||||
<*> fromPTermWith ds ns t
|
||||
<*> pure loc
|
||||
|
||||
DLam i s _ =>
|
||||
DLam <$> fromPTermDScope ds ns [< i] s
|
||||
DLam i s loc =>
|
||||
DLam <$> fromPTermDScope ds ns [< i] s <*> pure loc
|
||||
|
||||
DApp s p _ =>
|
||||
map E $ (:%) <$> fromPTermElim ds ns s <*> fromPDimWith ds p
|
||||
DApp s p loc =>
|
||||
map E $ DApp
|
||||
<$> fromPTermElim ds ns s
|
||||
<*> fromPDimWith ds p
|
||||
<*> pure loc
|
||||
|
||||
BOX q ty _ => BOX (fromPQty q) <$> fromPTermWith ds ns ty
|
||||
BOX q ty loc => BOX (fromPQty q) <$> fromPTermWith ds ns ty <*> pure loc
|
||||
|
||||
Box val _ => Box <$> fromPTermWith ds ns val
|
||||
Box val loc => Box <$> fromPTermWith ds ns val <*> pure loc
|
||||
|
||||
Case pi box (r, ret) (CaseBox b body _) _ =>
|
||||
Case pi box (r, ret) (CaseBox b body _) loc =>
|
||||
map E $ CaseBox (fromPQty pi)
|
||||
<$> fromPTermElim ds ns box
|
||||
<*> fromPTermTScope ds ns [< r] ret
|
||||
<*> fromPTermTScope ds ns [< b] body
|
||||
<*> pure loc
|
||||
|
||||
V x _ =>
|
||||
fromName (pure . E . B) (resolveName !(getAt NS) <=< avoidDim ds) ns x
|
||||
V x loc =>
|
||||
fromName (\i => pure $ E $ B i loc)
|
||||
(resolveName !(getAt NS) loc <=< avoidDim ds loc) ns x
|
||||
|
||||
Ann s a _ =>
|
||||
map E $ (:#) <$> fromPTermWith ds ns s <*> fromPTermWith ds ns a
|
||||
Ann s a loc =>
|
||||
map E $ Ann
|
||||
<$> fromPTermWith ds ns s
|
||||
<*> fromPTermWith ds ns a
|
||||
<*> pure loc
|
||||
|
||||
Coe (i, ty) p q val _ =>
|
||||
Coe (i, ty) p q val loc =>
|
||||
map E $ Coe
|
||||
<$> fromPTermDScope ds ns [< i] ty
|
||||
<*> fromPDimWith ds p
|
||||
<*> fromPDimWith ds q
|
||||
<*> fromPTermWith ds ns val
|
||||
<*> pure loc
|
||||
|
||||
Comp (i, ty) p q val r (j0, val0) (j1, val1) _ =>
|
||||
Comp (i, ty) p q val r (j0, val0) (j1, val1) loc =>
|
||||
map E $ CompH'
|
||||
<$> fromPTermDScope ds ns [< i] ty
|
||||
<*> fromPDimWith ds p
|
||||
|
|
@ -205,6 +225,7 @@ mutual
|
|||
<*> fromPDimWith ds r
|
||||
<*> fromPTermDScope ds ns [< j0] val0
|
||||
<*> fromPTermDScope ds ns [< j1] val1
|
||||
<*> pure loc
|
||||
|
||||
private
|
||||
fromPTermEnumArms : Context' PatVar d -> Context' PatVar n ->
|
||||
|
|
@ -221,7 +242,7 @@ mutual
|
|||
case !(fromPTermWith ds ns e) of
|
||||
E e => pure e
|
||||
t => let ctx = MkNameContexts (map fromPatVar ds) (map fromPatVar ns) in
|
||||
throw $ AnnotationNeeded ctx t
|
||||
throw $ AnnotationNeeded t.loc ctx t
|
||||
|
||||
-- [todo] use SN if the var is named but still unused
|
||||
private
|
||||
|
|
@ -251,10 +272,10 @@ fromPTerm = fromPTermWith [<] [<]
|
|||
|
||||
|
||||
export
|
||||
globalPQty : (q : Qty) -> Eff [Except Error] (So $ isGlobal q)
|
||||
globalPQty pi = case choose $ isGlobal pi of
|
||||
globalPQty : Loc -> (q : Qty) -> Eff [Except Error] (So $ isGlobal q)
|
||||
globalPQty loc pi = case choose $ isGlobal pi of
|
||||
Left y => pure y
|
||||
Right _ => throw $ QtyNotGlobal pi
|
||||
Right _ => throw $ QtyNotGlobal loc pi
|
||||
|
||||
|
||||
export
|
||||
|
|
@ -262,30 +283,31 @@ fromPBaseNameNS : PBaseName -> Eff [StateL NS Mods] Name
|
|||
fromPBaseNameNS name = pure $ addMods !(getAt NS) $ fromPBaseName name
|
||||
|
||||
private
|
||||
injTC : TC a -> Eff FromParserPure a
|
||||
injTC act = rethrow $ mapFst WrapTypeError $ runTC !(getAt DEFS) act
|
||||
liftTC : TC a -> Eff FromParserPure a
|
||||
liftTC act = do
|
||||
res <- lift $ runExcept $ runReaderAt DEFS !(getAt DEFS) act
|
||||
rethrow $ mapFst WrapTypeError res
|
||||
|
||||
export covering
|
||||
fromPDef : PDefinition -> Eff FromParserPure NDefinition
|
||||
fromPDef (MkPDef qty pname ptype pterm _) = do
|
||||
fromPDef (MkPDef qty pname ptype pterm defLoc) = do
|
||||
name <- lift $ fromPBaseNameNS pname
|
||||
let qty = fromPQty qty
|
||||
qtyGlobal <- lift $ globalPQty qty
|
||||
let gqty = Element qty qtyGlobal
|
||||
let sqty = globalToSubj gqty
|
||||
qtyGlobal <- lift $ globalPQty qty.loc qty.val
|
||||
let gqty = Element qty.val qtyGlobal
|
||||
sqty = globalToSubj gqty
|
||||
type <- lift $ traverse fromPTerm ptype
|
||||
term <- lift $ fromPTerm pterm
|
||||
case type of
|
||||
Just type => do
|
||||
injTC $ checkTypeC empty type Nothing
|
||||
injTC $ ignore $ checkC empty sqty term type
|
||||
let def = mkDef gqty type term
|
||||
liftTC $ checkTypeC empty type Nothing
|
||||
liftTC $ ignore $ checkC empty sqty term type
|
||||
let def = mkDef gqty type term defLoc
|
||||
modifyAt DEFS $ insert name def
|
||||
pure (name, def)
|
||||
Nothing => do
|
||||
let E elim = term | t => throw $ AnnotationNeeded empty t
|
||||
res <- injTC $ inferC empty sqty elim
|
||||
let def = mkDef gqty res.type term
|
||||
let E elim = term | _ => throw $ AnnotationNeeded term.loc empty term
|
||||
res <- liftTC $ inferC empty sqty elim
|
||||
let def = mkDef gqty res.type term defLoc
|
||||
modifyAt DEFS $ insert name def
|
||||
pure (name, def)
|
||||
|
||||
|
|
@ -296,27 +318,23 @@ fromPDecl (PNs ns) =
|
|||
localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
|
||||
|
||||
|
||||
public export
|
||||
LoadFile : List (Type -> Type)
|
||||
LoadFile = [IO, StateL SEEN SeenFiles, Reader IncludePath, Except Error]
|
||||
|
||||
export covering
|
||||
loadFile : String -> Eff LoadFile (Maybe String)
|
||||
loadFile file =
|
||||
loadFile : Loc -> String -> Eff LoadFile (Maybe String)
|
||||
loadFile loc file =
|
||||
if contains file !(getAt SEEN) then
|
||||
pure Nothing
|
||||
else do
|
||||
Just ifile <- firstExists (map (</> file) !ask)
|
||||
| Nothing => throw $ LoadError file FileNotFound
|
||||
| Nothing => throw $ LoadError loc file FileNotFound
|
||||
case !(readFile ifile) of
|
||||
Right res => modifyAt SEEN (insert file) $> Just res
|
||||
Left err => throw $ LoadError ifile err
|
||||
Left err => throw $ LoadError loc ifile err
|
||||
|
||||
mutual
|
||||
export covering
|
||||
loadProcessFile : String -> FromParser (List NDefinition)
|
||||
loadProcessFile file =
|
||||
case !(lift $ loadFile file) of
|
||||
loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition)
|
||||
loadProcessFile loc file =
|
||||
case !(lift $ loadFile loc file) of
|
||||
Just inp => do
|
||||
tl <- either (throw . WrapParseError file) pure $ lexParseInput file inp
|
||||
concat <$> traverse fromPTopLevel tl
|
||||
|
|
@ -324,26 +342,29 @@ mutual
|
|||
|
||||
||| populates the `defs` field of the state
|
||||
export covering
|
||||
fromPTopLevel : PTopLevel -> FromParser (List NDefinition)
|
||||
fromPTopLevel (PD decl) = lift $ fromPDecl decl
|
||||
fromPTopLevel (PLoad file _) = loadProcessFile file
|
||||
fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
|
||||
fromPTopLevel (PD decl) = lift $ fromPDecl decl
|
||||
fromPTopLevel (PLoad file loc) = loadProcessFile loc file
|
||||
|
||||
export
|
||||
fromParserPure : Definitions ->
|
||||
fromParserPure : NameSuf -> Definitions ->
|
||||
Eff FromParserPure a ->
|
||||
Either Error (a, Definitions)
|
||||
fromParserPure defs act =
|
||||
(Either Error (a, Definitions), NameSuf)
|
||||
fromParserPure suf defs act =
|
||||
extract $
|
||||
runStateAt GEN suf $
|
||||
runExcept $
|
||||
evalStateAt NS [<] $
|
||||
runStateAt DEFS defs act
|
||||
|
||||
export
|
||||
fromParserIO : (MonadRec io, HasIO io) =>
|
||||
IncludePath -> IORef SeenFiles -> IORef Definitions ->
|
||||
FromParser a -> io (Either Error a)
|
||||
fromParserIO inc seen defs act =
|
||||
IncludePath ->
|
||||
IORef SeenFiles -> IORef NameSuf -> IORef Definitions ->
|
||||
Eff FromParserIO a -> io (Either Error a)
|
||||
fromParserIO inc seen suf defs act =
|
||||
runIO $
|
||||
runStateIORefAt GEN suf $
|
||||
runExcept $
|
||||
evalStateAt NS [<] $
|
||||
runStateIORefAt SEEN seen $
|
||||
|
|
|
|||
|
|
@ -18,33 +18,24 @@ ParseError = Parser.Error
|
|||
|
||||
public export
|
||||
data Error =
|
||||
AnnotationNeeded (NameContexts d n) (Term d n)
|
||||
| DuplicatesInEnum (List TagVal)
|
||||
| TermNotInScope Name
|
||||
| DimNotInScope PBaseName
|
||||
| QtyNotGlobal Qty
|
||||
| DimNameInTerm PBaseName
|
||||
AnnotationNeeded Loc (NameContexts d n) (Term d n)
|
||||
| DuplicatesInEnum Loc (List TagVal)
|
||||
| TermNotInScope Loc Name
|
||||
| DimNotInScope Loc PBaseName
|
||||
| QtyNotGlobal Loc Qty
|
||||
| DimNameInTerm Loc PBaseName
|
||||
| WrapTypeError TypeError
|
||||
| LoadError String FileError
|
||||
| LoadError Loc String FileError
|
||||
| WrapParseError String ParseError
|
||||
|
||||
|
||||
parameters (unicode, showContext : Bool)
|
||||
export
|
||||
prettyBounds : String -> Bounds -> Doc HL
|
||||
prettyBounds file (MkBounds l1 c1 l2 c2) =
|
||||
hcat [hl Free $ pretty file, hl Delim ":",
|
||||
hl TVar $ pretty l1, hl Delim ":",
|
||||
hl DVar $ pretty c1, hl Delim "-",
|
||||
hl TVar $ pretty l2, hl Delim ":",
|
||||
hl DVar $ pretty c2]
|
||||
|
||||
export
|
||||
prettyParseError1 : String -> ParsingError _ -> Doc HL
|
||||
prettyParseError1 file (Error msg Nothing) =
|
||||
pretty msg
|
||||
prettyParseError1 file (Error msg (Just bounds)) =
|
||||
asep [prettyBounds file bounds <+> hl Delim ":", pretty msg]
|
||||
hsep [prettyLoc $ makeLoc file bounds, pretty msg]
|
||||
|
||||
export
|
||||
prettyParseError : String -> ParseError -> Doc HL
|
||||
|
|
@ -56,33 +47,38 @@ parameters (unicode, showContext : Bool)
|
|||
|
||||
export
|
||||
prettyError : Error -> Doc HL
|
||||
prettyError (AnnotationNeeded ctx tm) =
|
||||
sep ["the term", prettyTerm unicode ctx.dnames ctx.tnames tm,
|
||||
prettyError (AnnotationNeeded loc ctx tm) =
|
||||
sep [prettyLoc loc <++> "the term",
|
||||
prettyTerm unicode ctx.dnames ctx.tnames tm,
|
||||
"needs a type annotation"]
|
||||
-- [todo] print the original PTerm instead
|
||||
|
||||
prettyError (DuplicatesInEnum tags) =
|
||||
sep ["duplicate tags in enum type", braces $ fillSep $ map pretty tags]
|
||||
prettyError (DuplicatesInEnum loc tags) =
|
||||
sep [prettyLoc loc <++> "duplicate tags in enum type",
|
||||
braces $ fillSep $ map pretty tags]
|
||||
|
||||
prettyError (DimNotInScope i) =
|
||||
sep ["dimension", pretty0 unicode $ DV $ fromString i, "not in scope"]
|
||||
prettyError (DimNotInScope loc i) =
|
||||
sep [prettyLoc loc <++> "dimension",
|
||||
pretty0 unicode $ DV $ fromString i, "not in scope"]
|
||||
|
||||
prettyError (TermNotInScope x) =
|
||||
sep ["term variable", pretty0 unicode $ F x {d = 0, n = 0}, "not in scope"]
|
||||
prettyError (TermNotInScope loc x) =
|
||||
sep [prettyLoc loc <++> "term variable",
|
||||
hl Free $ pretty0 unicode x, "not in scope"]
|
||||
|
||||
prettyError (QtyNotGlobal pi) =
|
||||
sep ["quantity", pretty0 unicode pi,
|
||||
prettyError (QtyNotGlobal loc pi) =
|
||||
sep [prettyLoc loc <++> "quantity", pretty0 unicode pi,
|
||||
"can't be used on a top level declaration"]
|
||||
|
||||
prettyError (DimNameInTerm i) =
|
||||
sep ["dimension variable", pretty0 unicode $ DV $ fromString i,
|
||||
"used in a term context"]
|
||||
prettyError (DimNameInTerm loc i) =
|
||||
sep [prettyLoc loc <++> "dimension variable",
|
||||
pretty0 unicode $ DV $ fromString i, "used in a term context"]
|
||||
|
||||
prettyError (WrapTypeError err) =
|
||||
Typing.prettyError unicode showContext $ trimContext 2 err
|
||||
|
||||
prettyError (LoadError str err) =
|
||||
vsep [hsep ["couldn't load file", pretty str], fromString $ show err]
|
||||
prettyError (LoadError loc str err) =
|
||||
vsep [hsep [prettyLoc loc, "couldn't load file", pretty str],
|
||||
fromString $ show err]
|
||||
|
||||
prettyError (WrapParseError file err) =
|
||||
prettyParseError file err
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@ lexParseWith grm input = do
|
|||
export
|
||||
withLoc : {c : Bool} -> FileName -> (Grammar c (Loc -> a)) -> Grammar c a
|
||||
withLoc fname act = bounds act <&> \res =>
|
||||
if res.isIrrelevant then res.val Nothing
|
||||
if res.isIrrelevant then res.val noLoc
|
||||
else res.val $ makeLoc fname res.bounds
|
||||
|
||||
export
|
||||
|
|
@ -241,40 +241,40 @@ casePat fname = withLoc fname $
|
|||
<|> delim "[" "]" [|PBox (patVar fname)|]
|
||||
<|> fatalError "invalid pattern"
|
||||
|
||||
export covering
|
||||
export
|
||||
term : FileName -> Grammar True PTerm
|
||||
-- defined after all the subterm parsers
|
||||
|
||||
export covering
|
||||
export
|
||||
typeLine : FileName -> Grammar True (PatVar, PTerm)
|
||||
typeLine fname = do
|
||||
resC "["
|
||||
mustWork $ do
|
||||
i <- patVar fname <* resC "⇒" <|> unused fname
|
||||
t <- term fname <* needRes "]"
|
||||
t <- assert_total term fname <* needRes "]"
|
||||
pure (i, t)
|
||||
|
||||
||| box term `[t]` or type `[π.A]`
|
||||
export covering
|
||||
export
|
||||
boxTerm : FileName -> Grammar True PTerm
|
||||
boxTerm fname = withLoc fname $ do
|
||||
res "["; commit
|
||||
q <- optional $ qty fname <* res "."
|
||||
t <- mustWork $ term fname <* needRes "]"
|
||||
q <- optional $ qty fname <* res "."
|
||||
t <- mustWork $ assert_total term fname <* needRes "]"
|
||||
pure $ maybe (Box t) (\q => BOX q t) q
|
||||
|
||||
||| tuple term like `(a, b)`, or parenthesised single term.
|
||||
||| allows terminating comma. more than two elements are nested on the right:
|
||||
||| `(a, b, c, d) = (a, (b, (c, d)))`.
|
||||
export covering
|
||||
export
|
||||
tupleTerm : FileName -> Grammar True PTerm
|
||||
tupleTerm fname = withLoc fname $ do
|
||||
terms <- delimSep1 "(" ")" "," $ term fname
|
||||
terms <- delimSep1 "(" ")" "," $ assert_total term fname
|
||||
pure $ \loc => foldr1 (\s, t => Pair s t loc) terms
|
||||
|
||||
||| argument/atomic term: single-token terms, or those with delimiters e.g.
|
||||
||| `[t]`
|
||||
export covering
|
||||
export
|
||||
termArg : FileName -> Grammar True PTerm
|
||||
termArg fname = withLoc fname $
|
||||
[|TYPE universe1|]
|
||||
|
|
@ -287,7 +287,7 @@ termArg fname = withLoc fname $
|
|||
<|> [|V qname|]
|
||||
<|> const <$> tupleTerm fname
|
||||
|
||||
export covering
|
||||
export
|
||||
coeTerm : FileName -> Grammar True PTerm
|
||||
coeTerm fname = withLoc fname $ do
|
||||
resC "coe"
|
||||
|
|
@ -298,9 +298,11 @@ public export
|
|||
CompBranch : Type
|
||||
CompBranch = (DimConst, PatVar, PTerm)
|
||||
|
||||
export covering
|
||||
export
|
||||
compBranch : FileName -> Grammar True CompBranch
|
||||
compBranch fname = [|(,,) dimConst (patVar fname) (needRes "⇒" *> term fname)|]
|
||||
compBranch fname =
|
||||
[|(,,) dimConst (patVar fname)
|
||||
(needRes "⇒" *> assert_total term fname)|]
|
||||
|
||||
private
|
||||
checkCompTermBody : (PatVar, PTerm) -> PDim -> PDim -> PTerm -> PDim ->
|
||||
|
|
@ -313,7 +315,7 @@ checkCompTermBody a p q s r (e0, s0) (e1, s1) bounds =
|
|||
(_, _) =>
|
||||
fatalLoc bounds "body of 'comp' needs one 0 case and one 1 case"
|
||||
|
||||
export covering
|
||||
export
|
||||
compTerm : FileName -> Grammar True PTerm
|
||||
compTerm fname = withLoc fname $ do
|
||||
resC "comp"
|
||||
|
|
@ -328,27 +330,27 @@ compTerm fname = withLoc fname $ do
|
|||
let body = bounds $ mergeBounds bodyStart bodyEnd
|
||||
checkCompTermBody a p q s r s0 s1 body
|
||||
|
||||
export covering
|
||||
export
|
||||
splitUniverseTerm : FileName -> Grammar True PTerm
|
||||
splitUniverseTerm fname = withLoc fname $ resC "★" *> mustWork [|TYPE nat|]
|
||||
|
||||
export covering
|
||||
export
|
||||
eqTerm : FileName -> Grammar True PTerm
|
||||
eqTerm fname = withLoc fname $
|
||||
resC "Eq" *> mustWork [|Eq (typeLine fname) (termArg fname) (termArg fname)|]
|
||||
|
||||
export covering
|
||||
export
|
||||
succTerm : FileName -> Grammar True PTerm
|
||||
succTerm fname = withLoc fname $
|
||||
resC "succ" *> mustWork [|Succ (termArg fname)|]
|
||||
|
||||
||| a dimension argument with an `@` prefix, or
|
||||
||| a term argument with no prefix
|
||||
export covering
|
||||
export
|
||||
anyArg : FileName -> Grammar True (Either PDim PTerm)
|
||||
anyArg fname = dimArg fname <||> termArg fname
|
||||
|
||||
export covering
|
||||
export
|
||||
normalAppTerm : FileName -> Grammar True PTerm
|
||||
normalAppTerm fname = withLoc fname $ do
|
||||
head <- termArg fname
|
||||
|
|
@ -360,7 +362,7 @@ where ap : Loc -> PTerm -> Either PDim PTerm -> PTerm
|
|||
|
||||
||| application term `f x @y z`, or other terms that look like application
|
||||
||| like `succ` or `coe`.
|
||||
export covering
|
||||
export
|
||||
appTerm : FileName -> Grammar True PTerm
|
||||
appTerm fname =
|
||||
coeTerm fname
|
||||
|
|
@ -370,53 +372,55 @@ appTerm fname =
|
|||
<|> succTerm fname
|
||||
<|> normalAppTerm fname
|
||||
|
||||
export covering
|
||||
export
|
||||
infixEqTerm : FileName -> Grammar True PTerm
|
||||
infixEqTerm fname = withLoc fname $ do
|
||||
l <- appTerm fname; commit
|
||||
rest <- optional $
|
||||
res "≡" *> [|(,) (term fname) (needRes ":" *> appTerm fname)|]
|
||||
rest <- optional $ res "≡" *>
|
||||
[|(,) (assert_total term fname) (needRes ":" *> appTerm fname)|]
|
||||
let u = Unused $ onlyStart l.loc
|
||||
pure $ \loc => maybe l (\rest => Eq (u, snd rest) l (fst rest) loc) rest
|
||||
|
||||
export covering
|
||||
export
|
||||
annTerm : FileName -> Grammar True PTerm
|
||||
annTerm fname = withLoc fname $ do
|
||||
tm <- infixEqTerm fname; commit
|
||||
ty <- optional $ res "∷" *> term fname
|
||||
ty <- optional $ res "∷" *> assert_total term fname
|
||||
pure $ \loc => maybe tm (\ty => Ann tm ty loc) ty
|
||||
|
||||
export covering
|
||||
export
|
||||
lamTerm : FileName -> Grammar True PTerm
|
||||
lamTerm fname = withLoc fname $ do
|
||||
k <- DLam <$ res "δ" <|> Lam <$ res "λ"
|
||||
mustWork $ do
|
||||
xs <- some $ patVar fname; needRes "⇒"
|
||||
body <- term fname; commit
|
||||
xs <- some $ patVar fname; needRes "⇒"
|
||||
body <- assert_total term fname; commit
|
||||
pure $ \loc => foldr (\x, s => k x s loc) body xs
|
||||
|
||||
-- [todo] fix the backtracking in e.g. (F x y z × B)
|
||||
export covering
|
||||
export
|
||||
properBinders : FileName -> Grammar True (List1 PatVar, PTerm)
|
||||
properBinders fname = do
|
||||
properBinders fname = assert_total $ do
|
||||
-- putting assert_total directly on `term`, in this one function,
|
||||
-- doesn't work. i cannot tell why
|
||||
res "("
|
||||
xs <- some $ patVar fname; resC ":"
|
||||
t <- term fname; needRes ")"
|
||||
pure (xs, t)
|
||||
|
||||
export covering
|
||||
export
|
||||
piTerm : FileName -> Grammar True PTerm
|
||||
piTerm fname = withLoc fname $ do
|
||||
q <- qty fname; resC "."
|
||||
dom <- piBinder; needRes "→"
|
||||
cod <- term fname; commit
|
||||
q <- qty fname; resC "."
|
||||
dom <- piBinder; needRes "→"
|
||||
cod <- assert_total term fname; commit
|
||||
pure $ \loc => foldr (\x, t => Pi q x (snd dom) t loc) cod (fst dom)
|
||||
where
|
||||
piBinder : Grammar True (List1 PatVar, PTerm)
|
||||
piBinder = properBinders fname
|
||||
<|> [|(,) [|singleton $ unused fname|] (termArg fname)|]
|
||||
|
||||
export covering
|
||||
export
|
||||
sigmaTerm : FileName -> Grammar True PTerm
|
||||
sigmaTerm fname =
|
||||
(properBinders fname >>= continueDep)
|
||||
|
|
@ -440,9 +444,10 @@ public export
|
|||
PCaseArm : Type
|
||||
PCaseArm = (PCasePat, PTerm)
|
||||
|
||||
export covering
|
||||
export
|
||||
caseArm : FileName -> Grammar True PCaseArm
|
||||
caseArm fname = [|(,) (casePat fname) (needRes "⇒" *> term fname)|]
|
||||
caseArm fname =
|
||||
[|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|]
|
||||
|
||||
export
|
||||
checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody
|
||||
|
|
@ -468,30 +473,30 @@ checkCaseArms loc ((PBox x _, rhs) :: rest) =
|
|||
if null rest then pure $ CaseBox x rhs loc
|
||||
else fatalError "unexpected pattern after box"
|
||||
|
||||
export covering
|
||||
export
|
||||
caseBody : FileName -> Grammar True PCaseBody
|
||||
caseBody fname = do
|
||||
body <- bounds $ delimSep "{" "}" ";" $ caseArm fname
|
||||
let loc = makeLoc fname body.bounds
|
||||
checkCaseArms loc body.val
|
||||
|
||||
export covering
|
||||
export
|
||||
caseReturn : FileName -> Grammar True (PatVar, PTerm)
|
||||
caseReturn fname = do
|
||||
x <- patVar fname <* resC "⇒" <|> unused fname
|
||||
ret <- term fname
|
||||
ret <- assert_total term fname
|
||||
pure (x, ret)
|
||||
|
||||
export covering
|
||||
export
|
||||
caseTerm : FileName -> Grammar True PTerm
|
||||
caseTerm fname = withLoc fname $ do
|
||||
qty <- caseIntro fname; commit
|
||||
head <- mustWork $ term fname; needRes "return"
|
||||
ret <- mustWork $ caseReturn fname; needRes "of"
|
||||
qty <- caseIntro fname; commit
|
||||
head <- mustWork $ assert_total term fname; needRes "return"
|
||||
ret <- mustWork $ caseReturn fname; needRes "of"
|
||||
body <- mustWork $ caseBody fname
|
||||
pure $ Case qty head ret body
|
||||
|
||||
-- export covering
|
||||
-- export
|
||||
-- term : FileName -> Grammar True PTerm
|
||||
term fname = lamTerm fname
|
||||
<|> caseTerm fname
|
||||
|
|
@ -499,7 +504,7 @@ term fname = lamTerm fname
|
|||
<|> sigmaTerm fname
|
||||
|
||||
|
||||
export covering
|
||||
export
|
||||
decl : FileName -> Grammar True PDecl
|
||||
|
||||
||| `def` alone means `defω`
|
||||
|
|
@ -512,7 +517,7 @@ defIntro fname =
|
|||
let any = PQ Any $ makeLoc fname pos.bounds
|
||||
option any $ qty fname <* needRes "."
|
||||
|
||||
export covering
|
||||
export
|
||||
definition : FileName -> Grammar True PDefinition
|
||||
definition fname = withLoc fname $ do
|
||||
qty <- defIntro fname
|
||||
|
|
@ -522,7 +527,7 @@ definition fname = withLoc fname $ do
|
|||
optRes ";"
|
||||
pure $ MkPDef qty name type term
|
||||
|
||||
export covering
|
||||
export
|
||||
namespace_ : FileName -> Grammar True PNamespace
|
||||
namespace_ fname = withLoc fname $ do
|
||||
ns <- resC "namespace" *> qname; needRes "{"
|
||||
|
|
@ -531,28 +536,28 @@ namespace_ fname = withLoc fname $ do
|
|||
where
|
||||
nsInner : Grammar True (List PDecl)
|
||||
nsInner = [] <$ resC "}"
|
||||
<|> [|(decl fname <* commit) :: nsInner|]
|
||||
<|> [|(assert_total decl fname <* commit) :: assert_total nsInner|]
|
||||
|
||||
decl fname = [|PDef $ definition fname|] <|> [|PNs $ namespace_ fname|]
|
||||
|
||||
export covering
|
||||
export
|
||||
load : FileName -> Grammar True PTopLevel
|
||||
load fname = withLoc fname $
|
||||
resC "load" *> mustWork [|PLoad strLit|] <* optRes ";"
|
||||
|
||||
export covering
|
||||
export
|
||||
topLevel : FileName -> Grammar True PTopLevel
|
||||
topLevel fname = load fname <|> [|PD $ decl fname|]
|
||||
|
||||
export covering
|
||||
export
|
||||
input : FileName -> Grammar False (List PTopLevel)
|
||||
input fname = [] <$ eof
|
||||
<|> [|(topLevel fname <* commit) :: input fname|]
|
||||
<|> [|(topLevel fname <* commit) :: assert_total input fname|]
|
||||
|
||||
export covering
|
||||
export
|
||||
lexParseTerm : FileName -> String -> Either Error PTerm
|
||||
lexParseTerm = lexParseWith . term
|
||||
|
||||
export covering
|
||||
export
|
||||
lexParseInput : FileName -> String -> Either Error (List PTopLevel)
|
||||
lexParseInput = lexParseWith . input
|
||||
|
|
|
|||
|
|
@ -33,11 +33,14 @@ isUnused _ = False
|
|||
|
||||
|
||||
public export
|
||||
data PQty = PQ Qty Loc
|
||||
record PQty where
|
||||
constructor PQ
|
||||
val : Qty
|
||||
loc_ : Loc
|
||||
%name PQty qty
|
||||
%runElab derive "PQty" [Eq, Ord, Show]
|
||||
|
||||
export Located PQty where (PQ _ loc).loc = loc
|
||||
export Located PQty where q.loc = q.loc_
|
||||
|
||||
namespace PDim
|
||||
public export
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue