do scope checking in FromParser where it belongs
This commit is contained in:
parent
55c0bf9974
commit
b666bc20cf
11 changed files with 305 additions and 309 deletions
|
|
@ -20,8 +20,6 @@ import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
|
|||
%hide Typing.Error
|
||||
%hide Lexer.Error
|
||||
%hide Parser.Error
|
||||
%hide Definition.DEFS
|
||||
%hide Definition.NS
|
||||
|
||||
|
||||
public export
|
||||
|
|
@ -38,7 +36,12 @@ SeenFiles = SortedSet String
|
|||
|
||||
|
||||
public export
|
||||
data StateTag = DEFS | NS | SEEN
|
||||
data StateTag = NS | SEEN
|
||||
|
||||
public export
|
||||
0 FromParserPure : List (Type -> Type)
|
||||
FromParserPure =
|
||||
[Except Error, StateL DEFS Definitions, StateL NS Mods]
|
||||
|
||||
public export
|
||||
0 FromParserEff : List (Type -> Type)
|
||||
|
|
@ -70,16 +73,25 @@ fromPDimWith ds (V i) =
|
|||
|
||||
private
|
||||
avoidDim : Has (Except Error) fs =>
|
||||
Context' BName d -> PName -> Eff fs (Term d n)
|
||||
Context' BName d -> PName -> Eff fs Name
|
||||
avoidDim ds x =
|
||||
fromName (const $ throw $ DimNameInTerm x.base) (pure . FT . fromPName) ds x
|
||||
fromName (const $ throw $ DimNameInTerm x.base) (pure . fromPName) ds x
|
||||
|
||||
private
|
||||
resolveName : Mods -> Name -> Eff FromParserPure (Term d n)
|
||||
resolveName ns x =
|
||||
let here = addMods ns x in
|
||||
if isJust $ lookup here !(getAt DEFS) then
|
||||
pure $ FT here
|
||||
else do
|
||||
let ns :< _ = ns
|
||||
| _ => throw $ TermNotInScope x
|
||||
resolveName ns x
|
||||
|
||||
mutual
|
||||
export
|
||||
fromPTermWith : Has (Except Error) fs =>
|
||||
Context' BName d -> Context' BName n ->
|
||||
PTerm -> Eff fs (Term d n)
|
||||
fromPTermWith : Context' BName d -> Context' BName n ->
|
||||
PTerm -> Eff FromParserPure (Term d n)
|
||||
fromPTermWith ds ns t0 = case t0 of
|
||||
TYPE k =>
|
||||
pure $ TYPE $ k
|
||||
|
|
@ -154,7 +166,7 @@ mutual
|
|||
map E $ (:%) <$> fromPTermElim ds ns s <*> fromPDimWith ds p
|
||||
|
||||
V x =>
|
||||
fromName (pure . E . B) (avoidDim ds) ns x
|
||||
fromName (pure . E . B) (resolveName !(getAt NS) <=< avoidDim ds) ns x
|
||||
|
||||
s :# a =>
|
||||
map E $ (:#) <$> fromPTermWith ds ns s <*> fromPTermWith ds ns a
|
||||
|
|
@ -177,27 +189,29 @@ mutual
|
|||
<*> fromPTermDScope ds ns [< j1] val1
|
||||
|
||||
private
|
||||
fromPTermEnumArms : Has (Except Error) fs =>
|
||||
Context' BName d -> Context' BName n ->
|
||||
List (TagVal, PTerm) -> Eff fs (CaseEnumArms d n)
|
||||
fromPTermEnumArms : Context' BName d -> Context' BName n ->
|
||||
List (TagVal, PTerm) ->
|
||||
Eff FromParserPure (CaseEnumArms d n)
|
||||
fromPTermEnumArms ds ns =
|
||||
map SortedMap.fromList . traverse (traverse $ fromPTermWith ds ns)
|
||||
|
||||
private
|
||||
fromPTermElim : Has (Except Error) fs =>
|
||||
Context' BName d -> Context' BName n ->
|
||||
PTerm -> Eff fs (Elim d n)
|
||||
fromPTermElim : Context' BName d -> Context' BName n ->
|
||||
PTerm -> Eff FromParserPure (Elim d n)
|
||||
fromPTermElim ds ns e =
|
||||
case !(fromPTermWith ds ns e) of
|
||||
E e => pure e
|
||||
_ => throw $ AnnotationNeeded e
|
||||
t => let ctx = MkNameContexts (map name ds) (map name ns) in
|
||||
throw $ AnnotationNeeded ctx t
|
||||
where
|
||||
name : BName -> BaseName
|
||||
name = maybe Unused UN
|
||||
|
||||
-- [todo] use SN if the var is named but still unused
|
||||
private
|
||||
fromPTermTScope : {s : Nat} -> Has (Except Error) fs =>
|
||||
Context' BName d -> Context' BName n ->
|
||||
SnocVect s BName ->
|
||||
PTerm -> Eff fs (ScopeTermN s d n)
|
||||
fromPTermTScope : {s : Nat} -> Context' BName d -> Context' BName n ->
|
||||
SnocVect s BName -> PTerm ->
|
||||
Eff FromParserPure (ScopeTermN s d n)
|
||||
fromPTermTScope ds ns xs t =
|
||||
if all isNothing xs then
|
||||
SN <$> fromPTermWith ds ns t
|
||||
|
|
@ -206,10 +220,9 @@ mutual
|
|||
<$> fromPTermWith ds (ns ++ xs) t
|
||||
|
||||
private
|
||||
fromPTermDScope : {s : Nat} -> Has (Except Error) fs =>
|
||||
Context' BName d -> Context' BName n ->
|
||||
SnocVect s BName ->
|
||||
PTerm -> Eff fs (DScopeTermN s d n)
|
||||
fromPTermDScope : {s : Nat} -> Context' BName d -> Context' BName n ->
|
||||
SnocVect s BName -> PTerm ->
|
||||
Eff FromParserPure (DScopeTermN s d n)
|
||||
fromPTermDScope ds ns xs t =
|
||||
if all isNothing xs then
|
||||
SN <$> fromPTermWith ds ns t
|
||||
|
|
@ -219,7 +232,7 @@ mutual
|
|||
|
||||
|
||||
export %inline
|
||||
fromPTerm : Has (Except Error) fs => PTerm -> Eff fs (Term 0 0)
|
||||
fromPTerm : PTerm -> Eff FromParserPure (Term 0 0)
|
||||
fromPTerm = fromPTermWith [<] [<]
|
||||
|
||||
|
||||
|
|
@ -236,10 +249,9 @@ fromPNameNS : Has (StateL NS Mods) fs => PName -> Eff fs Name
|
|||
fromPNameNS name = pure $ addMods !(getAt NS) $ fromPName name
|
||||
|
||||
private
|
||||
injTC : (Has (StateL DEFS Definitions) fs, Has (StateL NS Mods) fs,
|
||||
Has (Except Error) fs) =>
|
||||
injTC : (Has (StateL DEFS Definitions) fs, Has (Except Error) fs) =>
|
||||
TC a -> Eff fs a
|
||||
injTC act = rethrow $ mapFst TypeError $ runTC !(getAt NS) !(getAt DEFS) act
|
||||
injTC act = rethrow $ mapFst TypeError $ runTC !(getAt DEFS) act
|
||||
|
||||
export covering
|
||||
fromPDef : (Has (StateL DEFS Definitions) fs,
|
||||
|
|
@ -251,8 +263,8 @@ fromPDef (MkPDef qty pname ptype pterm) = do
|
|||
qtyGlobal <- globalPQty qty
|
||||
let gqty = Element qty qtyGlobal
|
||||
let sqty = globalToSubj gqty
|
||||
type <- traverse fromPTerm ptype
|
||||
term <- fromPTerm pterm
|
||||
type <- lift $ traverse fromPTerm ptype
|
||||
term <- lift $ fromPTerm pterm
|
||||
case type of
|
||||
Just type => do
|
||||
injTC $ checkTypeC empty type Nothing
|
||||
|
|
@ -261,7 +273,7 @@ fromPDef (MkPDef qty pname ptype pterm) = do
|
|||
modifyAt DEFS $ insert name def
|
||||
pure (name, def)
|
||||
Nothing => do
|
||||
let E elim = term | _ => throw $ AnnotationNeeded pterm
|
||||
let E elim = term | t => throw $ AnnotationNeeded empty t
|
||||
res <- injTC $ inferC empty sqty elim
|
||||
let def = mkDef gqty res.type term
|
||||
modifyAt DEFS $ insert name def
|
||||
|
|
@ -315,6 +327,15 @@ parameters {auto _ : (Has IO fs,
|
|||
fromPTopLevel (PD decl) = fromPDecl decl
|
||||
fromPTopLevel (PLoad file) = loadProcessFile file
|
||||
|
||||
export
|
||||
fromParserPure : Definitions ->
|
||||
Eff FromParserPure a ->
|
||||
Either Error (a, Definitions)
|
||||
fromParserPure defs act =
|
||||
extract $
|
||||
runExcept $
|
||||
evalStateAt NS [<] $
|
||||
runStateAt DEFS defs act
|
||||
|
||||
export
|
||||
fromParserIO : (MonadRec io, HasIO io) =>
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue