quox/lib/Quox/Parser/FromParser.idr

430 lines
12 KiB
Idris
Raw Normal View History

2023-05-01 21:06:25 -04:00
||| take freshly-parsed input, scope check, type check, add to env
module Quox.Parser.FromParser
2023-08-25 12:09:06 -04:00
import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser
import Quox.Pretty
import Quox.Parser.Syntax
2023-03-13 14:33:09 -04:00
import Quox.Parser.Parser
2023-08-26 15:07:10 -04:00
import public Quox.Parser.LoadFile
import Quox.Typechecker
2024-04-14 10:20:40 -04:00
import Quox.CheckBuiltin
import Data.List
2023-05-14 13:58:46 -04:00
import Data.Maybe
import Data.SnocVect
2023-03-31 13:23:30 -04:00
import Quox.EffExtra
2023-09-18 18:41:47 -04:00
import Control.Monad.ST.Extra
2023-03-13 14:33:09 -04:00
import System.File
import System.Path
2023-03-31 13:23:30 -04:00
import Data.IORef
2023-03-13 14:33:09 -04:00
2023-10-19 23:23:56 -04:00
2023-03-31 13:23:30 -04:00
%hide Typing.Error
%hide Lexer.Error
%hide Parser.Error
2023-08-25 12:09:06 -04:00
%default total
2023-03-31 13:23:30 -04:00
public export
data StateTag = NS | SEEN
public export
FromParserPure : List (Type -> Type)
2024-04-04 12:23:50 -04:00
FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen, Log]
2023-05-01 21:06:25 -04:00
public export
FromParserIO : List (Type -> Type)
FromParserIO = FromParserPure ++ [LoadFile]
2024-04-04 12:23:50 -04:00
public export
record PureParserResult a where
constructor MkPureParserResult
val : a
suf : NameSuf
defs : Definitions
log : SnocList LogDoc
logLevels : LevelStack
export
fromParserPure : Mods -> NameSuf -> Definitions -> LevelStack ->
2024-04-04 12:23:50 -04:00
Eff FromParserPure a -> Either Error (PureParserResult a)
fromParserPure ns suf defs lvls act = runSTErr $ do
2024-04-04 12:23:50 -04:00
suf <- newSTRef' suf
defs <- newSTRef' defs
log <- newSTRef' [<]
lvls <- newSTRef' lvls
res <- runEff act $ with Union.(::)
2024-04-04 12:23:50 -04:00
[handleExcept $ \e => stLeft e,
handleStateSTRef defs,
2024-04-04 12:23:50 -04:00
handleStateSTRef !(newSTRef' ns),
handleStateSTRef suf,
handleLogST log lvls]
pure $ MkPureParserResult {
val = res,
suf = !(readSTRef' suf),
defs = !(readSTRef' defs),
log = !(readSTRef' log),
logLevels = !(readSTRef' lvls)
}
parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a)
(xs : Context' PatVar n)
private
fromBaseName : PBaseName -> m a
2024-04-11 16:08:07 -04:00
fromBaseName x = maybe (f $ MkPName [<] 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
2023-03-31 13:23:30 -04:00
fromPDimWith : Has (Except Error) fs =>
Context' PatVar d -> PDim -> Eff fs (Dim d)
2023-05-01 21:06:25 -04:00
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
2023-03-31 13:23:30 -04:00
avoidDim : Has (Except Error) fs =>
2023-05-01 21:06:25 -04:00
Context' PatVar d -> Loc -> PName -> Eff fs Name
avoidDim ds loc x =
fromName (const $ throw $ DimNameInTerm loc x.base) (pure . fromPName) ds x
private
2023-05-21 14:09:34 -04:00
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
2023-05-21 14:09:34 -04:00
pure $ FT here (fromMaybe 0 u) loc
else do
let ns :< _ = ns
2023-05-01 21:06:25 -04:00
| _ => throw $ TermNotInScope loc x
2023-05-21 14:09:34 -04:00
resolveName ns loc x u
export
2023-05-01 21:06:25 -04:00
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
2023-05-21 14:09:34 -04:00
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)
2023-08-25 12:09:06 -04:00
bound i = unless (isNothing u) (throw $ DisplacedBoundVar loc x) $> BT i loc
2023-05-21 14:09:34 -04:00
free : PName -> Eff FromParserPure (Term d n)
2023-08-25 12:09:06 -04:00
free x = resolveName !(getAt NS) loc !(avoidDim ds loc x) u
2023-05-21 14:09:34 -04:00
mutual
export
fromPTermWith : Context' PatVar d -> Context' PatVar n ->
PTerm -> Eff FromParserPure (Term d n)
fromPTermWith ds ns t0 = case t0 of
2023-05-01 21:06:25 -04:00
TYPE k loc =>
pure $ TYPE k loc
IOState loc =>
pure $ IOState loc
2023-05-01 21:06:25 -04:00
Pi pi x s t loc =>
Pi (fromPQty pi)
<$> fromPTermWith ds ns s
<*> fromPTermTScope ds ns [< x] t
2023-05-01 21:06:25 -04:00
<*> pure loc
2023-05-01 21:06:25 -04:00
Lam x s loc =>
Lam <$> fromPTermTScope ds ns [< x] s <*> pure loc
2023-05-01 21:06:25 -04:00
App s t loc =>
map E $ App
<$> fromPTermElim ds ns s
<*> fromPTermWith ds ns t
<*> pure loc
2023-05-01 21:06:25 -04:00
Sig x s t loc =>
Sig <$> fromPTermWith ds ns s
<*> fromPTermTScope ds ns [< x] t
<*> pure loc
2023-05-01 21:06:25 -04:00
Pair s t loc =>
Pair <$> fromPTermWith ds ns s <*> fromPTermWith ds ns t <*> pure loc
2023-05-01 21:06:25 -04:00
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
2023-05-01 21:06:25 -04:00
<*> pure loc
2023-09-18 15:52:51 -04:00
Fst pair loc =>
map E $ Fst <$> fromPTermElim ds ns pair <*> pure loc
Snd pair loc =>
map E $ Snd <$> fromPTermElim ds ns pair <*> pure loc
2023-05-01 21:06:25 -04:00
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 loc ds ns arms
2023-05-01 21:06:25 -04:00
<*> pure loc
2023-11-02 13:14:22 -04:00
NAT loc => pure $ NAT loc
Nat n loc => pure $ Nat n loc
2023-05-01 21:06:25 -04:00
Succ n loc => [|Succ (fromPTermWith ds ns n) (pure loc)|]
2023-03-26 08:40:54 -04:00
STRING loc => pure $ STRING loc
Str str loc => pure $ Str str loc
2023-05-01 21:06:25 -04:00
Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) loc =>
map E $ CaseNat (fromPQty pi) (fromPQty pi')
2023-03-26 08:40:54 -04:00
<$> fromPTermElim ds ns nat
<*> fromPTermTScope ds ns [< r] ret
<*> fromPTermWith ds ns zer
<*> fromPTermTScope ds ns [< s, ih] suc
2023-05-01 21:06:25 -04:00
<*> pure loc
2023-03-26 08:40:54 -04:00
Enum strs loc => do
let set = SortedSet.fromList strs
unless (length strs == length (SortedSet.toList set)) $
throw $ DuplicatesInEnumType loc strs
pure $ Enum set loc
2023-05-01 21:06:25 -04:00
Tag str loc => pure $ Tag str loc
2023-05-01 21:06:25 -04:00
Eq (i, ty) s t loc =>
Eq <$> fromPTermDScope ds ns [< i] ty
<*> fromPTermWith ds ns s
<*> fromPTermWith ds ns t
2023-05-01 21:06:25 -04:00
<*> pure loc
2023-05-01 21:06:25 -04:00
DLam i s loc =>
DLam <$> fromPTermDScope ds ns [< i] s <*> pure loc
2023-05-01 21:06:25 -04:00
DApp s p loc =>
map E $ DApp
<$> fromPTermElim ds ns s
<*> fromPDimWith ds p
<*> pure loc
2023-05-01 21:06:25 -04:00
BOX q ty loc => BOX (fromPQty q) <$> fromPTermWith ds ns ty <*> pure loc
2023-03-31 13:11:35 -04:00
2023-05-01 21:06:25 -04:00
Box val loc => Box <$> fromPTermWith ds ns val <*> pure loc
2023-03-31 13:11:35 -04:00
2023-05-01 21:06:25 -04:00
Case pi box (r, ret) (CaseBox b body _) loc =>
map E $ CaseBox (fromPQty pi)
2023-03-31 13:11:35 -04:00
<$> fromPTermElim ds ns box
<*> fromPTermTScope ds ns [< r] ret
<*> fromPTermTScope ds ns [< b] body
2023-05-01 21:06:25 -04:00
<*> pure loc
2023-03-31 13:11:35 -04:00
2023-05-21 14:09:34 -04:00
V x u loc => fromV ds ns x u loc
2023-05-01 21:06:25 -04:00
Ann s a loc =>
map E $ Ann
<$> fromPTermWith ds ns s
<*> fromPTermWith ds ns a
<*> pure loc
2023-05-01 21:06:25 -04:00
Coe (i, ty) p q val loc =>
2023-04-15 09:13:01 -04:00
map E $ Coe
<$> fromPTermDScope ds ns [< i] ty
<*> fromPDimWith ds p
<*> fromPDimWith ds q
<*> fromPTermWith ds ns val
2023-05-01 21:06:25 -04:00
<*> pure loc
2023-04-15 09:13:01 -04:00
2023-05-01 21:06:25 -04:00
Comp (i, ty) p q val r (j0, val0) (j1, val1) loc =>
map E $ CompH'
2023-04-15 09:13:01 -04:00
<$> 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
2023-05-01 21:06:25 -04:00
<*> pure loc
2023-04-15 09:13:01 -04:00
2023-12-04 12:48:25 -05:00
Let (qty, x, rhs) body loc =>
2023-12-04 16:47:52 -05:00
Let (fromPQty qty)
<$> fromPTermElim ds ns rhs
<*> fromPTermTScope ds ns [< x] body
<*> pure loc
2023-12-04 12:48:25 -05:00
private
fromPTermEnumArms : Loc -> Context' PatVar d -> Context' PatVar n ->
List (PTagVal, PTerm) ->
Eff FromParserPure (CaseEnumArms d n)
fromPTermEnumArms loc ds ns arms = do
res <- SortedMap.fromList <$>
traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns)) arms
unless (length (keys res) == length arms) $
throw $ DuplicatesInEnumCase loc (map (fromPTagVal . fst) arms)
pure res
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
2023-05-01 21:06:25 -04:00
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
2024-05-28 11:00:01 -04:00
SY (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
2023-11-27 15:01:36 -05:00
SN {f = \d => Term d n} <$> fromPTermWith ds ns t
else
2024-05-28 11:00:01 -04:00
SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t
export %inline
fromPTerm : PTerm -> Eff FromParserPure (Term 0 0)
fromPTerm = fromPTermWith [<] [<]
export
2023-11-05 14:49:02 -05:00
globalPQty : Has (Except Error) fs => PQty -> Eff fs GQty
globalPQty (PQ pi loc) = case toGlobal pi of
Just g => pure g
Nothing => throw $ QtyNotGlobal loc pi
2023-03-13 14:33:09 -04:00
export
2023-08-25 12:09:06 -04:00
fromPBaseNameNS : Has (StateL NS Mods) fs => PBaseName -> Eff fs Name
fromPBaseNameNS name = pure $ addMods !(getAt NS) $ fromPBaseName name
2023-08-25 12:09:06 -04:00
2023-03-13 14:33:09 -04:00
private
2023-08-24 13:55:57 -04:00
liftTC : Eff TC a -> Eff FromParserPure a
2023-08-25 12:09:06 -04:00
liftTC tc = runEff tc $ with Union.(::)
[handleExcept $ \e => throw $ WrapTypeError e,
handleReaderConst !(getAt DEFS),
2024-04-04 13:23:08 -04:00
\g => send g,
2023-08-25 12:09:06 -04:00
\g => send g]
2024-04-14 10:20:40 -04:00
private
liftWhnf : Eff Whnf a -> Eff FromParserPure a
liftWhnf tc = runEff tc $ with Union.(::)
[handleExcept $ \e => throw $ WrapTypeError e,
\g => send g,
\g => send g]
2023-08-25 12:09:06 -04:00
private
addDef : Has DefsState fs => Name -> Definition -> Eff fs NDefinition
addDef name def = do
2023-08-25 12:09:06 -04:00
modifyAt DEFS $ insert name def
pure (name, def)
2023-03-31 13:23:30 -04:00
export covering
2023-11-05 14:49:02 -05:00
fromPDef : PDefinition -> Eff FromParserPure NDefinition
fromPDef def = do
name <- fromPBaseNameNS def.name
2024-04-14 10:20:40 -04:00
defs <- getAt DEFS
when (isJust $ lookup name defs) $ do
2023-11-05 14:49:02 -05:00
throw $ AlreadyExists def.loc name
gqty <- globalPQty def.qty
2023-08-25 12:09:06 -04:00
let sqty = globalToSubj gqty
2023-11-05 14:49:02 -05:00
case def.body of
PConcrete ptype pterm => do
type <- traverse fromPTerm ptype
term <- fromPTerm pterm
2024-04-14 10:20:40 -04:00
type <- case type of
Just type => do
ignore $ liftTC $ do
checkTypeC empty type Nothing
checkC empty sqty term type
2024-04-14 10:20:40 -04:00
pure type
Nothing => do
let E elim = term
| _ => throw $ AnnotationNeeded term.loc empty term
res <- liftTC $ inferC empty sqty elim
2024-04-14 10:20:40 -04:00
pure res.type
when def.main $ liftWhnf $ expectMainType defs type
addDef name $ mkDef gqty type term def.scheme def.main def.loc
PPostulate ptype => do
type <- fromPTerm ptype
2023-11-05 14:49:02 -05:00
addDef name $ mkPostulate gqty type def.scheme def.main def.loc
2023-03-31 13:23:30 -04:00
public export
data HasFail = NoFail | AnyFail | FailWith String
export covering
2023-11-05 14:49:02 -05:00
expectFail : Loc -> Eff FromParserPure a -> Eff FromParserPure Error
2024-04-04 12:23:50 -04:00
expectFail loc act = do
gen <- getAt GEN; defs <- getAt DEFS; ns <- getAt NS; lvl <- curLevels
case fromParserPure ns gen defs (singleton lvl) act of
Left err => pure err
2023-11-05 14:49:02 -05:00
Right _ => throw $ ExpectedFail loc
2023-11-05 14:49:02 -05:00
export covering
maybeFail : Monoid a =>
PFail -> Loc -> Eff FromParserPure a -> Eff FromParserPure a
maybeFail PSucceed _ act = act
maybeFail PFailAny loc act = expectFail loc act $> neutral
maybeFail (PFailMatch str) loc act = do
err <- expectFail loc act
let msg = runPretty $ prettyError False err {opts = Opts 10_000} -- w/e
if str `isInfixOf` renderInfinite msg
2023-11-05 14:49:02 -05:00
then pure neutral
else throw $ WrongFail str err loc
2023-11-05 14:49:02 -05:00
export covering
fromPDecl : PDecl -> Eff FromParserPure (List NDefinition)
fromPDecl (PDef def) =
maybeFail def.fail def.loc $ singleton <$> fromPDef def
fromPDecl (PNs ns) =
maybeFail ns.fail ns.loc $
localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls
2024-04-12 15:49:15 -04:00
fromPDecl (PPrag prag) =
case prag of
PLogPush p _ => Log.push p $> []
PLogPop _ => Log.pop $> []
mutual
2023-03-31 13:23:30 -04:00
export covering
2023-05-01 21:06:25 -04:00
loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition)
loadProcessFile loc file =
2023-08-25 12:09:06 -04:00
case !(loadFile loc file) of
2023-10-19 23:23:56 -04:00
Just tl => concat <$> traverse fromPTopLevel tl
2023-03-31 13:23:30 -04:00
Nothing => pure []
||| populates the `defs` field of the state
export covering
2023-05-01 21:06:25 -04:00
fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition)
fromPTopLevel (PD decl) = lift $ fromPDecl decl
fromPTopLevel (PLoad file loc) = loadProcessFile loc file