quox/lib/Quox/Parser/Syntax.idr

333 lines
8.8 KiB
Idris
Raw Normal View History

module Quox.Parser.Syntax
import public Quox.Syntax
import public Quox.Syntax.Qty.Three
2023-03-06 05:35:57 -05:00
import public Quox.Definition
2023-03-05 10:49:50 -05:00
import public Control.Monad.Either
import Derive.Prelude
%hide TT.Name
%default total
%language ElabReflection
public export
0 BName : Type
BName = Maybe BaseName
public export
0 PUniverse : Type
PUniverse = Nat
public export
0 PQty : Type
PQty = Three
namespace PDim
public export
data PDim = K DimConst | V BaseName
2023-03-05 10:49:50 -05:00
%name PDim p, q
%runElab derive "PDim" [Eq, Ord, Show]
namespace PTerm
mutual
||| terms out of the parser with BVs and bidirectionality still tangled up
public export
data PTerm =
TYPE Nat
| Pi PQty BName PTerm PTerm
| Lam BName PTerm
| (:@) PTerm PTerm
| Sig BName PTerm PTerm
| Pair PTerm PTerm
| Case PQty PTerm (BName, PTerm) (PCaseBody)
| Enum (List TagVal)
| Tag TagVal
| Eq (BName, PTerm) PTerm PTerm
| DLam BName PTerm
| (:%) PTerm PDim
| V Name
| (:#) PTerm PTerm
2023-03-05 10:49:50 -05:00
%name PTerm s, t
public export
data PCaseBody =
CasePair (BName, BName) PTerm
| CaseEnum (List (TagVal, PTerm))
2023-03-05 10:49:50 -05:00
%name PCaseBody body
%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show]
2023-03-06 05:35:57 -05:00
public export
record PDefinition where
constructor MkPDef
qty : PQty
name : Name
type : PTerm
term : PTerm
%name PDefinition def
%runElab derive "PDefinition" [Eq, Ord, Show]
export
toPDimWith : Context' BaseName d -> Dim d -> PDim
toPDimWith ds (K e) = K e
toPDimWith ds (B i) = V $ ds !!! i
export
toPDim : Dim 0 -> PDim
toPDim = toPDimWith [<]
mutual
namespace Term
export
toPTermWith : Context' BaseName d -> Context' BaseName n ->
Term Three d n -> PTerm
toPTermWith ds ns t =
let Element t _ = pushSubsts t in
toPTermWith' ds ns t
private
toPTermWith' : Context' BaseName d -> Context' BaseName n ->
(t : Term Three d n) -> (0 _ : NotClo t) =>
PTerm
toPTermWith' ds ns s = case s of
2023-03-05 10:48:29 -05:00
TYPE l =>
TYPE l
Pi qty arg (S [x] res) =>
Pi qty (Just x) (toPTermWith ds ns arg)
(toPTermWith ds (ns :< x) res.term)
Lam (S [x] body) =>
Lam (Just x) $ toPTermWith ds (ns :< x) body.term
Sig fst (S [x] snd) =>
Sig (Just x) (toPTermWith ds ns fst)
(toPTermWith ds (ns :< x) snd.term)
Pair fst snd =>
Pair (toPTermWith ds ns fst) (toPTermWith ds ns snd)
Enum cases =>
Enum $ SortedSet.toList cases
Tag tag =>
Tag tag
Eq (S [i] ty) l r =>
Eq (Just i, toPTermWith (ds :< i) ns ty.term)
(toPTermWith ds ns l) (toPTermWith ds ns r)
DLam (S [i] body) =>
DLam (Just i) $ toPTermWith (ds :< i) ns body.term
E e =>
toPTermWith ds ns e
namespace Elim
export
toPTermWith : Context' BaseName d -> Context' BaseName n ->
Elim Three d n -> PTerm
toPTermWith ds ns e =
let Element e _ = pushSubsts e in
toPTermWith' ds ns e
private
toPTermWith' : Context' BaseName d -> Context' BaseName n ->
(e : Elim Three d n) -> (0 _ : NotClo e) =>
PTerm
toPTermWith' ds ns e = case e of
F x =>
V x
B i =>
V $ unq $ ns !!! i
fun :@ arg =>
toPTermWith ds ns fun :@ toPTermWith ds ns arg
CasePair qty pair (S [r] ret) (S [x, y] body) =>
Case qty (toPTermWith ds ns pair)
(Just r, toPTermWith ds (ns :< r) ret.term)
(CasePair (Just x, Just y) $
toPTermWith ds (ns :< x :< y) body.term)
CaseEnum qty tag (S [r] ret) arms =>
Case qty (toPTermWith ds ns tag)
(Just r, toPTermWith ds (ns :< r) ret.term)
(CaseEnum $ mapSnd (toPTermWith ds ns) <$> SortedMap.toList arms)
fun :% arg =>
toPTermWith ds ns fun :% toPDimWith ds arg
tm :# ty =>
toPTermWith ds ns tm :# toPTermWith ds ns ty
namespace Term
export
toPTerm : Term Three 0 0 -> PTerm
toPTerm = toPTermWith [<] [<]
namespace Elim
export
toPTerm : Elim Three 0 0 -> PTerm
toPTerm = toPTermWith [<] [<]
2023-03-05 10:49:50 -05:00
public export
data FromPTermError =
AnnotationNeeded PTerm
| DuplicatesInEnum (List TagVal)
| DimNotInScope Name
2023-03-06 05:35:57 -05:00
| QtyNotGlobal PQty
2023-03-05 10:49:50 -05:00
public export
FromPTerm : (Type -> Type) -> Type
FromPTerm m = MonadError FromPTermError m
private
extendVect : Telescope' a from to -> Vect n a -> Telescope' a from (n + to)
extendVect tel [] = tel
extendVect tel (x :: xs) {n = S n} =
rewrite plusSuccRightSucc n to in
extendVect (tel :< x) xs
parameters {auto _ : FromPTerm m} (b : Var n -> m a) (f : Name -> m a)
(xs : Context' BName n)
private
fromBaseName : BaseName -> m a
fromBaseName x = maybe (f $ unq x) b $ Context.find (== Just x) xs
fromName : Name -> m a
fromName x = if null x.mods then fromBaseName x.base else f x
export
fromPDimWith : FromPTerm m =>
Context' BName d -> PDim -> m (Dim d)
fromPDimWith ds (K e) = pure $ K e
2023-03-06 05:35:57 -05:00
fromPDimWith ds (V i) = fromBaseName (pure . B) (throwError . DimNotInScope) ds i
2023-03-05 10:49:50 -05:00
mutual
export
fromPTermWith : FromPTerm m =>
Context' BName d -> Context' BName n ->
PTerm -> m (Term Three d n)
fromPTermWith ds ns t0 = case t0 of
TYPE k =>
pure $ TYPE $ k
Pi pi x s t =>
Pi pi <$> fromPTermWith ds ns s
<*> fromPTermTScope ds ns [x] t
Lam x s =>
Lam <$> fromPTermTScope ds ns [x] s
s :@ t =>
map E $ (:@) <$> fromPTermElim ds ns s <*> fromPTermWith ds ns t
Sig x s t =>
Sig <$> fromPTermWith ds ns s <*> fromPTermTScope ds ns [x] t
Pair s t =>
Pair <$> fromPTermWith ds ns s <*> fromPTermWith ds ns t
Case pi pair (r, ret) (CasePair (x, y) body) =>
map E $ Base.CasePair pi
<$> fromPTermElim ds ns pair
<*> fromPTermTScope ds ns [r] ret
<*> fromPTermTScope ds ns [x, y] body
Case pi tag (r, ret) (CaseEnum arms) =>
map E $ Base.CaseEnum pi
<$> fromPTermElim ds ns tag
<*> fromPTermTScope ds ns [r] ret
<*> assert_total fromPTermEnumArms ds ns arms
Enum strs =>
let set = SortedSet.fromList strs in
if length strs == length (SortedSet.toList set) then
pure $ Enum set
else
throwError $ DuplicatesInEnum strs
Tag str => pure $ Tag str
Eq (i, ty) s t =>
Eq <$> fromPTermDScope ds ns [i] ty
<*> fromPTermWith ds ns s
<*> fromPTermWith ds ns t
DLam i s =>
DLam <$> fromPTermDScope ds ns [i] s
s :% p =>
map E $ (:%) <$> fromPTermElim ds ns s <*> fromPDimWith ds p
V x =>
fromName (pure . E . B) (pure . FT) ns x
s :# a =>
map E $ (:#) <$> fromPTermWith ds ns s <*> fromPTermWith ds ns a
private
fromPTermEnumArms : FromPTerm m =>
Context' BName d -> Context' BName n ->
List (TagVal, PTerm) -> m (CaseEnumArms Three d n)
fromPTermEnumArms ds ns =
map SortedMap.fromList . traverse (traverse $ fromPTermWith ds ns)
private
fromPTermElim : FromPTerm m =>
Context' BName d -> Context' BName n ->
PTerm -> m (Elim Three d n)
fromPTermElim ds ns e =
case !(fromPTermWith ds ns e) of
E e => pure e
_ => throwError $ AnnotationNeeded e
-- [todo] use SN if the var is named but still unused
private
fromPTermTScope : {s : Nat} -> FromPTerm m =>
Context' BName d -> Context' BName n ->
Vect s BName ->
PTerm -> m (ScopeTermN s Three d n)
fromPTermTScope ds ns xs t =
if all isNothing xs then
SN <$> fromPTermWith ds ns t
else
SY (map (fromMaybe "_") xs) <$> fromPTermWith ds (extendVect ns xs) t
private
fromPTermDScope : {s : Nat} -> FromPTerm m =>
Context' BName d -> Context' BName n ->
Vect s BName ->
PTerm -> m (DScopeTermN s Three d n)
fromPTermDScope ds ns xs t =
if all isNothing xs then
SN <$> fromPTermWith ds ns t
else
SY (map (fromMaybe "_") xs) <$> fromPTermWith (extendVect ds xs) ns t
export %inline
fromPTerm : FromPTerm m => PTerm -> m (Term Three 0 0)
fromPTerm = fromPTermWith [<] [<]
2023-03-06 05:35:57 -05:00
export
globalPQty : FromPTerm m => (q : PQty) -> m (IsGlobal q)
globalPQty Zero = pure GZero
globalPQty One = throwError $ QtyNotGlobal One
globalPQty Any = pure GAny
-- [todo] extend substitutions so they can do this injection. that's the sort of
-- thing they are for.
export
fromPDefinition : FromPTerm m => PDefinition -> m (Name, Definition Three)
fromPDefinition (MkPDef {name, qty, type, term}) =
pure (name, MkDef' {
qty, qtyGlobal = !(globalPQty qty),
type = T $ inject !(fromPTerm type),
term = Just $ T $ inject !(fromPTerm term)
})