crude but effective stratification
This commit is contained in:
parent
e4a20cc632
commit
42aa07c9c8
31 changed files with 817 additions and 582 deletions
|
|
@ -83,15 +83,16 @@ avoidDim ds loc x =
|
|||
fromName (const $ throw $ DimNameInTerm loc x.base) (pure . fromPName) ds x
|
||||
|
||||
private
|
||||
resolveName : Mods -> Loc -> Name -> Eff FromParserPure (Term d n)
|
||||
resolveName ns loc x =
|
||||
resolveName : Mods -> Loc -> Name -> Maybe Universe ->
|
||||
Eff FromParserPure (Term d n)
|
||||
resolveName ns loc x u =
|
||||
let here = addMods ns x in
|
||||
if isJust $ lookup here !(getAt DEFS) then
|
||||
pure $ FT here loc
|
||||
pure $ FT here (fromMaybe 0 u) loc
|
||||
else do
|
||||
let ns :< _ = ns
|
||||
| _ => throw $ TermNotInScope loc x
|
||||
resolveName ns loc x
|
||||
resolveName ns loc x u
|
||||
|
||||
export
|
||||
fromPatVar : PatVar -> BindName
|
||||
|
|
@ -107,6 +108,17 @@ fromPTagVal : PTagVal -> TagVal
|
|||
fromPTagVal (PT t _) = t
|
||||
|
||||
|
||||
private
|
||||
fromV : Context' PatVar d -> Context' PatVar n ->
|
||||
PName -> Maybe Universe -> Loc -> Eff FromParserPure (Term d n)
|
||||
fromV ds ns x u loc = fromName bound free ns x where
|
||||
bound : Var n -> Eff FromParserPure (Term d n)
|
||||
bound i = do whenJust u $ \u => throw $ DisplacedBoundVar loc x
|
||||
pure $ E $ B i loc
|
||||
free : PName -> Eff FromParserPure (Term d n)
|
||||
free x = do x <- avoidDim ds loc x
|
||||
resolveName !(getAt NS) loc x u
|
||||
|
||||
mutual
|
||||
export
|
||||
fromPTermWith : Context' PatVar d -> Context' PatVar n ->
|
||||
|
|
@ -199,9 +211,7 @@ mutual
|
|||
<*> fromPTermTScope ds ns [< b] body
|
||||
<*> pure loc
|
||||
|
||||
V x loc =>
|
||||
fromName (\i => pure $ E $ B i loc)
|
||||
(resolveName !(getAt NS) loc <=< avoidDim ds loc) ns x
|
||||
V x u loc => fromV ds ns x u loc
|
||||
|
||||
Ann s a loc =>
|
||||
map E $ Ann
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ data Error =
|
|||
| DimNotInScope Loc PBaseName
|
||||
| QtyNotGlobal Loc Qty
|
||||
| DimNameInTerm Loc PBaseName
|
||||
| DisplacedBoundVar Loc PName
|
||||
| WrapTypeError TypeError
|
||||
| LoadError Loc String FileError
|
||||
| WrapParseError String ParseError
|
||||
|
|
@ -89,6 +90,11 @@ parameters (showContext : Bool)
|
|||
(sep ["dimension" <++> !(hl DVar $ text i),
|
||||
"used in a term context"])
|
||||
|
||||
prettyError (DisplacedBoundVar loc x) = pure $
|
||||
vappend !(prettyLoc loc)
|
||||
(sep ["local variable" <++> !(hl TVar $ text $ toDotsP x),
|
||||
"cannot be displaced"])
|
||||
|
||||
prettyError (WrapTypeError err) =
|
||||
Typing.prettyError showContext $ trimContext 2 err
|
||||
|
||||
|
|
|
|||
|
|
@ -21,7 +21,8 @@ import Derive.Prelude
|
|||
||| @ Nat nat literal
|
||||
||| @ String string literal
|
||||
||| @ Tag tag literal
|
||||
||| @ TYPE "Type" or "★" with subscript
|
||||
||| @ TYPE "Type" or "★" with ascii nat directly after
|
||||
||| @ Sup superscript or ^ number (displacement, or universe for ★)
|
||||
public export
|
||||
data Token =
|
||||
Reserved String
|
||||
|
|
@ -30,6 +31,7 @@ data Token =
|
|||
| Str String
|
||||
| Tag String
|
||||
| TYPE Nat
|
||||
| Sup Nat
|
||||
%runElab derive "Token" [Eq, Ord, Show]
|
||||
|
||||
-- token or whitespace
|
||||
|
|
@ -94,21 +96,33 @@ fromSub c = case c of
|
|||
'₀' => '0'; '₁' => '1'; '₂' => '2'; '₃' => '3'; '₄' => '4'
|
||||
'₅' => '5'; '₆' => '6'; '₇' => '7'; '₈' => '8'; '₉' => '9'; _ => c
|
||||
|
||||
private %inline
|
||||
fromSup : Char -> Char
|
||||
fromSup c = case c of
|
||||
'⁰' => '0'; '¹' => '1'; '²' => '2'; '³' => '3'; '⁴' => '4'
|
||||
'⁵' => '5'; '⁶' => '6'; '⁷' => '7'; '⁸' => '8'; '⁹' => '9'; _ => c
|
||||
|
||||
private %inline
|
||||
subToNat : String -> Nat
|
||||
subToNat = cast . pack . map fromSub . unpack
|
||||
|
||||
private %inline
|
||||
supToNat : String -> Nat
|
||||
supToNat = cast . pack . map fromSup . unpack
|
||||
|
||||
-- ★0, Type0. base ★/Type is a Reserved
|
||||
private
|
||||
universe : Tokenizer TokenW
|
||||
universe = universeWith "★" <|> universeWith "Type" where
|
||||
universeWith : String -> Tokenizer TokenW
|
||||
universeWith pfx =
|
||||
let len = length pfx in
|
||||
match (exact pfx <+> some (range '0' '9'))
|
||||
(TYPE . cast . drop len) <|>
|
||||
match (exact pfx <+> some (range '₀' '₉'))
|
||||
(TYPE . subToNat . drop len)
|
||||
match (exact pfx <+> digits) (TYPE . cast . drop len)
|
||||
|
||||
private
|
||||
sup : Tokenizer TokenW
|
||||
sup = match (some $ pred isSupDigit) (Sup . supToNat)
|
||||
<|> match (is '^' <+> digits) (Sup . cast . drop 1)
|
||||
|
||||
|
||||
private %inline
|
||||
|
|
@ -219,7 +233,7 @@ tokens = choice $
|
|||
blockComment (exact "{-") (exact "-}")] <+>
|
||||
[universe] <+> -- ★ᵢ takes precedence over bare ★
|
||||
map resTokenizer reserved <+>
|
||||
[nat, string, tag, name]
|
||||
[sup, nat, string, tag, name]
|
||||
|
||||
export
|
||||
lex : String -> Either Error (List (WithBounds Token))
|
||||
|
|
|
|||
|
|
@ -106,10 +106,14 @@ export
|
|||
strLit : Grammar True String
|
||||
strLit = terminalMatch "string literal" `(Str s) `(s)
|
||||
|
||||
||| single-token universe, like ★₀ or Type1
|
||||
||| single-token universe, like ★0 or Type1
|
||||
export
|
||||
universe1 : Grammar True Universe
|
||||
universe1 = terminalMatch "universe" `(TYPE u) `(u)
|
||||
universeTok : Grammar True Universe
|
||||
universeTok = terminalMatch "universe" `(TYPE u) `(u)
|
||||
|
||||
export
|
||||
super : Grammar True Nat
|
||||
super = terminalMatch "superscript number or '^'" `(Sup n) `(n)
|
||||
|
||||
||| possibly-qualified name
|
||||
export
|
||||
|
|
@ -134,6 +138,11 @@ qtyVal = terminalMatchN "quantity"
|
|||
[(`(Nat 0), `(Zero)), (`(Nat 1), `(One)), (`(Reserved "ω"), `(Any))]
|
||||
|
||||
|
||||
||| optional superscript number
|
||||
export
|
||||
displacement : Grammar False (Maybe Universe)
|
||||
displacement = optional super
|
||||
|
||||
||| quantity (0, 1, or ω)
|
||||
export
|
||||
qty : FileName -> Grammar True PQty
|
||||
|
|
@ -263,6 +272,10 @@ tupleTerm fname = withLoc fname $ do
|
|||
terms <- delimSep1 "(" ")" "," $ assert_total term fname
|
||||
pure $ \loc => foldr1 (\s, t => Pair s t loc) terms
|
||||
|
||||
export
|
||||
universe1 : Grammar True Universe
|
||||
universe1 = universeTok <|> res "★" *> super
|
||||
|
||||
||| argument/atomic term: single-token terms, or those with delimiters e.g.
|
||||
||| `[t]`
|
||||
export
|
||||
|
|
@ -275,7 +288,7 @@ termArg fname = withLoc fname $
|
|||
<|> Nat <$ res "ℕ"
|
||||
<|> Zero <$ res "zero"
|
||||
<|> [|fromNat nat|]
|
||||
<|> [|V qname|]
|
||||
<|> [|V qname displacement|]
|
||||
<|> const <$> tupleTerm fname
|
||||
|
||||
export
|
||||
|
|
@ -345,7 +358,10 @@ compTerm fname = withLoc fname $ do
|
|||
|
||||
export
|
||||
splitUniverseTerm : FileName -> Grammar True PTerm
|
||||
splitUniverseTerm fname = withLoc fname $ resC "★" *> mustWork [|TYPE nat|]
|
||||
splitUniverseTerm fname =
|
||||
withLoc fname $ resC "★" *> mustWork [|TYPE $ nat <|> super|]
|
||||
-- having super here looks redundant, but when parsing a non-atomic term
|
||||
-- this branch will be taken first
|
||||
|
||||
export
|
||||
eqTerm : FileName -> Grammar True PTerm
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@ namespace PTerm
|
|||
| BOX PQty PTerm Loc
|
||||
| Box PTerm Loc
|
||||
|
||||
| V PName Loc
|
||||
| V PName (Maybe Universe) Loc
|
||||
| Ann PTerm PTerm Loc
|
||||
|
||||
| Coe (PatVar, PTerm) PDim PDim PTerm Loc
|
||||
|
|
@ -124,7 +124,7 @@ Located PTerm where
|
|||
(Succ _ loc).loc = loc
|
||||
(BOX _ _ loc).loc = loc
|
||||
(Box _ loc).loc = loc
|
||||
(V _ loc).loc = loc
|
||||
(V _ _ loc).loc = loc
|
||||
(Ann _ _ loc).loc = loc
|
||||
(Coe _ _ _ _ loc).loc = loc
|
||||
(Comp _ _ _ _ _ _ _ loc).loc = loc
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue