@@ -4,6 +4,8 @@ module SourceSyntax.Expression where
44import Data.Data
55import Data.List (intercalate)
66import qualified Text.Pandoc as Pandoc
7+import SourceSyntax.PrettyPrint
8+import Text.PrettyPrint as PP
79import qualified SourceSyntax.Helpers as Help
810import qualified SourceSyntax.Location as Location
911import qualified SourceSyntax.Pattern as Pattern
@@ -29,70 +31,94 @@ data Expr t v
2931 | Modify (LExpr t v) [(String, LExpr t v)]
3032 | Record [(String, LExpr t v)]
3133 | Markdown Pandoc.Pandoc
32− deriving (Eq, Data, Typeable)
34+ deriving (Eq, Data, Typeable, Show)
3335
3436data Def tipe var
3537 = Def Pattern.Pattern (LExpr tipe var)
3638 | TypeAnnotation String Type
37− deriving (Eq, Data, Typeable)
39+ deriving (Eq, Data, Typeable, Show)
3840
3941tuple es = Data ("Tuple" ++ show (length es)) es
4042
4143delist (Location.L _ _ (Data "::" [h,t])) = h : delist t
4244delist _ = []
4345
44−
45−instance Show (Expr t v) where
46− show e =
47− let show' (Location.L _ _ e) = Help.parensIf (needsParens e) (show e) in
48− case e of
49− Literal lit -> show lit
50− Range e1 e2 -> "[" ++ show e1 ++ ".." ++ show e2 ++ "]"
51− ExplicitList es -> "[" ++ intercalate "," (map show es) ++ "]"
52− Binop op e1 e2 -> show' e1 ++ " " ++ op ++ " " ++ show' e2
53− Lambda x e -> let (xs,e') = getLambdas (Location.none $ Lambda x e) in
54− concat [ "\\", intercalate " " xs, " -> ", show e' ]
55− App e1 e2 -> show' e1 ++ " " ++ show' e2
56− MultiIf (p:ps) -> concat [ "if | ", iff p, sep (map iff ps) ]
57− where iff (b,e) = show b ++ " -> " ++ show e
58− sep = concatMap ("\n | " ++)
59− Let defs e -> "let { "++intercalate " ; " (map show defs)++" } in "++show e
60− Var (c:cs) -> if Help.isOp c then Help.parens (c:cs) else c:cs
61− Case e pats -> "case "++ show e ++" of " ++ Help.brkt (intercalate " ; " pats')
62− where pats' = map (\(p,e) -> show p ++ " -> " ++ show e) pats
63− Data "::" [h,t] -> show h ++ " :: " ++ show t
64− Data "[]" [] -> "[]"
65− Data name es -> name ++ " " ++ intercalate " " (map show' es)
66− Access e x -> show' e ++ "." ++ x
67− Remove e x -> Help.brkt (show e ++ " - " ++ x)
46+instance Pretty (Expr t v) where
47+ pretty expr =
48+ case expr of
49+ Literal lit -> pretty lit
50+ Var x@(c:_) -> parensIf (Help.isOp c) (PP.text x)
51+ Range e1 e2 -> PP.brackets (pretty e1 <> PP.text ".." <> pretty e2)
52+ ExplicitList es -> PP.brackets (commaCat (map pretty es))
53+ Binop op e1 e2 -> PP.sep [ prettyParens e1 <+> PP.text op, prettyParens e2 ]
54+ Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)
55+ in PP.text "\\" <> PP.sep ps <+> PP.text "->" <+> pretty body
56+ App _ _ -> PP.hang func 2 (PP.sep args)
57+ where func:args = map prettyParens (collectApps (Location.none expr))
58+ MultiIf branches -> PP.text "if" $$ nest 3 (vcat $ map iff branches)
59+ where
60+ iff (b,e) = PP.text "|" <+> PP.hang (pretty b <+> PP.text "->") 2 (pretty e)
61+ Let defs e ->
62+ PP.sep [ PP.hang (PP.text "let") 4 (PP.vcat (map pretty defs))
63+ , PP.text "in" <+> pretty e ]
64+ Case e pats ->
65+ PP.hang pexpr 2 (PP.vcat (map pretty' pats))
66+ where
67+ pexpr = PP.sep [ PP.text "case" <+> pretty e, PP.text "of" ]
68+ pretty' (p,e) = pretty p <+> PP.text "->" <+> pretty e
69+ Data "::" [hd,tl] -> pretty hd <+> PP.text "::" <+> pretty tl
70+ Data "[]" [] -> PP.text "[]"
71+ Data name es -> PP.hang (PP.text name) 2 (PP.sep (map prettyParens es))
72+ Access e x -> prettyParens e <> PP.text "." <> PP.text x
73+ Remove e x -> PP.braces (pretty e <+> PP.text "-" <+> PP.text x)
6874 Insert (Location.L _ _ (Remove e y)) x v ->
69− Help.brkt (show e ++ " - " ++ y ++ " | " ++ x ++ " = " ++ show v)
70− Insert e x v -> Help.brkt (show e ++ " | " ++ x ++ " = " ++ show v)
71− Modify e fs -> Help.brkt (show e ++" | "++ intercalate ", " (map field fs))
72− where field (x,e) = x ++ " <- " ++ show e
73− Record r -> Help.brkt (intercalate ", " (map fields r))
74− where fields (f,e) = f ++ " = " ++ show e
75− Markdown _ -> "[markdown| ... |]"
75+ PP.braces (pretty e <+> PP.text "-" <+> PP.text y <+> PP.text "|" <+> PP.text x <+> PP.text "=" <+> pretty v)
76+ Insert e x v ->
77+ PP.braces (pretty e <+> PP.text "|" <+> PP.text x <+> PP.text "=" <+> pretty v)
78+
79+ Modify e fs ->
80+ PP.braces $ PP.hang (pretty e <+> PP.text "|")
81+ 4
82+ (PP.sep . PP.punctuate PP.comma $ map field fs)
83+ where
84+ field (x,e) = PP.text x <+> PP.text "<-" <+> pretty e
85+
86+ Record fs ->
87+ PP.braces $ PP.nest 2 (PP.sep . PP.punctuate PP.comma $ map field fs)
88+ where
89+ field (x,e) = PP.text x <+> PP.text "=" <+> pretty e
90+
91+ Markdown _ -> PP.text "[markdown| ... |]"
7692
93+instance Pretty (Def t v) where
94+ pretty def =
95+ case def of
96+ TypeAnnotation name tipe ->
97+ PP.text name <+> PP.text ":" <+> PP.text (show tipe)
98+ Def pattern expr ->
99+ pretty pattern <+> PP.text "=" <+> pretty expr
77100
78−instance Show (Def t v) where
79− show e =
80− case e of
81− TypeAnnotation n t -> n ++ " : " ++ show t
82− Def pattern e ->
83− show pattern ++ " = " ++ show e
101+collectApps lexpr@(Location.L _ _ expr) =
102+ case expr of
103+ App a b -> collectApps a ++ [b]
104+ _ -> [lexpr]
84105
85−getLambdas (Location.L _ _ (Lambda x e)) = (show x:xs,e')
86− where (xs,e') = getLambdas e
87−getLambdas e = ([],e)
106+collectLambdas lexpr@(Location.L _ _ expr) =
107+ case expr of
108+ Lambda pattern body ->
109+ let (ps, body') = collectLambdas body
110+ in (pretty pattern : ps, body')
111+ _ -> ([], lexpr)
88112
89−needsParens e =
90− case e of
91− Binop _ _ _ -> True
92− Lambda _ _ -> True
93− App _ _ -> True
94− MultiIf _ -> True
95− Let _ _ -> True
96− Case _ _ -> True
97− Data name (x:xs) -> name /= "::"
98− _ -> False
113+prettyParens (Location.L _ _ expr) = parensIf needed (pretty expr)
114+ where
115+ needed =
116+ case expr of
117+ Binop _ _ _ -> True
118+ Lambda _ _ -> True
119+ App _ _ -> True
120+ MultiIf _ -> True
121+ Let _ _ -> True
122+ Case _ _ -> True
123+ Data name (x:xs) -> name /= "::"
124+ _ -> False