Use Pretty for errors and expressions

5 files changed, 71 insertions, 27 deletions

diff --git a/ast/CC/Source.hs b/ast/CC/Source.hs
index 80d8f01..81e691b 100644
--- a/ast/CC/Source.hs
+++ b/ast/CC/Source.hs
@@ -26,21 +26,9 @@ data Expr = Call SourceRange Expr Expr
   deriving (Show, Read)
 
 instance Pretty Type where
-    pretty = unparse
-
-class Unparse a where
-    -- Parentheses are required if precedence of unparsed element is
-    -- greater than the argument.
-    unparsePrec :: Int -> a -> String
-
-    unparse :: a -> String
-    unparse = unparsePrec 0
-
-instance Unparse Type where
-    unparsePrec _ TInt = "Int"
-    unparsePrec p (TFun a b) =
-        let s = unparsePrec 3 a ++ " -> " ++ unparsePrec 2 b
-        in if p > 2 then "(" ++ s ++ ")" else s
+    prettyPrec _ TInt = "Int"
+    prettyPrec p (TFun a b) =
+        precParens p 2 (prettyPrec 3 a ++ " -> " ++ prettyPrec 2 b)
 
 instance HasRange Expr where
     range (Call sr _ _) = sr
diff --git a/ast/CC/Typed.hs b/ast/CC/Typed.hs
index b11067f..5b8ed38 100644
--- a/ast/CC/Typed.hs
+++ b/ast/CC/Typed.hs
@@ -3,6 +3,7 @@ module CC.Typed(
     module CC.Types
 ) where
 
+import CC.Pretty
 import CC.Types
 
 
@@ -33,3 +34,31 @@ exprType :: ExprT -> TypeT
 exprType (CallT typ _ _) = typ
 exprType (IntT _) = TIntT
 exprType (VarT (Occ _ typ)) = typ
+
+instance Pretty TypeT where
+    prettyPrec _ TIntT = "Int"
+    prettyPrec p (TFunT a b) =
+        precParens p 2 (prettyPrec 3 a ++ " -> " ++ prettyPrec 2 b)
+    prettyPrec _ (TyVar i) = 't' : show i
+
+instance Pretty ExprT where
+    prettyPrec p (LamT ty (Occ n t) e) =
+        precParens p 2 $
+            "(\\(" ++ n ++ " :: " ++ pretty t ++ ") -> "
+                ++ prettyPrec 2 e ++ ") :: " ++ pretty ty
+    prettyPrec p (CallT ty e1 e2) =
+        precParens p 2 $
+            prettyPrec 3 e1 ++ " " ++ prettyPrec 3 e2 ++ " :: " ++ pretty ty
+    prettyPrec _ (IntT i) = show i
+    prettyPrec p (VarT (Occ n t)) =
+        precParens p 2 $
+            show n ++ " :: " ++ pretty t
+
+instance Pretty DefT where
+    pretty (FunctionT n e) = n ++ " = " ++ pretty e
+
+instance Pretty DeclT where
+    pretty (DefT def) = pretty def
+
+instance Pretty ProgramT where
+    pretty (ProgramT decls) = concatMap ((++ "\n") . pretty) decls
diff --git a/main/Main.hs b/main/Main.hs
index 58e475c..3216833 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -4,6 +4,8 @@ import System.Exit
 
 import qualified CC.Parser
 import qualified CC.Typecheck
+
+import CC.Pretty
 import CC.Types
 
 
@@ -13,10 +15,10 @@ import CC.Types
 
 type Pass a b = Context -> a -> Either String b
 
-pass :: (Read a, Show b, Show e) => (Context -> a -> Either e b) -> Pass a b
-pass f ctx a = either (Left . show) Right (f ctx a)
+pass :: (Read a, Show b, Pretty e) => (Context -> a -> Either e b) -> Pass a b
+pass f ctx a = either (Left . pretty) Right (f ctx a)
 
-passJoin :: (Read a, Show b, Read b, Show c) => Pass a b -> Pass b c -> Pass a c
+passJoin :: (Read a, Show c) => Pass a b -> Pass b c -> Pass a c
 passJoin f1 f2 ctx a = f1 ctx a >>= f2 ctx
 
 main :: IO ()
@@ -29,5 +31,5 @@ main = do
     source <- getContents
     let context = Context "<stdin>"
     case combined context (read source) of
-        Right prog -> print prog
-        Left err -> die (show err)
+        Right prog -> pprint prog
+        Left err -> die err
diff --git a/parser/CC/Parser.hs b/parser/CC/Parser.hs
index 0088956..d6c2239 100644
--- a/parser/CC/Parser.hs
+++ b/parser/CC/Parser.hs
@@ -1,20 +1,22 @@
 module CC.Parser(runPass, parseProgram) where
 
 import Control.Monad
-import Text.Parsec hiding (State, SourcePos, getPosition, token)
+import Text.Parsec hiding (SourcePos, getPosition, token)
 import qualified Text.Parsec
 
+import CC.Pretty
 import CC.Source
 
 
-type Parser a = Parsec String State a
-type State = Int  -- base indentation level; hanging lines should be > this
+type Parser a = Parsec String () a
 
-runPass :: Context -> RawString -> Either ParseError Program
-runPass (Context path) (RawString src) = parseProgram path src
+runPass :: Context -> RawString -> Either (PrettyShow ParseError) Program
+runPass (Context path) (RawString src) = fmapLeft PrettyShow (parseProgram path src)
+  where fmapLeft f (Left x) = Left (f x)
+        fmapLeft _ (Right x) = Right x
 
 parseProgram :: FilePath -> String -> Either ParseError Program
-parseProgram fname src = runParser pProgram 0 fname src
+parseProgram fname src = parse pProgram fname src
 
 pProgram :: Parser Program
 pProgram = do
@@ -30,7 +32,6 @@ pDef :: Parser Def
 pDef = do
     func <- try $ do
         emptyLines
-        putState 0
         name <- pName0 <?> "declaration head name"
         return name
     mtyp <- optionMaybe $ do
diff --git a/utils/CC/Pretty.hs b/utils/CC/Pretty.hs
index 0a41abe..ccb886a 100644
--- a/utils/CC/Pretty.hs
+++ b/utils/CC/Pretty.hs
@@ -2,8 +2,32 @@ module CC.Pretty where
 
 
 class Pretty a where
+    {-# MINIMAL pretty | prettyPrec #-}
     pretty :: a -> String
+    pretty = prettyPrec (-1)
 
+    -- | Higher precedence binds tighter.
+    -- Parentheses are required if the printed element has lower precedence
+    -- than the Int argument.
+    prettyPrec :: Int -> a -> String
+    prettyPrec _ = pretty
 
 instance Pretty Int where
     pretty = show
+
+
+-- Useful if you want the Pretty instance to be equal to the Show instance.
+newtype PrettyShow a = PrettyShow a
+  deriving (Show)
+
+instance Show a => Pretty (PrettyShow a) where
+    pretty (PrettyShow x) = show x
+
+
+pprint :: Pretty a => a -> IO ()
+pprint = putStrLn . pretty
+
+precParens :: Int -> Int -> String -> String
+precParens environ self s
+    | self < environ = "(" ++ s ++ ")"
+    | otherwise = s