type-case

lib/Quox/Syntax/Term/Pretty.idr

@@ -25,17 +25,19 @@ annD    = hlF Syntax $ ifUnicode "∷" "::"
 natD    = hlF Syntax $ ifUnicode "ℕ" "Nat"
 
 export %inline
-eqD, colonD, commaD, semiD, caseD, returnD, ofD, dotD, zeroD, succD : Doc HL
-eqD     = hl Syntax "Eq"
-colonD  = hl Syntax ":"
-commaD  = hl Syntax ","
-semiD   = hl Syntax ";"
-caseD   = hl Syntax "case"
-ofD     = hl Syntax "of"
-returnD = hl Syntax "return"
-dotD    = hl Delim "."
-zeroD   = hl Syntax "zero"
-succD   = hl Syntax "succ"
+eqD, colonD, commaD, semiD, caseD, typecaseD, returnD,
+ofD, dotD, zeroD, succD : Doc HL
+eqD       = hl Syntax "Eq"
+colonD    = hl Syntax ":"
+commaD    = hl Syntax ","
+semiD     = hl Syntax ";"
+caseD     = hl Syntax "case"
+typecaseD = hl Syntax "type-case"
+ofD       = hl Syntax "of"
+returnD   = hl Syntax "return"
+dotD      = hl Delim "."
+zeroD     = hl Syntax "zero"
+succD     = hl Syntax "succ"
 
 
 export
@@ -141,6 +143,19 @@ prettyArms =
   map (braces . aseparate semiD) .
   traverse (\(xs, l, r) => prettyArm T xs l r)
 
+export
+prettyCase' : (PrettyHL a, PrettyHL b, PrettyHL c, Pretty.HasEnv m) =>
+              Doc HL -> a -> BaseName -> b ->
+              List (SnocList BaseName, Doc HL, c) ->
+              m (Doc HL)
+prettyCase' intro elim r ret arms = do
+  elim  <- pretty0M elim
+  ret   <- case r of
+    Unused => pretty0M ret
+    _      => prettyLams Nothing T [< r] ret
+  arms  <- prettyArms arms
+  pure $ asep [intro <++> elim, returnD <++> ret, ofD <++> arms]
+
 export
 prettyCase : (PrettyHL a, PrettyHL b, PrettyHL c, Pretty.HasEnv m) =>
              Qty -> a -> BaseName -> b ->
@@ -148,10 +163,7 @@ prettyCase : (PrettyHL a, PrettyHL b, PrettyHL c, Pretty.HasEnv m) =>
              m (Doc HL)
 prettyCase pi elim r ret arms = do
   caseq <- (caseD <+>) <$> prettySuffix pi
-  elim  <- pretty0M elim
-  ret   <- prettyLams Nothing T [< r] ret
-  arms  <- prettyArms arms
-  pure $ asep [caseq <++> elim, returnD <++> ret, ofD <++> arms]
+  prettyCase' caseq elim r ret arms
 
 export
 escapeString : String -> String
@@ -293,6 +305,24 @@ parameters (showSubsts : Bool)
       s <- withPrec AnnL $ prettyM s
       a <- withPrec AnnR $ prettyM a
       parensIfM AnnR $ hang 2 $ s <++> !annD <%%> a
+    prettyM (TypeCase ty ret univ
+                (S [< piA, piB] pi) (S [< sigA, sigB] sig) enum
+                (S [< eqA0, eqA1, eqA, eqL, eqR] eq)
+                nat (S [< boxA] box)) = do
+      let v : BaseName -> Doc HL := pretty0 True . TV
+      pipat  <- pure $ parens $ hsep [v piA,  !arrowD, v piB]
+      sigpat <- pure $ parens $ hsep [v sigA, !timesD, v sigB]
+      eqpat  <- prettyApps Nothing (L eqD)
+                  [TV eqA0, TV eqA1, TV eqA, TV eqL, TV eqR]
+      boxpat <- pure $ bracks $ v boxA
+      prettyCase' typecaseD ty Unused ret
+        [([<], !typeD, eterm univ),
+         ([< piA, piB], pipat, eterm pi.term),
+         ([< sigA, sigB], sigpat, eterm sig.term),
+         ([<], hl Syntax "{}", eterm enum),
+         ([< eqA0, eqA1, eqA, eqL, eqR], eqpat, eterm eq.term),
+         ([<], !natD, eterm nat),
+         ([< boxA], boxpat, eterm box.term)]
     prettyM (CloE e th)  =
       if showSubsts then
         parensIfM SApp . hang 2 =<<