unify Doc types; better expr. pretty print

10 files changed, 133 insertions, 117 deletions

diff --git a/lambdacube-compiler.cabal b/lambdacube-compiler.cabal
index 17c8fd56..a5bd8980 100644
--- a/lambdacube-compiler.cabal
+++ b/lambdacube-compiler.cabal
@@ -136,7 +136,7 @@ executable lambdacube-compiler-test-suite
     monad-control >= 1.0 && <1.1,
     optparse-applicative == 0.12.*,
     megaparsec >= 4.3.0 && <4.5,
-    wl-pprint >=1.2 && <1.3,
+    ansi-wl-pprint >=0.6 && <0.7,
     patience >= 0.1 && < 0.2,
     text >= 1.2 && <1.3,
     time >= 1.5 && <1.6,
@@ -244,7 +244,7 @@ executable lambdacube-compiler-coverage-test-suite
     monad-control >= 1.0 && <1.1,
     optparse-applicative == 0.12.*,
     megaparsec >= 4.3.0 && <4.5,
-    wl-pprint >=1.2 && <1.3,
+    ansi-wl-pprint >=0.6 && <0.7,
     pretty-show >= 1.6.9,
     patience >= 0.1 && < 0.2,
     text >= 1.2 && <1.3,
diff --git a/src/LambdaCube/Compiler/CoreToIR.hs b/src/LambdaCube/Compiler/CoreToIR.hs
index 13aac101..d9d31d68 100644
--- a/src/LambdaCube/Compiler/CoreToIR.hs
+++ b/src/LambdaCube/Compiler/CoreToIR.hs
@@ -913,7 +913,7 @@ instance Up ExpTV where
     closedExp (ExpTV a b cs) = ExpTV (closedExp a) (closedExp b) cs
 
 instance PShow ExpTV where
-    pShowPrec p (ExpTV x t _) = pShowPrec p (x, t)
+    pShow (ExpTV x t _) = pShow (x, t)
 
 isSampler (TyCon n _) = show n == "'Sampler"
 isSampler _ = False
diff --git a/src/LambdaCube/Compiler/DesugaredSource.hs b/src/LambdaCube/Compiler/DesugaredSource.hs
index 0511988a..e588403a 100644
--- a/src/LambdaCube/Compiler/DesugaredSource.hs
+++ b/src/LambdaCube/Compiler/DesugaredSource.hs
@@ -24,6 +24,7 @@ import qualified Data.Set as Set
 import qualified Data.IntMap as IM
 import Control.Arrow hiding ((<+>))
 import Control.DeepSeq
+import Debug.Trace
 
 import LambdaCube.Compiler.Utils
 import LambdaCube.Compiler.DeBruijn
@@ -64,7 +65,7 @@ data SPos = SPos
   deriving (Eq, Ord)
 
 instance PShow SPos where
-    pShowPrec _ (SPos r c) = pShow r <> ":" <> pShow c
+    pShow (SPos r c) = pShow r <> ":" <> pShow c
 
 -------------------------------------------------------------------------------- file info
 
@@ -77,7 +78,7 @@ data FileInfo = FileInfo
 instance Eq FileInfo where (==) = (==) `on` fileId
 instance Ord FileInfo where compare = compare `on` fileId
 
-instance PShow FileInfo where pShowPrec _ = text . filePath
+instance PShow FileInfo where pShow = text . filePath
 instance Show FileInfo where show = ppShow
 
 showPos :: FileInfo -> SPos -> Doc
@@ -92,7 +93,7 @@ instance NFData Range where
     rnf Range{} = ()
 
 -- short version
-instance PShow Range where pShowPrec _ (Range n b e) = pShow n <+> pShow b <> "-" <> pShow e
+instance PShow Range where pShow (Range n b e) = pShow n <+> pShow b <> "-" <> pShow e
 instance Show Range where show = ppShow
 
 -- long version
@@ -131,8 +132,8 @@ instance Monoid SI where
     mappend _ r@RangeSI{} = r
 
 instance PShow SI where
-    pShowPrec _ (NoSI ds) = hsep $ map text $ Set.toList ds
-    pShowPrec _ (RangeSI r) = pShow r
+    pShow (NoSI ds) = hsep $ map text $ Set.toList ds
+    pShow (RangeSI r) = pShow r
 
 -- long version
 showSI x = case sourceInfo x of
@@ -155,13 +156,14 @@ pattern SIName si n <- SIName_ si _ n
 instance Eq SIName where (==) = (==) `on` sName
 instance Ord SIName where compare = compare `on` sName
 instance Show SIName where show = sName
-instance PShow SIName where pShowPrec _ = text . sName
+instance PShow SIName where pShow = text . sName
 
 sName (SIName _ s) = s
 
 --appName f (SIName si n) = SIName si $ f n
 
-getFixity (SIName_ _ f _) = fromMaybe (Fixity InfixL 9) f
+getFixity_ (SIName_ _ f _) = f
+--getFixity (SIName_ _ f _) = fromMaybe (Fixity InfixL 9) f
 
 -------------
 
@@ -386,13 +388,14 @@ trSExp' :: SExp -> SExp' a
 trSExp' = trSExp elimVoid
 
 instance Up a => PShow (SExp' a) where
-    pShowPrec _ = showDoc_ . sExpDoc
+    pShow = sExpDoc
 
 sExpDoc :: Up a => SExp' a -> NDoc
 sExpDoc = \case
     SGlobal ns      -> shAtom $ sName ns
     SAnn a b        -> shAnn ":" False (sExpDoc a) (sExpDoc b)
     TyType a        -> shApp Visible (shAtom "tyType") (sExpDoc a)
+    SGlobal op `SAppV` a `SAppV` b | Just p <- getFixity_ op -> DOp p (pShow a) (sName op) (pShow b)
     SApp h a b      -> shApp h (sExpDoc a) (sExpDoc b)
     Wildcard t      -> shAnn ":" True (shAtom "_") (sExpDoc t)
     SBind_ _ h _ a b -> shLam (usedVar 0 b) h (sExpDoc a) (sExpDoc b)
@@ -401,6 +404,9 @@ sExpDoc = \case
     SVar _ i        -> shVar i
     SLit _ l        -> shAtom $ show l
 
+shApp Visible a b = DApp a b
+shApp Hidden a b = DApp a (DOp (Fixity InfixR 20) "@" "" b)
+
 shLam usedVar h a b = DFreshName usedVar $ lam (p $ DUp 0 a) b
   where
     lam = case h of
@@ -408,7 +414,7 @@ shLam usedVar h a b = DFreshName usedVar $ lam (p $ DUp 0 a) b
         _ -> shLam'
 
     p = case h of
-        BMeta -> cpar . shAnn ":" True (inBlue' $ DVar 0)
+        BMeta -> shAnn ":" True (inBlue' $ DVar 0)
         BLam h -> vpar h
         BPi h -> vpar h
 
@@ -429,7 +435,7 @@ data Stmt
 pattern Primitive n t = Let n (Just t) (SBuiltin "undefined")
 
 instance PShow Stmt where
-    pShowPrec p = \case
+    pShow = \case
         Let n ty e -> text (sName n) </> "=" <+> maybe (pShow e) (\ty -> pShow e </> "::" <+> pShow ty) ty 
         Data n ps ty cs -> "data" <+> text (sName n)
         PrecDef n i -> "precedence" <+> text (sName n) <+> text (show i)
diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs
index 492e9a69..b44d67f2 100644
--- a/src/LambdaCube/Compiler/Infer.hs
+++ b/src/LambdaCube/Compiler/Infer.hs
@@ -1443,29 +1443,29 @@ joinEnv e1 e2 = do
 
 downTo n m = map Var [n+m-1, n+m-2..n]
 
-tellType si t = tell $ mkInfoItem (sourceInfo si) $ removeEscs $ showDoc $ mkDoc False True (t, TType)
+tellType si t = tell $ mkInfoItem (sourceInfo si) $ removeEscs $ show $ mkDoc False True (t, TType)
 
 
 -------------------------------------------------------------------------------- pretty print
 -- todo: do this via conversion to SExp
 
 instance PShow Exp where
-    pShowPrec _ = showDoc_ . mkDoc False False
+    pShow = mkDoc False False
 
 instance PShow (CEnv Exp) where
-    pShowPrec _ = showDoc_ . mkDoc False False
+    pShow = mkDoc False False
 
 instance PShow Env where
-    pShowPrec _ e = showDoc_ $ envDoc e $ epar $ shAtom "<<HERE>>"
+    pShow e = envDoc e $ epar $ shAtom "<<HERE>>"
 
 showEnvExp :: Env -> ExpType -> String
-showEnvExp e c = showDoc $ envDoc e $ epar $ mkDoc False False c
+showEnvExp e c = show $ envDoc e $ epar $ mkDoc False False c
 
 showEnvSExp :: Up a => Env -> SExp' a -> String
-showEnvSExp e c = showDoc $ envDoc e $ epar $ sExpDoc c
+showEnvSExp e c = show $ envDoc e $ epar $ sExpDoc c
 
 showEnvSExpType :: Up a => Env -> SExp' a -> Exp -> String
-showEnvSExpType e c t = showDoc $ envDoc e $ epar $ (shAnn "::" False (sExpDoc c) (mkDoc False False (t, TType)))
+showEnvSExpType e c t = show $ envDoc e $ epar $ (shAnn "::" False (sExpDoc c) (mkDoc False False (t, TType)))
 {-
   where
     infixl 4 <**>
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs
index 49079073..33a24d0a 100644
--- a/src/LambdaCube/Compiler/Parser.hs
+++ b/src/LambdaCube/Compiler/Parser.hs
@@ -71,7 +71,7 @@ instance Show LCParseError where
     show = \case
         MultiplePatternVars xs -> unlines $ "multiple pattern vars:":
             concat [(sName (head ns) ++ " is defined at"): map showSI ns | ns <- xs]
-        OperatorMismatch op op' -> "Operator precedences don't match:\n" ++ show (getFixity op) ++ " at " ++ showSI op ++ "\n" ++ show (getFixity op') ++ " at " ++ showSI op'
+        OperatorMismatch op op' -> "Operator precedences don't match:\n" ++ show (fromJust $ getFixity_ op) ++ " at " ++ showSI op ++ "\n" ++ show (fromJust $ getFixity_ op') ++ " at " ++ showSI op'
         UndefinedConstructor n -> "Constructor " ++ show n ++ " is not defined at " ++ showSI n
         ParseError p -> show p
 
@@ -105,7 +105,7 @@ instance Monoid DesugarInfo where
 addFixity :: BodyParser SIName -> BodyParser SIName
 addFixity p = f <$> asks (fixityMap . desugarInfo) <*> p
   where
-    f fm sn@(SIName_ si _ n) = SIName_ si (Map.lookup n fm) n
+    f fm sn@(SIName_ si _ n) = SIName_ si (Just $ fromMaybe (Fixity InfixL 9) $ Map.lookup n fm) n
 
 addConsInfo p = join $ f <$> asks (consMap . desugarInfo) <*> p
   where
@@ -278,7 +278,7 @@ calculatePrecs = go where
     waitOp lsec e acc []            = calcPrec' e acc
     waitOp lsec e acc _             = error "impossible @ Parser 488"
 
-    calcPrec' e = postponedCheck id . calcPrec (\op x y -> SGlobal op `SAppV` x `SAppV` y) getFixity e . reverse
+    calcPrec' e = postponedCheck id . calcPrec (\op x y -> SGlobal op `SAppV` x `SAppV` y) (fromJust . getFixity_) e . reverse
 
 generator, letdecl, boolExpression :: BodyParser (SExp -> ErrorFinder SExp)
 generator = do
@@ -337,7 +337,7 @@ mkPVar s = PVarSimp s
 
 concatParPats ps = ParPat $ concat [p | ParPat p <- ps]
 
-litP = flip ViewPatSimp cTrue . SAppV (SBuiltin "==")
+litP = flip ViewPatSimp cTrue . SAppV (SGlobal $ SIName_ mempty (Just $ Fixity Infix 4) "==")
 
 patlist = commaSep $ setR parsePatAnn
 
@@ -357,7 +357,7 @@ mkTup ps = foldr cHCons cHNil ps
 patType p (Wildcard SType) = p
 patType p t = PatTypeSimp p t
 
-calculatePatPrecs e xs = postponedCheck fst $ calcPrec (\op x y -> PConSimp op [x, y]) (getFixity . fst) e xs
+calculatePatPrecs e xs = postponedCheck fst $ calcPrec (\op x y -> PConSimp op [x, y]) (fromJust . getFixity_ . fst) e xs
 
 longPattern = setR parsePatAnn <&> (reverse . getPVars &&& id)
 
diff --git a/src/LambdaCube/Compiler/Patterns.hs b/src/LambdaCube/Compiler/Patterns.hs
index 00626d2e..06036f44 100644
--- a/src/LambdaCube/Compiler/Patterns.hs
+++ b/src/LambdaCube/Compiler/Patterns.hs
@@ -54,9 +54,9 @@ pattern ParPat ps <- ParPat_ _ ps
   where ParPat ps =  ParPat_ (foldMap sourceInfo ps) ps
 
 instance PShow (Pat_ a) where
-    pShowPrec _ = showDoc_ . patDoc
+    pShow = patDoc
 instance PShow (ParPat_ a) where
-    pShowPrec _ = showDoc_ . parPatDoc
+    pShow = parPatDoc
 
 
 pattern PWildcard si = ParPat_ si []
diff --git a/src/LambdaCube/Compiler/Pretty.hs b/src/LambdaCube/Compiler/Pretty.hs
index e7c1216f..e94f6e41 100644
--- a/src/LambdaCube/Compiler/Pretty.hs
+++ b/src/LambdaCube/Compiler/Pretty.hs
@@ -4,98 +4,74 @@
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
 module LambdaCube.Compiler.Pretty
     ( module LambdaCube.Compiler.Pretty
-    , Doc
-    , (<+>), (</>), (<$$>)
-    , hsep, hcat, vcat
---    , punctuate
-    , tupled, braces, parens
-    , text
-    , nest
     ) where
 
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Control.Monad.Except
+import Data.Monoid
+import Data.String
+--import qualified Data.Set as Set
+--import qualified Data.Map as Map
 import Control.Monad.Reader
 import Control.Monad.State
 import Control.Arrow hiding ((<+>))
-import Debug.Trace
+--import Debug.Trace
 
-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
+import qualified Text.PrettyPrint.ANSI.Leijen as P
 
 import LambdaCube.Compiler.Utils
 
+type Doc = NDoc
+hsep [] = mempty
+hsep xs = foldr1 (<+>) xs
+vcat [] = mempty
+vcat xs = foldr1 (<$$>) xs
+text = DAtom
+
 --------------------------------------------------------------------------------
 
 class PShow a where
-    pShowPrec :: Int -> a -> Doc
+    pShow :: a -> NDoc
 
-pShow = pShowPrec (-2)
 ppShow = show . pShow
 
-ppShow' = show
-
---------------------------------------------------------------------------------
-
-pParens p x
-    | p = tupled [x]
-    | otherwise = x
-
-pOp i j k sep p a b = pParens (p >= i) $ pShowPrec j a <+> sep <+> pShowPrec k b
-pOp' i j k sep p a b = pParens (p >= i) $ pShowPrec j a </> sep <+> pShowPrec k b
-
-pInfixl i = pOp i (i-1) i
-pInfixr i = pOp i i (i-1)
-pInfixr' i = pOp' i i (i-1)
-pInfix  i = pOp i i i
-
-pTyApp = pInfixl 10 "@"
-pApps p x [] = pShowPrec p x
-pApps p x xs = pParens (p > 9) $ hsep $ pShowPrec 9 x: map (pShowPrec 10) xs
-pApp p a b = pApps p a [b]
-
-showRecord = braces . hsep . punctuate (pShow ',') . map (\(a, b) -> pShow a <> ":" <+> pShow b)
-
 --------------------------------------------------------------------------------
 
 instance PShow Bool where
-    pShowPrec p b = if b then "True" else "False"
+    pShow b = if b then "True" else "False"
 
 instance (PShow a, PShow b) => PShow (a, b) where
-    pShowPrec p (a, b) = tupled [pShow a, pShow b]
+    pShow (a, b) = tupled [pShow a, pShow b]
 
 instance (PShow a, PShow b, PShow c) => PShow (a, b, c) where
-    pShowPrec p (a, b, c) = tupled [pShow a, pShow b, pShow c]
+    pShow (a, b, c) = tupled [pShow a, pShow b, pShow c]
 
 instance PShow a => PShow [a] where
-    pShowPrec p = brackets . sep . punctuate comma . map pShow
+--    pShow = P.brackets . P.sep . P.punctuate P.comma . map pShow  -- TODO
 
 instance PShow a => PShow (Maybe a) where
-    pShowPrec p = \case
-        Nothing -> "Nothing"
-        Just x -> "Just" <+> pShow x
+    pShow = maybe "Nothing" (("Just" `DApp`) . pShow)
 
-instance PShow a => PShow (Set a) where
-    pShowPrec p = pShowPrec p . Set.toList
+--instance PShow a => PShow (Set a) where
+--    pShow = pShow . Set.toList
 
-instance (PShow s, PShow a) => PShow (Map s a) where
-    pShowPrec p = braces . vcat . map (\(k, t) -> pShow k <> colon <+> pShow t) . Map.toList
+--instance (PShow s, PShow a) => PShow (Map s a) where
+--    pShow = braces . vcat . map (\(k, t) -> pShow k <> P.colon <+> pShow t) . Map.toList
 
 instance (PShow a, PShow b) => PShow (Either a b) where
-    pShowPrec p = either (("Left" <+>) . pShow) (("Right" <+>) . pShow)
+   pShow = either (("Left" `DApp`) . pShow) (("Right" `DApp`) . pShow)
 
-instance PShow Doc where
-    pShowPrec p x = x
+instance PShow NDoc where
+    pShow x = x
 
-instance PShow Int     where pShowPrec _ = int
-instance PShow Integer where pShowPrec _ = integer
-instance PShow Double  where pShowPrec _ = double
-instance PShow Char    where pShowPrec _ = char
-instance PShow ()      where pShowPrec _ _ = "()"
+instance PShow Int     where pShow = fromString . show
+instance PShow Integer where pShow = fromString . show
+instance PShow Double  where pShow = fromString . show
+instance PShow Char    where pShow = fromString . show
+instance PShow ()      where pShow _ = "()"
 
 ---------------------------------------------------------------------------------
 -- TODO: remove
@@ -118,7 +94,7 @@ data FixityDir = Infix | InfixL | InfixR
 data Fixity = Fixity !FixityDir !Int
     deriving (Eq, Show)
 
--------------------------------------------------------------------------------- pretty print
+-------------------------------------------------------------------------------- doc data type
 
 data NDoc
     = DAtom String
@@ -128,15 +104,40 @@ data NDoc
     | DVar Int
     | DFreshName Bool{-False: dummy-} NDoc
     | DUp Int NDoc
-    | DColor Color NDoc
+    | DDoc (DocOp NDoc) --Color Color NDoc
     -- add wl-pprint combinators as necessary here
     deriving (Eq)
 
+data DocOp a
+    = DOColor Color a
+    | DOHSep a a
+    | DOHCat a a
+    | DOSoftSep a a
+    | DOVCat a a
+    | DONest Int a
+    | DOTupled [a]
+    deriving (Eq, Functor, Foldable, Traversable)
+
+pattern DColor c a = DDoc (DOColor c a)
+
+a <+> b = DDoc $ DOHSep a b
+a </> b = DDoc $ DOSoftSep a b
+a <$$> b = DDoc $ DOVCat a b
+nest n = DDoc . DONest n
+tupled = DDoc . DOTupled
+
+instance Monoid NDoc where
+    mempty = fromString ""
+    a `mappend` b = DDoc $ DOHCat a b
+
 pattern DParen x = DPar "(" x ")"
 pattern DBrace x = DPar "{" x "}"
 pattern DArr x y = DOp (Fixity InfixR (-1)) x "->" y
 pattern DAnn x y = DOp (Fixity InfixR (-3)) x ":" y
 
+braces = DBrace
+parens = DParen
+
 data Color = Green | Blue | Underlined
     deriving (Eq)
 
@@ -148,7 +149,7 @@ strip = \case
     DColor _ x     -> strip x
     DUp _ x        -> strip x
     DFreshName _ x -> strip x
-    x -> x
+    x              -> x
 
 simple x = case strip x of
     DAtom{} -> True
@@ -156,12 +157,12 @@ simple x = case strip x of
     DPar{} -> True
     _ -> False
 
-renderDocX :: NDoc -> Doc
+renderDocX :: NDoc -> P.Doc
 renderDocX = render . addPar (-10) . flip runReader [] . flip evalStateT (flip (:) <$> iterate ('\'':) "" <*> ['a'..'z']) . showVars
   where
     showVars x = case x of
         DAtom s -> pure x
-        DColor c x -> DColor c <$> showVars x
+        DDoc d -> DDoc <$> traverse showVars d
         DPar l x r -> DPar l <$> showVars x <*> pure r
         DOp pr x s y -> DOp pr <$> showVars x <*> pure s <*> showVars y
         DVar i -> asks $ DAtom . lookupVarName i
@@ -180,6 +181,7 @@ renderDocX = render . addPar (-10) . flip runReader [] . flip evalStateT (flip (
         DPar l x r -> DPar l (addPar (-20) x) r
         DOp pr' x s y -> paren $ DOp pr' (addPar (precL pr') x) s (addPar (precR pr') y)
         DLam lam vs arr e -> paren $ DLam lam (addPar 10 <$> vs) arr (addPar (-10) e)
+        DDoc d -> DDoc $ addPar (-10) <$> d
       where
         paren d
             | protect x = DParen d
@@ -199,46 +201,57 @@ renderDocX = render . addPar (-10) . flip runReader [] . flip evalStateT (flip (
         precR (Fixity InfixR i) = i
 
     render x = case x of
-        DColor c x -> colorFun c $ render x
-        DAtom s -> text s
-        DPar l x r -> text l <> render x <> text r
+        DDoc d -> case render <$> d of
+            DOColor c x -> colorFun c x
+            DOHSep a b  -> a P.<+> b
+            DOHCat a b  -> a <> b
+            DOSoftSep a b -> a P.</> b
+            DOVCat a b  -> a P.<$$> b
+            DONest n a  -> P.nest n a
+            DOTupled a  -> P.tupled a
+        DAtom s -> P.text s
+        DPar l x r -> P.text l <> render x <> P.text r
         DOp _ x s y -> case s of
-            "" -> render x <+> render y
-            _ | simple x && simple y && s /= "," -> render x <> text s <> render y
-              | otherwise -> (render x <++> s) <+> render y
-        DLam lam vs arr e -> text lam <> hsep (render <$> vs) <+> text arr <+> render e
+            ""  -> render x P.<> render y
+            " " -> render x P.<+> render y
+            _ | simple x && simple y && s /= "," -> render x <> P.text s <> render y
+              | otherwise -> (render x <++> s) P.<+> render y
+        DLam lam vs arr e -> P.text lam <> P.hsep (render <$> vs) P.<+> P.text arr P.<+> render e
       where
-        x <++> "," = x <> text ","
-        x <++> s = x <+> text s
+        x <++> "," = x <> P.text ","
+        x <++> s = x P.<+> P.text s
 
         colorFun = \case
-            Green -> dullgreen
-            Blue -> dullblue
-            Underlined -> underline
+            Green       -> P.dullgreen
+            Blue        -> P.dullblue
+            Underlined  -> P.underline
         
-showDoc :: NDoc -> String
-showDoc = show . renderDocX
+instance Show NDoc where
+    show = show . renderDocX
 
-showDoc_ :: NDoc -> Doc
+showDoc_ :: NDoc -> P.Doc
 showDoc_ = renderDocX
 
 shVar = DVar
 
-shLet i a b = shLam' (cpar . shLet' (inBlue' $ shVar i) $ DUp i a) (DUp i b)
-shLet_ a b = DFreshName True $ shLam' (cpar . shLet' (shVar 0) $ DUp 0 a) b
+shLet i a b = shLam' (shLet' (inBlue' $ shVar i) $ DUp i a) (DUp i b)
+shLet_ a b = DFreshName True $ shLam' (shLet' (shVar 0) $ DUp 0 a) b
 
 -----------------------------------------
 
+instance IsString NDoc where
+    fromString = DAtom
+
 shAtom = DAtom
 
-shTuple [] = DAtom "()"
+shTuple [] = "()"
 shTuple [x] = DParen $ DParen x
 shTuple xs = DParen $ foldr1 (\x y -> DOp (Fixity InfixR (-20)) x "," y) xs
 
-shAnn _ True x y | strip y == DAtom "Type" = x
+shAnn _ True x y | strip y == "Type" = x
 shAnn s _ x y = DOp (Fixity InfixR (-3)) x s y
 
-shApp _ x y = DOp (Fixity InfixL 10) x "" y
+pattern DApp x y = DOp (Fixity InfixL 10) x " " y
 
 shArr = DArr
 
@@ -252,7 +265,4 @@ getFN a = (0, a)
 shLam' x (getFN -> (i, DLam "\\" xs "->" y)) = iterateN i (DFreshName True) $ DLam "\\" (iterateN i (DUp 0) x: xs) "->" y
 shLam' x y = DLam "\\" [x] "->" y
 
-cpar s | simple s = s
-cpar s = DParen s
-
 
diff --git a/testdata/language-features/basic-values/case05.out b/testdata/language-features/basic-values/case05.out
index 85e6bced..f4f03c51 100644
--- a/testdata/language-features/basic-values/case05.out
+++ b/testdata/language-features/basic-values/case05.out
@@ -11,5 +11,5 @@ Uncovered pattern(s) at testdata/language-features/basic-values/case05.lc:1:16:
 value x = case x of
                ^
 Missing case(s):
-  _ | False <- == (fromInt 1) a_
+  _ | False <- fromInt 1 == a_
 
diff --git a/testdata/language-features/basic-values/def03.out b/testdata/language-features/basic-values/def03.out
index ba33b297..3161d04a 100644
--- a/testdata/language-features/basic-values/def03.out
+++ b/testdata/language-features/basic-values/def03.out
@@ -11,5 +11,5 @@ Uncovered pattern(s) at testdata/language-features/basic-values/def03.lc:1:1:
 fun 1 = '1'
 fun 2 = '2'
 Missing case(s):
-  _ | False <- == (fromInt 1) a_, False <- == (fromInt 2) a_
+  _ | False <- fromInt 1 == a_, False <- fromInt 2 == a_
 
diff --git a/testdata/language-features/basic-values/def07.reject.out b/testdata/language-features/basic-values/def07.reject.out
index 0ce641f7..e54d61ca 100644
--- a/testdata/language-features/basic-values/def07.reject.out
+++ b/testdata/language-features/basic-values/def07.reject.out
@@ -28,11 +28,11 @@ Uncovered pattern(s) at testdata/language-features/basic-values/def07.reject.lc:
 fun 1 = '1'
 fun 2 = '2'
 Missing case(s):
-  _ | False <- == (fromInt 1) a_, False <- == (fromInt 2) a_
+  _ | False <- fromInt 1 == a_, False <- fromInt 2 == a_
 
 Uncovered pattern(s) at testdata/language-features/basic-values/def07.reject.lc:3:1:
 fun2 1 _ = '1'
 ^^^^
 Missing case(s):
-  _ _ | False <- == (fromInt 1) b_
+  _ _ | False <- fromInt 1 == b_