add module Parser.Syntax with PTerm and toPTerm

lib/Quox/Parser.idr

@@ -1,18 +1,19 @@
 module Quox.Parser
 
-import public Quox.Syntax.Qty.Three
-import public Quox.Syntax
 import public Quox.Lexer
+import public Quox.Parser.Syntax
 
 import Data.Fin
 import Data.Vect
 import public Text.Parser
 
+
+-- [fixme] without this import idris fails to solve the
+-- IsReserved arguments, which, ??????????????????????
 import Derive.Prelude
 %hide TT.Name
 
 %default total
-%language ElabReflection
 
 
 public export
@@ -20,59 +21,8 @@ public export
 Grammar = Core.Grammar () Token
 %hide Core.Grammar
 
-
-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
-  %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
-
-    public export
-    data PCaseBody =
-        CasePair (BName, BName) PTerm
-      | CaseEnum (List (TagVal, PTerm))
-
-  %runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show]
-
 private
 data PArg = T PTerm | D PDim
-%runElab derive "PArg" [Eq, Ord, Show]
 
 
 private

lib/Quox/Parser/Syntax.idr

@@ -0,0 +1,152 @@
+module Quox.Parser.Syntax
+
+import public Quox.Syntax
+import public Quox.Syntax.Qty.Three
+
+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
+  %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
+
+    public export
+    data PCaseBody =
+        CasePair (BName, BName) PTerm
+      | CaseEnum (List (TagVal, PTerm))
+
+%runElab deriveMutual ["PTerm", "PCaseBody"] [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
+      TYPE (U 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 [<] [<]

lib/Quox/Typechecker.idr

@@ -291,11 +291,11 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
     let bodyctx = extendTyN [< tfst, tsnd.term] ctx
         bodyty  = substCasePairRet pairres.type ret
         pisg    = pi * sg.fst
-    bodyout <- popQs [< pisg, pisg] !(checkC bodyctx sg body.term bodyty)
+    bodyout <- checkC bodyctx sg body.term bodyty
     -- then Ψ | Γ ⊢ σ · case ⋯ ⇒ ret[pair/p] ⊳ πΣ₁ + Σ₂
     pure $ InfRes {
       type = sub1 ret pair,
-      qout = pi * pairres.qout + bodyout
+      qout = pi * pairres.qout + !(popQs [< pisg, pisg] bodyout)
     }
 
   infer' ctx sg (CaseEnum pi t ret arms) {n} = do

lib/quox-lib.ipkg

@@ -36,4 +36,5 @@ modules =
   Quox.Typing,
   Quox.Typechecker,
   Quox.Lexer,
+  Quox.Parser.Syntax,
   Quox.Parser