start of equality type stuff

lib/Quox/Syntax/Term/Pretty.idr

@@ -10,20 +10,18 @@ import Data.Vect
 %default total
 
 
-parameters {auto _ : Pretty.HasEnv m}
-  private %inline arrowD : m (Doc HL)
-  arrowD = hlF Syntax $ ifUnicode "→" "->"
+private %inline
+arrowD, lamD, eqndD, dlamD, annD : Pretty.HasEnv m => m (Doc HL)
+arrowD = hlF Syntax $ ifUnicode "→"  "->"
+lamD   = hlF Syntax $ ifUnicode "λ"  "fun"
+eqndD  = hlF Syntax $ ifUnicode "≡"  "=="
+dlamD  = hlF Syntax $ ifUnicode "λᴰ" "dfun"
+annD   = hlF Syntax $ ifUnicode "∷"  "::"
 
-  private %inline lamD : m (Doc HL)
-  lamD = hlF Syntax $ ifUnicode "λ" "fun"
-
-  private %inline annD : m (Doc HL)
-  annD = hlF Syntax $ ifUnicode "⦂" "::"
-
-private %inline typeD : Doc HL
-typeD = hl Syntax "Type"
-
-private %inline colonD : Doc HL
+private %inline
+typeD, eqD, colonD : Doc HL
+typeD  = hl Syntax "Type"
+eqD    = hl Syntax "Eq"
 colonD = hl Syntax ":"
 
 mutual
@@ -36,11 +34,23 @@ mutual
         !(prettyBinder [qty] x s) <++> !arrowD
           <//> !(under T x $ prettyM t)
     prettyM (Lam x t) =
-      parensIfM Outer $
-        sep [!lamD, hl TVar !(prettyM x), !arrowD]
-          <//> !(under T x $ prettyM t)
-    prettyM (E e) =
-      pure $ hl Delim "[" <+> !(prettyM e) <+> hl Delim "]"
+      let GotLams {names, body, _} = getLams' [x] t.term Refl in
+      prettyLams T (toList names) body
+    prettyM (Eq _ (DUnused ty) l r) =
+      parensIfM Eq !(withPrec InEq $ pure $
+        sep [!(prettyM l) <++> !eqndD, !(prettyM r) <++> colonD, !(prettyM ty)])
+    prettyM (Eq i (DUsed ty) l r) =
+      parensIfM App $
+        eqD <++>
+        sep [bracks !(withPrec Outer $ pure $ hang 2 $
+               sep [hl DVar !(prettyM i) <++> !arrowD,
+                    !(under D i $ prettyM ty)]),
+             !(withPrec Arg $ prettyM l),
+             !(withPrec Arg $ prettyM r)]
+    prettyM (DLam i t) =
+      let GotDLams {names, body, _} = getDLams' [i] t.term Refl in
+      prettyLams D (toList names) body
+    prettyM (E e) = bracks <$> prettyM e
     prettyM (CloT s th) =
       parensIfM SApp . hang 2 =<<
         [|withPrec SApp (prettyM s) </> prettyTSubst th|]
@@ -55,9 +65,11 @@ mutual
     prettyM (B i) =
       prettyVar TVar TVarErr (!ask).tnames i
     prettyM (e :@ s) =
-      let GotArgs f args _ = getArgs' e [s] in
-      parensIfM App =<< withPrec Arg
-        [|prettyM f <//> (align . sep <$> traverse prettyM args)|]
+      let GotArgs {fun, args, _} = getArgs' e [s] in
+      prettyApps fun args
+    prettyM (e :% d) =
+      let GotDArgs {fun, args, _} = getDArgs' e [d] in
+      prettyApps fun args
     prettyM (s :# a) =
       parensIfM Ann $ hang 2 $
         !(withPrec AnnL $ prettyM s) <++> !annD
@@ -71,7 +83,7 @@ mutual
 
   export covering
   PrettyHL q => PrettyHL (ScopeTerm q d n) where
-    prettyM body = prettyM $ fromScopeTerm body
+    prettyM body = prettyM body.term
 
   export covering
   prettyTSubst : Pretty.HasEnv m => PrettyHL q =>
@@ -86,3 +98,19 @@ mutual
       hsep [hl TVar !(prettyM x),
             sep [!(prettyQtyBinds pis),
                  hsep [colonD, !(withPrec Outer $ prettyM a)]]]
+
+  export covering
+  prettyLams : Pretty.HasEnv m => PrettyHL q =>
+               BinderSort -> List Name -> Term q _ _ -> m (Doc HL)
+  prettyLams sort names body = do
+    lam    <- case sort of T => lamD; D => dlamD
+    header <- sequence $ [hl TVar <$> prettyM x | x <- names] ++ [arrowD]
+    body   <- unders sort names $ prettyM body
+    parensIfM Outer $ sep (lam :: header) <//> body
+
+  export covering
+  prettyApps : Pretty.HasEnv m => PrettyHL f => PrettyHL a =>
+               f -> List a -> m (Doc HL)
+  prettyApps fun args =
+    parensIfM App =<< withPrec Arg
+      [|prettyM fun <//> (align . sep <$> traverse prettyM args)|]