mtl ⇒ eff
This commit is contained in:
parent
8a9b4c23dd
commit
36609713ac
8 changed files with 382 additions and 226 deletions
|
|
@ -7,15 +7,27 @@ import Quox.Typechecker
|
|||
|
||||
import Data.List
|
||||
import Data.SnocVect
|
||||
import public Control.Monad.Either
|
||||
import public Control.Monad.State
|
||||
import public Control.Monad.Reader
|
||||
import Quox.EffExtra
|
||||
|
||||
import System.File
|
||||
import System.Path
|
||||
import Data.IORef
|
||||
|
||||
%hide Context.(<$>)
|
||||
%hide Context.(<*>)
|
||||
|
||||
%default total
|
||||
|
||||
%hide Typing.Error
|
||||
%hide Lexer.Error
|
||||
%hide Parser.Error
|
||||
|
||||
|
||||
public export
|
||||
0 Def : Type
|
||||
Def = Definition Three
|
||||
|
||||
public export
|
||||
0 NDef : Type
|
||||
NDef = (Name, Def)
|
||||
|
||||
public export
|
||||
0 Defs : Type
|
||||
|
|
@ -33,30 +45,26 @@ data FromParserError =
|
|||
| ParseError Parser.Error
|
||||
|
||||
public export
|
||||
0 CanError : (Type -> Type) -> Type
|
||||
CanError = MonadError FromParserError
|
||||
0 IncludePath : Type
|
||||
IncludePath = List String
|
||||
|
||||
public export
|
||||
0 HasDefsRW : (Type -> Type) -> Type
|
||||
HasDefsRW = MonadState Defs
|
||||
|
||||
public export
|
||||
0 HasNamespace : (Type -> Type) -> Type
|
||||
HasNamespace = MonadReader Mods
|
||||
0 SeenFiles : Type
|
||||
SeenFiles = SortedSet String
|
||||
|
||||
|
||||
public export
|
||||
0 LoadFile : (Type -> Type) -> Type
|
||||
LoadFile m =
|
||||
(HasIO m, MonadReader (List String) m, MonadState (SortedSet String) m)
|
||||
-- reader for include paths, state for seen files
|
||||
|
||||
data StateTag = DEFS | NS | SEEN
|
||||
|
||||
public export
|
||||
0 FromParser : (Type -> Type) -> Type
|
||||
FromParser m =
|
||||
(CanError m, HasDefsRW m, HasNamespace m, LoadFile m)
|
||||
0 FromParserEff : List (Type -> Type)
|
||||
FromParserEff =
|
||||
[Except Error, StateL DEFS Defs, StateL NS Mods,
|
||||
Reader IncludePath, StateL SEEN SeenFiles, IO]
|
||||
|
||||
public export
|
||||
0 FromParser : Type -> Type
|
||||
FromParser = Eff FromParserEff
|
||||
|
||||
|
||||
parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a)
|
||||
|
|
@ -70,24 +78,24 @@ parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a)
|
|||
fromName x = if null x.mods then fromBaseName x.base else f x
|
||||
|
||||
export
|
||||
fromPDimWith : CanError m =>
|
||||
Context' BName d -> PDim -> m (Dim d)
|
||||
fromPDimWith : Has (Except Error) fs =>
|
||||
Context' BName d -> PDim -> Eff fs (Dim d)
|
||||
fromPDimWith ds (K e) = pure $ K e
|
||||
fromPDimWith ds (V i) =
|
||||
fromBaseName (pure . B) (const $ throwError $ DimNotInScope i) ds i
|
||||
fromBaseName (pure . B) (const $ throw $ DimNotInScope i) ds i
|
||||
|
||||
private
|
||||
avoidDim : CanError m => Context' BName d -> PName -> m (Term q d n)
|
||||
avoidDim : Has (Except Error) fs =>
|
||||
Context' BName d -> PName -> Eff fs (Term q d n)
|
||||
avoidDim ds x =
|
||||
fromName (const $ throwError $ DimNameInTerm x.base)
|
||||
(pure . FT . fromPName) ds x
|
||||
fromName (const $ throw $ DimNameInTerm x.base) (pure . FT . fromPName) ds x
|
||||
|
||||
|
||||
mutual
|
||||
export
|
||||
fromPTermWith : CanError m =>
|
||||
fromPTermWith : Has (Except Error) fs =>
|
||||
Context' BName d -> Context' BName n ->
|
||||
PTerm -> m (Term Three d n)
|
||||
PTerm -> Eff fs (Term Three d n)
|
||||
fromPTermWith ds ns t0 = case t0 of
|
||||
TYPE k =>
|
||||
pure $ TYPE $ k
|
||||
|
|
@ -136,7 +144,7 @@ mutual
|
|||
if length strs == length (SortedSet.toList set) then
|
||||
pure $ Enum set
|
||||
else
|
||||
throwError $ DuplicatesInEnum strs
|
||||
throw $ DuplicatesInEnum strs
|
||||
|
||||
Tag str => pure $ Tag str
|
||||
|
||||
|
|
@ -168,27 +176,27 @@ mutual
|
|||
map E $ (:#) <$> fromPTermWith ds ns s <*> fromPTermWith ds ns a
|
||||
|
||||
private
|
||||
fromPTermEnumArms : CanError m =>
|
||||
fromPTermEnumArms : Has (Except Error) fs =>
|
||||
Context' BName d -> Context' BName n ->
|
||||
List (TagVal, PTerm) -> m (CaseEnumArms Three d n)
|
||||
List (TagVal, PTerm) -> Eff fs (CaseEnumArms Three d n)
|
||||
fromPTermEnumArms ds ns =
|
||||
map SortedMap.fromList . traverse (traverse $ fromPTermWith ds ns)
|
||||
|
||||
private
|
||||
fromPTermElim : CanError m =>
|
||||
fromPTermElim : Has (Except Error) fs =>
|
||||
Context' BName d -> Context' BName n ->
|
||||
PTerm -> m (Elim Three d n)
|
||||
PTerm -> Eff fs (Elim Three d n)
|
||||
fromPTermElim ds ns e =
|
||||
case !(fromPTermWith ds ns e) of
|
||||
E e => pure e
|
||||
_ => throwError $ AnnotationNeeded e
|
||||
_ => throw $ AnnotationNeeded e
|
||||
|
||||
-- [todo] use SN if the var is named but still unused
|
||||
private
|
||||
fromPTermTScope : {s : Nat} -> CanError m =>
|
||||
fromPTermTScope : {s : Nat} -> Has (Except Error) fs =>
|
||||
Context' BName d -> Context' BName n ->
|
||||
SnocVect s BName ->
|
||||
PTerm -> m (ScopeTermN s Three d n)
|
||||
PTerm -> Eff fs (ScopeTermN s Three d n)
|
||||
fromPTermTScope ds ns xs t =
|
||||
if all isNothing xs then
|
||||
SN <$> fromPTermWith ds ns t
|
||||
|
|
@ -197,10 +205,10 @@ mutual
|
|||
<$> fromPTermWith ds (ns ++ xs) t
|
||||
|
||||
private
|
||||
fromPTermDScope : {s : Nat} -> CanError m =>
|
||||
fromPTermDScope : {s : Nat} -> Has (Except Error) fs =>
|
||||
Context' BName d -> Context' BName n ->
|
||||
SnocVect s BName ->
|
||||
PTerm -> m (DScopeTermN s Three d n)
|
||||
PTerm -> Eff fs (DScopeTermN s Three d n)
|
||||
fromPTermDScope ds ns xs t =
|
||||
if all isNothing xs then
|
||||
SN <$> fromPTermWith ds ns t
|
||||
|
|
@ -210,29 +218,32 @@ mutual
|
|||
|
||||
|
||||
export %inline
|
||||
fromPTerm : CanError m => PTerm -> m (Term Three 0 0)
|
||||
fromPTerm : Has (Except Error) fs => PTerm -> Eff fs (Term Three 0 0)
|
||||
fromPTerm = fromPTermWith [<] [<]
|
||||
|
||||
|
||||
export
|
||||
globalPQty : CanError m => (q : PQty) -> m (IsGlobal q)
|
||||
globalPQty : Has (Except Error) fs =>
|
||||
(q : PQty) -> Eff fs (IsGlobal q)
|
||||
globalPQty pi = case isGlobal pi of
|
||||
Yes y => pure y
|
||||
No n => throwError $ QtyNotGlobal pi
|
||||
No n => throw $ QtyNotGlobal pi
|
||||
|
||||
|
||||
export
|
||||
fromPNameNS : HasNamespace m => PName -> m Name
|
||||
fromPNameNS name = asks $ \ns => addMods ns $ fromPName name
|
||||
fromPNameNS : Has (StateL NS Mods) fs => PName -> Eff fs Name
|
||||
fromPNameNS name = pure $ addMods !(getAt NS) $ fromPName name
|
||||
|
||||
private
|
||||
injTC : (CanError m, HasDefsRW m) => (forall m'. CanTC Three m' => m' a) -> m a
|
||||
injTC act =
|
||||
either (throwError . TypeError) pure $
|
||||
runReaderT {m = Either _} !get act
|
||||
injTC : (Has (StateL DEFS Defs) fs, Has (Except Error) fs) =>
|
||||
TC Three a -> Eff fs a
|
||||
injTC act = rethrow $ mapFst TypeError $ runTC !(getAt DEFS) act
|
||||
|
||||
export
|
||||
fromPDef : (CanError m, HasDefsRW m, HasNamespace m) => PDefinition -> m ()
|
||||
export covering
|
||||
fromPDef : (Has (StateL DEFS Defs) fs,
|
||||
Has (StateL NS Mods) fs,
|
||||
Has (Except Error) fs) =>
|
||||
PDefinition -> Eff fs NDef
|
||||
fromPDef (MkPDef qty pname ptype pterm) = do
|
||||
name <- fromPNameNS pname
|
||||
qtyGlobal <- globalPQty qty
|
||||
|
|
@ -243,39 +254,73 @@ fromPDef (MkPDef qty pname ptype pterm) = do
|
|||
Just type => do
|
||||
injTC $ checkTypeC empty type Nothing
|
||||
injTC $ ignore $ checkC empty sqty term type
|
||||
modify $ insert name $ mkDef qty type term
|
||||
let def = mkDef qty type term
|
||||
modifyAt DEFS $ insert name def
|
||||
pure (name, def)
|
||||
Nothing => do
|
||||
let E elim = term | _ => throwError $ AnnotationNeeded pterm
|
||||
let E elim = term | _ => throw $ AnnotationNeeded pterm
|
||||
res <- injTC $ inferC empty sqty elim
|
||||
modify $ insert name $ mkDef qty res.type term
|
||||
let def = mkDef qty res.type term
|
||||
modifyAt DEFS $ insert name def
|
||||
pure (name, def)
|
||||
|
||||
export
|
||||
fromPDecl : FromParser m => PDecl -> m ()
|
||||
fromPDecl (PDef def) = fromPDef def
|
||||
export covering
|
||||
fromPDecl : (Has (StateL DEFS Defs) fs,
|
||||
Has (StateL NS Mods) fs,
|
||||
Has (Except Error) fs) =>
|
||||
PDecl -> Eff fs (List NDef)
|
||||
fromPDecl (PDef def) = singleton <$> fromPDef def
|
||||
fromPDecl (PNs ns) =
|
||||
local (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
|
||||
localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
|
||||
|
||||
|
||||
export
|
||||
loadFile : (LoadFile m, CanError m) => String -> m (Maybe String)
|
||||
export covering
|
||||
loadFile : (Has IO fs,
|
||||
Has (StateL SEEN SeenFiles) fs,
|
||||
Has (Reader IncludePath) fs,
|
||||
Has (Except Error) fs) =>
|
||||
String -> Eff fs (Maybe String)
|
||||
loadFile file =
|
||||
if contains file !get then
|
||||
if contains file !(getAt SEEN) then
|
||||
pure Nothing
|
||||
else do
|
||||
Just file <- firstExists (map (</> file) !ask)
|
||||
| Nothing => throwError $ LoadError file FileNotFound
|
||||
| Nothing => throw $ LoadError file FileNotFound
|
||||
case !(readFile file) of
|
||||
Right res => pure $ Just res
|
||||
Left err => throwError $ LoadError file err
|
||||
Right res => modifyAt SEEN (insert file) $> Just res
|
||||
Left err => throw $ LoadError file err
|
||||
|
||||
parameters {auto _ : (Has IO fs,
|
||||
Has (StateL SEEN SeenFiles) fs,
|
||||
Has (Reader IncludePath) fs,
|
||||
Has (Except Error) fs,
|
||||
Has (StateL DEFS Defs) fs,
|
||||
Has (StateL NS Mods) fs)}
|
||||
mutual
|
||||
export covering
|
||||
loadProcessFile : String -> Eff fs (List NDef)
|
||||
loadProcessFile file =
|
||||
case !(loadFile file) of
|
||||
Just inp => do
|
||||
tl <- either (throw . ParseError) pure $ lexParseInput inp
|
||||
concat <$> traverse fromPTopLevel tl
|
||||
Nothing => pure []
|
||||
|
||||
||| populates the `defs` field of the state
|
||||
export covering
|
||||
fromPTopLevel : PTopLevel -> Eff fs (List NDef)
|
||||
fromPTopLevel (PD decl) = fromPDecl decl
|
||||
fromPTopLevel (PLoad file) = loadProcessFile file
|
||||
|
||||
|
||||
||| populates the `defs` field of the state
|
||||
export
|
||||
fromPTopLevel : FromParser m => PTopLevel -> m ()
|
||||
fromPTopLevel (PD decl) = fromPDecl decl
|
||||
fromPTopLevel (PLoad file) =
|
||||
case !(loadFile file) of
|
||||
Just inp => do
|
||||
tl <- either (throwError . ParseError) pure $ lexParseInput inp
|
||||
traverse_ fromPTopLevel tl
|
||||
Nothing => pure ()
|
||||
fromParserIO : (MonadRec io, HasIO io) =>
|
||||
IncludePath -> IORef SeenFiles -> IORef Defs ->
|
||||
FromParser a -> io (Either Error a)
|
||||
fromParserIO inc seen defs act =
|
||||
runIO $
|
||||
runExcept $
|
||||
evalStateAt NS [<] $
|
||||
runStateIORefAt SEEN seen $
|
||||
runStateIORefAt DEFS defs $
|
||||
runReader inc act
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue