@@ -0,0 +1,191 @@
1+{-# OPTIONS_GHC -Wall #-}
2+
3+{-| The Abstract Syntax Tree (AST) for expressions comes in a couple formats.
4+The first is the fully general version and is labeled with a prime (Expr').
5+The others are specialized versions of the AST that represent specific phases
6+of the compilation process. I expect there to be more phases as we begin to
7+enrich the AST with more information.
8+-}
9+module AST.Expression.General where
10+
11+import SourceSyntax.PrettyPrint
12+import Text.PrettyPrint as P
13+import AST.Type (Type)
14+import qualified AST.Variable as Var
15+import qualified SourceSyntax.Helpers as Help
16+import qualified SourceSyntax.Annotation as Annotation
17+import qualified SourceSyntax.Pattern as Pattern
18+import qualified SourceSyntax.Literal as Literal
19+
20+---- GENERAL AST ----
21+
22+{-| This is a fully general Abstract Syntax Tree (AST) for expressions. It has
23+"type holes" that allow us to enrich the AST with additional information as we
24+move through the compilation process. The type holes are used to represent:
25+
26+ ann: Annotations for arbitrary expressions. Allows you to add information
27+ to the AST like position in source code or inferred types.
28+
29+ def: Definition style. The source syntax separates type annotations and
30+ definitions, but after parsing we check that they are well formed and
31+ collapse them.
32+
33+ var: Representation of variables. Starts as strings, but is later enriched
34+ with information about what module a variable came from.
35+
36+-}
37+type Expr annotation definition variable =
38+ Annotation.Annotated annotation (Expr' annotation definition variable)
39+
40+data Expr' ann def var
41+ = Literal Literal.Literal
42+ | Var var
43+ | Range (Expr ann def var) (Expr ann def var)
44+ | ExplicitList [Expr ann def var]
45+ | Binop var (Expr ann def var) (Expr ann def var)
46+ | Lambda (Pattern.Pattern var) (Expr ann def var)
47+ | App (Expr ann def var) (Expr ann def var)
48+ | MultiIf [(Expr ann def var,Expr ann def var)]
49+ | Let [def] (Expr ann def var)
50+ | Case (Expr ann def var) [(Pattern.Pattern var, Expr ann def var)]
51+ | Data String [Expr ann def var]
52+ | Access (Expr ann def var) String
53+ | Remove (Expr ann def var) String
54+ | Insert (Expr ann def var) String (Expr ann def var)
55+ | Modify (Expr ann def var) [(String, Expr ann def var)]
56+ | Record [(String, Expr ann def var)]
57+ | Markdown String String [Expr ann def var]
58+ -- for type checking and code gen only
59+ | PortIn String (Type var)
60+ | PortOut String (Type var) (Expr ann def var)
61+ deriving (Show)
62+
63+
64+---- UTILITIES ----
65+
66+rawVar :: String -> Expr' ann def Var.Raw
67+rawVar x = Var (Var.Raw x)
68+
69+localVar :: String -> Expr' ann def Var.Canonical
70+localVar x = Var (Var.Canonical Var.Local x)
71+
72+tuple :: [Expr ann def var] -> Expr' ann def var
73+tuple es = Data ("_Tuple" ++ show (length es)) es
74+
75+delist :: Expr ann def var -> [Expr ann def var]
76+delist (Annotation.A _ (Data "::" [h,t])) = h : delist t
77+delist _ = []
78+
79+saveEnvName :: String
80+saveEnvName = "_save_the_environment!!!"
81+
82+dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical
83+dummyLet defs =
84+ Annotation.none $ Let defs (Annotation.none $ localVar saveEnvName)
85+
86+instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var) where
87+ pretty expr =
88+ case expr of
89+ Literal lit -> pretty lit
90+
91+ Var x -> pretty x
92+
93+ Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
94+
95+ ExplicitList es -> P.brackets (commaCat (map pretty es))
96+
97+ Binop op (Annotation.A _ (Literal (Literal.IntNum 0))) e
98+ | Var.toString op == "-" ->
99+ P.text "-" <> prettyParens e
100+
101+ Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op'', prettyParens e2 ]
102+ where
103+ op' = Var.toString op
104+ op'' = if Help.isOp op' then op' else "`" ++ op' ++ "`"
105+
106+ Lambda p e -> P.text "\\" <> args <+> P.text "->" <+> pretty body
107+ where
108+ (ps,body) = collectLambdas (Annotation.A undefined $ Lambda p e)
109+ args = P.sep (map Pattern.prettyParens ps)
110+
111+ App _ _ -> P.hang func 2 (P.sep args)
112+ where
113+ func:args = map prettyParens (collectApps (Annotation.A undefined expr))
114+
115+ MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
116+ where
117+ iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
118+
119+ Let defs e ->
120+ P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
121+ , P.text "in" <+> pretty e ]
122+
123+ Case e pats ->
124+ P.hang pexpr 2 (P.vcat (map pretty' pats))
125+ where
126+ pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
127+ pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
128+
129+ Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
130+ Data "[]" [] -> P.text "[]"
131+ Data name es
132+ | Help.isTuple name -> P.parens (commaCat (map pretty es))
133+ | otherwise -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
134+
135+ Access e x -> prettyParens e <> P.text "." <> variable x
136+
137+ Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
138+
139+ Insert (Annotation.A _ (Remove e y)) x v ->
140+ P.braces $ P.hsep [ pretty e, P.text "-", variable y, P.text "|"
141+ , variable x, P.equals, pretty v ]
142+
143+ Insert e x v ->
144+ P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
145+
146+ Modify e fs ->
147+ P.braces $ P.hang (pretty e <+> P.text "|")
148+ 4
149+ (commaSep $ map field fs)
150+ where
151+ field (k,v) = variable k <+> P.text "<-" <+> pretty v
152+
153+ Record fs ->
154+ P.braces $ P.nest 2 (commaSep $ map field fs)
155+ where
156+ field (x,e) = variable x <+> P.equals <+> pretty e
157+
158+ Markdown _ _ _ -> P.text "[markdown| ... |]"
159+
160+ PortIn name _ -> P.text $ "<port:" ++ name ++ ">"
161+
162+ PortOut _ _ signal -> pretty signal
163+
164+collectApps :: Expr ann def var -> [Expr ann def var]
165+collectApps annExpr@(Annotation.A _ expr) =
166+ case expr of
167+ App a b -> collectApps a ++ [b]
168+ _ -> [annExpr]
169+
170+collectLambdas :: Expr ann def var -> ([Pattern.Pattern var], Expr ann def var)
171+collectLambdas lexpr@(Annotation.A _ expr) =
172+ case expr of
173+ Lambda pattern body ->
174+ let (ps, body') = collectLambdas body
175+ in (pattern : ps, body')
176+
177+ _ -> ([], lexpr)
178+
179+prettyParens :: (Pretty def, Pretty var, Var.ToString var) => Expr ann def var -> Doc
180+prettyParens (Annotation.A _ expr) = parensIf needed (pretty expr)
181+ where
182+ needed =
183+ case expr of
184+ Binop _ _ _ -> True
185+ Lambda _ _ -> True
186+ App _ _ -> True
187+ MultiIf _ -> True
188+ Let _ _ -> True
189+ Case _ _ -> True
190+ Data name (_:_) -> name /= "::"
191+ _ -> False