399 lines
11 KiB
Idris
399 lines
11 KiB
Idris
||| take freshly-parsed input, scope check, type check, add to env
|
|
module Quox.Parser.FromParser
|
|
|
|
import Quox.Parser.Syntax
|
|
import Quox.Parser.Parser
|
|
import Quox.Typechecker
|
|
|
|
import Data.List
|
|
import Data.Maybe
|
|
import Data.SnocVect
|
|
import Quox.EffExtra
|
|
|
|
import System.File
|
|
import System.Path
|
|
import Data.IORef
|
|
|
|
import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
|
|
|
|
%default total
|
|
|
|
%hide Typing.Error
|
|
%hide Lexer.Error
|
|
%hide Parser.Error
|
|
|
|
|
|
public export
|
|
NDefinition : Type
|
|
NDefinition = (Name, Definition)
|
|
|
|
public export
|
|
IncludePath : Type
|
|
IncludePath = List String
|
|
|
|
public export
|
|
SeenFiles : Type
|
|
SeenFiles = SortedSet String
|
|
|
|
|
|
public export
|
|
data StateTag = NS | SEEN
|
|
|
|
public export
|
|
FromParserPure : List (Type -> Type)
|
|
FromParserPure =
|
|
[Except Error, DefsState, StateL NS Mods, NameGen]
|
|
|
|
public export
|
|
LoadFile' : List (Type -> Type)
|
|
LoadFile' = [IO, StateL SEEN SeenFiles, Reader IncludePath]
|
|
|
|
public export
|
|
LoadFile : List (Type -> Type)
|
|
LoadFile = LoadFile' ++ [Except Error]
|
|
|
|
public export
|
|
FromParserIO : List (Type -> Type)
|
|
FromParserIO = FromParserPure ++ LoadFile'
|
|
|
|
|
|
parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a)
|
|
(xs : Context' PatVar n)
|
|
private
|
|
fromBaseName : PBaseName -> m a
|
|
fromBaseName x = maybe (f $ MakePName [<] x) b $
|
|
Context.find (\y => y.name == Just x) xs
|
|
|
|
private
|
|
fromName : PName -> m a
|
|
fromName x = if null x.mods then fromBaseName x.base else f x
|
|
|
|
export
|
|
fromPDimWith : Has (Except Error) fs =>
|
|
Context' PatVar d -> PDim -> Eff fs (Dim d)
|
|
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 -> Loc -> PName -> Eff fs Name
|
|
avoidDim ds loc x =
|
|
fromName (const $ throw $ DimNameInTerm loc x.base) (pure . fromPName) ds x
|
|
|
|
private
|
|
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 (fromMaybe 0 u) loc
|
|
else do
|
|
let ns :< _ = ns
|
|
| _ => throw $ TermNotInScope loc x
|
|
resolveName ns loc x u
|
|
|
|
export
|
|
fromPatVar : PatVar -> BindName
|
|
fromPatVar (Unused loc) = BN Unused loc
|
|
fromPatVar (PV x loc) = BN (UN x) loc
|
|
|
|
export
|
|
fromPQty : PQty -> Qty
|
|
fromPQty (PQ q _) = q
|
|
|
|
export
|
|
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 ->
|
|
PTerm -> Eff FromParserPure (Term d n)
|
|
fromPTermWith ds ns t0 = case t0 of
|
|
TYPE k loc =>
|
|
pure $ TYPE k loc
|
|
|
|
Pi pi x s t loc =>
|
|
Pi (fromPQty pi)
|
|
<$> fromPTermWith ds ns s
|
|
<*> fromPTermTScope ds ns [< x] t
|
|
<*> pure loc
|
|
|
|
Lam x s loc =>
|
|
Lam <$> fromPTermTScope ds ns [< x] s <*> pure loc
|
|
|
|
App s t loc =>
|
|
map E $ App
|
|
<$> fromPTermElim ds ns s
|
|
<*> fromPTermWith ds ns t
|
|
<*> pure loc
|
|
|
|
Sig x s t loc =>
|
|
Sig <$> fromPTermWith ds ns s
|
|
<*> fromPTermTScope ds ns [< x] t
|
|
<*> pure loc
|
|
|
|
Pair s t loc =>
|
|
Pair <$> fromPTermWith ds ns s <*> fromPTermWith ds ns t <*> pure loc
|
|
|
|
W x s t loc =>
|
|
W <$> fromPTermWith ds ns s
|
|
<*> fromPTermTScope ds ns [< x] t
|
|
<*> pure loc
|
|
|
|
Sup s t loc =>
|
|
Sup <$> fromPTermWith ds ns s
|
|
<*> fromPTermWith ds ns t
|
|
<*> pure loc
|
|
|
|
Case pi tree (r, ret) (CaseW x y (rh, ih) body _) loc =>
|
|
map E $ CaseW (fromPQty pi) (fromPQty rh)
|
|
<$> fromPTermElim ds ns tree
|
|
<*> fromPTermTScope ds ns [< r] ret
|
|
<*> fromPTermTScope ds ns [< x, y, ih] body
|
|
<*> pure loc
|
|
|
|
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
|
|
|
|
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) _) 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 loc =>
|
|
let set = SortedSet.fromList strs in
|
|
if length strs == length (SortedSet.toList set) then
|
|
pure $ Enum set loc
|
|
else
|
|
throw $ DuplicatesInEnum loc strs
|
|
|
|
Tag str loc => pure $ Tag str loc
|
|
|
|
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
|
|
|
|
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 loc =>
|
|
DLam <$> fromPTermDScope ds ns [< i] s <*> pure loc
|
|
|
|
DApp s p loc =>
|
|
map E $ DApp
|
|
<$> fromPTermElim ds ns s
|
|
<*> fromPDimWith ds p
|
|
<*> pure loc
|
|
|
|
BOX q ty loc => BOX (fromPQty q) <$> fromPTermWith ds ns ty <*> pure loc
|
|
|
|
Box val loc => Box <$> fromPTermWith ds ns val <*> pure loc
|
|
|
|
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 u loc => fromV ds ns x u loc
|
|
|
|
Ann s a loc =>
|
|
map E $ Ann
|
|
<$> fromPTermWith ds ns s
|
|
<*> fromPTermWith ds ns a
|
|
<*> pure loc
|
|
|
|
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) loc =>
|
|
map E $ CompH'
|
|
<$> fromPTermDScope ds ns [< i] ty
|
|
<*> fromPDimWith ds p
|
|
<*> fromPDimWith ds q
|
|
<*> fromPTermWith ds ns val
|
|
<*> fromPDimWith ds r
|
|
<*> fromPTermDScope ds ns [< j0] val0
|
|
<*> fromPTermDScope ds ns [< j1] val1
|
|
<*> pure loc
|
|
|
|
private
|
|
fromPTermEnumArms : Context' PatVar d -> Context' PatVar n ->
|
|
List (PTagVal, PTerm) ->
|
|
Eff FromParserPure (CaseEnumArms d n)
|
|
fromPTermEnumArms ds ns =
|
|
map SortedMap.fromList .
|
|
traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns))
|
|
|
|
private
|
|
fromPTermElim : Context' PatVar d -> Context' PatVar n ->
|
|
PTerm -> Eff FromParserPure (Elim d n)
|
|
fromPTermElim ds ns e =
|
|
case !(fromPTermWith ds ns e) of
|
|
E e => pure e
|
|
t => let ctx = MkNameContexts (map fromPatVar ds) (map fromPatVar ns) in
|
|
throw $ AnnotationNeeded t.loc ctx t
|
|
|
|
private
|
|
fromPTermTScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
|
|
SnocVect s PatVar -> PTerm ->
|
|
Eff FromParserPure (ScopeTermN s d n)
|
|
fromPTermTScope ds ns xs t =
|
|
if all isUnused xs then
|
|
SN <$> fromPTermWith ds ns t
|
|
else
|
|
ST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t
|
|
|
|
private
|
|
fromPTermDScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n ->
|
|
SnocVect s PatVar -> PTerm ->
|
|
Eff FromParserPure (DScopeTermN s d n)
|
|
fromPTermDScope ds ns xs t =
|
|
if all isUnused xs then
|
|
SN <$> fromPTermWith ds ns t
|
|
else
|
|
DST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
|
|
|
|
|
|
export %inline
|
|
fromPTerm : PTerm -> Eff FromParserPure (Term 0 0)
|
|
fromPTerm = fromPTermWith [<] [<]
|
|
|
|
|
|
export
|
|
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 loc pi
|
|
|
|
|
|
export
|
|
fromPBaseNameNS : PBaseName -> Eff [StateL NS Mods] Name
|
|
fromPBaseNameNS name = pure $ addMods !(getAt NS) $ fromPBaseName name
|
|
|
|
private
|
|
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 defLoc) = do
|
|
name <- lift $ fromPBaseNameNS pname
|
|
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
|
|
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 | _ => 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)
|
|
|
|
export covering
|
|
fromPDecl : PDecl -> Eff FromParserPure (List NDefinition)
|
|
fromPDecl (PDef def) = singleton <$> fromPDef def
|
|
fromPDecl (PNs ns) =
|
|
localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
|
|
|
|
|
|
export covering
|
|
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 loc file FileNotFound
|
|
case !(readFile ifile) of
|
|
Right res => modifyAt SEEN (insert file) $> Just res
|
|
Left err => throw $ LoadError loc ifile err
|
|
|
|
mutual
|
|
export covering
|
|
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
|
|
Nothing => pure []
|
|
|
|
||| populates the `defs` field of the state
|
|
export covering
|
|
fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
|
|
fromPTopLevel (PD decl) = lift $ fromPDecl decl
|
|
fromPTopLevel (PLoad file loc) = loadProcessFile loc file
|
|
|
|
export
|
|
fromParserPure : NameSuf -> Definitions ->
|
|
Eff FromParserPure a ->
|
|
(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 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 $
|
|
runStateIORefAt DEFS defs $
|
|
runReader inc act
|