pretty printer refactoring

lib/Quox/Syntax/Term/Pretty.idr

@@ -32,61 +32,66 @@ ofD     = hl Syntax "of"
 returnD = hl Syntax "return"
 
 
-export covering
+export
 prettyBindType : PrettyHL a => PrettyHL b => PrettyHL q =>
                  Pretty.HasEnv m =>
                  List q -> BaseName -> a -> Doc HL -> b -> m (Doc HL)
-prettyBindType qtys x s arr t =
+prettyBindType qtys x s arr t = do
-    parensIfM Outer $ hang 2 $
+  var <- prettyQtyBinds qtys $ TV x
-      parens (hang 2 $ !(prettyQtyBinds qtys (TV x)) <++> colonD
+  s   <- withPrec Outer $ prettyM s
-                <//> !(prettyM s)) <++> arr
+  t   <- withPrec Outer $ under T x $ prettyM t
-        <//> !(under T x $ prettyM t)
+  let bind = parens (var <++> colonD <//> hang 2 s)
+  parensIfM Outer $ hang 2 $ bind <//> t
 
-export covering
+export
+prettyArm : PrettyHL a => Pretty.HasEnv m =>
+            BinderSort -> List BaseName -> Doc HL -> a -> m (Doc HL)
+prettyArm sort xs pat body = do
+  body <- withPrec Outer $ unders sort xs $ prettyM body
+  pure $ hang 2 $ sep [pat <+> dotD, body]
+
+export
 prettyLams : PrettyHL a => Pretty.HasEnv m =>
-             BinderSort -> List BaseName -> a -> m (Doc HL)
+             Maybe (Doc HL) -> BinderSort -> List BaseName -> a -> m (Doc HL)
-prettyLams sort names body = do
+prettyLams lam sort names body = do
-  lam    <- case sort of T => lamD; D => dlamD
+  let var = case sort of T => TVar; D => DVar
-  header <- sequence $ [hl TVar <$> prettyM x | x <- names]
+  header <- sequence $ [hlF var $ prettyM x | x <- names]
-  body   <- unders sort names $ prettyM body
+  let header = sep $ maybe header (:: header) lam
-  parensIfM Outer $ (sep (lam :: header) <+> dotD) <//> body
+  parensIfM Outer =<< prettyArm sort names header body
 
-export covering
+export
 prettyApps : PrettyHL f => PrettyHL a => Pretty.HasEnv m =>
              Maybe (Doc HL) -> f -> List a -> m (Doc HL)
-prettyApps pfx fun args =
+prettyApps pfx fun args = do
-  parensIfM App =<< withPrec Arg
+  fun  <- withPrec Arg $ prettyM fun
-    [|prettyM fun <//> (align . sep <$> traverse prettyArg args)|]
+  args <- traverse (withPrec Arg . prettyArg) args
+  parensIfM App $ hang 2 $ sep $ fun :: args
  where
   prettyArg : a -> m (Doc HL)
-  prettyArg x = maybe id (\p => map (hl Delim p <+>)) pfx $ prettyM x
+  prettyArg = case pfx of
+    Nothing  => prettyM
+    Just pfx => \x => pure $ hl Delim pfx <+> !(prettyM x)
 
-export covering
+export
 prettyTuple : PrettyHL a => Pretty.HasEnv m => List a -> m (Doc HL)
 prettyTuple = map (parens . align . separate commaD) . traverse prettyM
 
-export covering
+export
-prettyArm : PrettyHL a => Pretty.HasEnv m =>
-            (List BaseName, Doc HL, a) -> m (Doc HL)
-prettyArm (xs, pat, body) =
-  pure $ hang 2 $ sep
-    [pat <+> dotD, !(withPrec Outer $ unders T xs $ prettyM body)]
-
-export covering
 prettyArms : PrettyHL a => Pretty.HasEnv m =>
              List (List BaseName, Doc HL, a) -> m (Doc HL)
-prettyArms = map (braces . align . sep) . traverse prettyArm
+prettyArms =
+  map (braces . asep) . traverse (\(xs, l, r) => prettyArm T xs l r)
 
-export covering
+export
 prettyCase : PrettyHL a => PrettyHL b => PrettyHL c => PrettyHL q =>
              Pretty.HasEnv m =>
              q -> a -> BaseName -> b -> List (List BaseName, Doc HL, c) ->
              m (Doc HL)
-prettyCase pi elim r ret arms =
+prettyCase pi elim r ret arms = do
-  pure $ align $ sep $
+  elim <- prettyQtyBinds [pi] elim
-    [hsep [caseD,   !(prettyQtyBinds [pi] elim)],
+  ret  <- prettyLams Nothing T [r] ret
-     hsep [returnD, !(prettyM r) <+> dotD, !(under T r $ prettyM ret)],
+  arms <- prettyArms arms
-     hsep [ofD,     !(prettyArms arms)]]
+  pure $ asep [caseD <++> elim, returnD <++> ret, ofD <++> arms]
 
 -- [fixme] put delimiters around tags that aren't simple names
 export
@@ -105,7 +110,7 @@ parameters (showSubsts : Bool)
       prettyBindType [qty] x s !arrowD t.term
     prettyM (Lam (S x t)) =
       let GotLams {names, body, _} = getLams' x t.term Refl in
-      prettyLams T (toList names) body
+      prettyLams (Just !lamD) T (toList names) body
     prettyM (Sig s (S [x] t)) =
       prettyBindType {q} [] x s !timesD t.term
     prettyM (Pair s t) =
@@ -116,21 +121,19 @@ parameters (showSubsts : Bool)
         Prelude.toList tags
     prettyM (Tag t) =
       pure $ prettyTag t
-    prettyM (Eq (S _ (N ty)) l r) =
+    prettyM (Eq (S _ (N ty)) l r) = do
-      parensIfM Eq !(withPrec InEq $ pure $
+      l  <- withPrec InEq $ prettyM l
-        sep [!(prettyM l) <++> !eqndD,
+      r  <- withPrec InEq $ prettyM r
-             !(prettyM r) <++> colonD, !(prettyM ty)])
+      ty <- withPrec InEq $ prettyM ty
-    prettyM (Eq (S [i] (Y ty)) l r) =
+      parensIfM Eq $ asep [l <++> !eqndD, r <++> colonD, ty]
-      parensIfM App $
+    prettyM (Eq (S [i] (Y ty)) l r) = do
-        eqD <++>
+      ty <- bracks <$> withPrec Outer (prettyLams Nothing D [i] ty)
-        sep [bracks !(withPrec Outer $ pure $ hang 2 $
+      l  <- withPrec Arg $ prettyM l
-               sep [hl DVar !(prettyM i) <+> dotD,
+      r  <- withPrec Arg $ prettyM r
-                    !(under D i $ prettyM ty)]),
+      parensIfM App $ eqD <++> asep [ty, l, r]
-             !(withPrec Arg $ prettyM l),
-             !(withPrec Arg $ prettyM r)]
     prettyM (DLam (S i t)) =
       let GotDLams {names, body, _} = getDLams' i t.term Refl in
-      prettyLams D (toList names) body
+      prettyLams (Just !dlamD) D (toList names) body
     prettyM (E e) = bracks <$> prettyM e
     prettyM (CloT s th) =
       if showSubsts then
@@ -156,8 +159,7 @@ parameters (showSubsts : Bool)
       let GotArgs {fun, args, _} = getArgs' e [s] in
       prettyApps Nothing fun args
     prettyM (CasePair pi p (S [r] ret) (S [x, y] body)) = do
-      pat <- (parens . separate commaD . map (hl TVar)) <$>
+      pat <- parens . separate commaD <$> traverse (hlF TVar . prettyM) [x, y]
-             traverse prettyM [x, y]
       prettyCase pi p r ret.term [([x, y], pat, body.term)]
     prettyM (CaseEnum pi t (S [r] ret) arms) =
       prettyCase pi t r ret.term
@@ -165,10 +167,10 @@ parameters (showSubsts : Bool)
     prettyM (e :% d) =
       let GotDArgs {fun, args, _} = getDArgs' e [d] in
       prettyApps (Just "@") fun args
-    prettyM (s :# a) =
+    prettyM (s :# a) = do
-      parensIfM Ann $ hang 2 $
+      s <- withPrec AnnL $ prettyM s
-        !(withPrec AnnL $ prettyM s) <++> !annD
+      a <- withPrec Ann  $ prettyM a
-          <//> !(withPrec Ann $ prettyM a)
+      parensIfM Ann $ hang 2 $ s <++> !annD <//> a
     prettyM (CloE e th)  =
       if showSubsts then
         parensIfM SApp . hang 2 =<<