diff options
| -rw-r--r-- | ast/CC/Source.hs | 18 | ||||
| -rw-r--r-- | ast/CC/Typed.hs | 29 | ||||
| -rw-r--r-- | main/Main.hs | 12 | ||||
| -rw-r--r-- | parser/CC/Parser.hs | 15 | ||||
| -rw-r--r-- | utils/CC/Pretty.hs | 24 |
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 |