git.iko.soy/elk
on d1a85fe help sign in
elk/compiler/SourceSyntax/Expression.hs
186 lines 6.8 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module SourceSyntax.Expression where
4import SourceSyntax.PrettyPrint
5import Text.PrettyPrint as P
6import qualified SourceSyntax.Helpers as Help
7import qualified SourceSyntax.Location as Location
8import qualified SourceSyntax.Pattern as Pattern
9import qualified SourceSyntax.Type as SrcType
10import qualified SourceSyntax.Literal as Literal
11import qualified Type.Type as Type
13{-| This is a located expression. -}
14type LExpr' def = Location.Located (Expr' def)
16{-| This is a fully general expression. The compilation process will enrich
17this data structure with additional information after the initial parse.
18The type holes let us reflect these structural changes in the types.
20 def: Parsing allows two kinds of definitions (type annotations or definitions),
21 but later checks will see that they are well formed and combine them.
23 t: for adding type information, currently unused
25 v: for enriching variables with information like provenonce, currently unused
27Please don't get on my case to take the unused ones out. I have considered it.
28It's a huge pain to add and remove, it will get used eventually, and it's not
29hurting anything as it is.
30-}
31data Expr' def
32 = Literal Literal.Literal
33 | Var String
34 | Range (LExpr' def) (LExpr' def)
35 | ExplicitList [LExpr' def]
36 | Binop String (LExpr' def) (LExpr' def)
37 | Lambda Pattern.Pattern (LExpr' def)
38 | App (LExpr' def) (LExpr' def)
39 | MultiIf [(LExpr' def,LExpr' def)]
40 | Let [def] (LExpr' def)
41 | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
42 | Data String [LExpr' def]
43 | Access (LExpr' def) String
44 | Remove (LExpr' def) String
45 | Insert (LExpr' def) String (LExpr' def)
46 | Modify (LExpr' def) [(String, LExpr' def)]
47 | Record [(String, LExpr' def)]
48 | Markdown String String [LExpr' def]
49 -- for type checking and code gen only
50 | PortIn String SrcType.Type Type.Variable (LExpr' def)
51 | PortOut String SrcType.Type (LExpr' def)
53type ParseExpr = Expr' ParseDef
54type LParseExpr = LExpr' ParseDef
55type LExpr = LExpr' Def
56type Expr = Expr' Def
58{-| Style of definitions as they are parsed. Users specify them
59separately, and other checks will make sure they can be combined.
60-}
61data ParseDef
62 = Def Pattern.Pattern LParseExpr
63 | TypeAnnotation String SrcType.Type
64 deriving (Show)
66{-| After checking that type annotations and definitions are all
67valid, they can be combined.
68-}
69data Def = Definition Pattern.Pattern (LExpr' Def) (Maybe SrcType.Type)
70 deriving (Show)
72tuple :: [LExpr' def] -> Expr' def
73tuple es = Data ("_Tuple" ++ show (length es)) es
75delist :: LExpr' def -> [LExpr' def]
76delist (Location.L _ (Data "::" [h,t])) = h : delist t
77delist _ = []
79saveEnvName :: String
80saveEnvName = "_save_the_environment!!!"
82dummyLet :: Pretty def => [def] -> LExpr' def
83dummyLet defs =
84 Location.none $ Let defs (Location.none $ Var saveEnvName)
86instance Pretty def => Show (Expr' def) where
87 show = render . pretty
89instance Pretty def => Pretty (Expr' def) where
90 pretty expr =
91 case expr of
92 Literal lit -> pretty lit
93 Var x -> variable x
94 Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
95 ExplicitList es -> P.brackets (commaCat (map pretty es))
96 Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->
97 P.text "-" <> prettyParens e
98 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
99 where op' = if Help.isOp op then op else "`" ++ op ++ "`"
100 Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)
101 in P.text "\\" <> P.sep ps <+> P.text "->" <+> pretty body
102 App _ _ -> P.hang func 2 (P.sep args)
103 where func:args = map prettyParens (collectApps (Location.none expr))
104 MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
105 where
106 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
107 Let defs e ->
108 P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
109 , P.text "in" <+> pretty e ]
110 Case e pats ->
111 P.hang pexpr 2 (P.vcat (map pretty' pats))
112 where
113 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
114 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
115 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
116 Data "[]" [] -> P.text "[]"
117 Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
118 Access e x -> prettyParens e <> P.text "." <> variable x
119 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
120 Insert (Location.L _ (Remove e y)) x v ->
121 P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
122 Insert e x v ->
123 P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
125 Modify e fs ->
126 P.braces $ P.hang (pretty e <+> P.text "|")
127 4
128 (commaSep $ map field fs)
129 where
130 field (k,v) = variable k <+> P.text "<-" <+> pretty v
132 Record fs ->
133 P.braces $ P.nest 2 (commaSep $ map field fs)
134 where
135 field (x,e) = variable x <+> P.equals <+> pretty e
137 Markdown _ _ _ -> P.text "[markdown| ... |]"
139 PortIn _ _ _ handler -> pretty handler
141 PortOut _ _ signal -> pretty signal
143instance Pretty ParseDef where
144 pretty def =
145 case def of
146 TypeAnnotation name tipe ->
147 variable name <+> P.colon <+> pretty tipe
148 Def pattern expr ->
149 pretty pattern <+> P.equals <+> pretty expr
151instance Pretty Def where
152 pretty (Definition pattern expr maybeTipe) =
153 P.vcat [ annotation, definition ]
154 where
155 definition = pretty pattern <+> P.equals <+> pretty expr
156 annotation = case maybeTipe of
157 Nothing -> P.empty
158 Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
160collectApps :: LExpr' def -> [LExpr' def]
161collectApps lexpr@(Location.L _ expr) =
162 case expr of
163 App a b -> collectApps a ++ [b]
164 _ -> [lexpr]
166collectLambdas :: LExpr' def -> ([Doc], LExpr' def)
167collectLambdas lexpr@(Location.L _ expr) =
168 case expr of
169 Lambda pattern body ->
170 let (ps, body') = collectLambdas body
171 in (pretty pattern : ps, body')
172 _ -> ([], lexpr)
174prettyParens :: (Pretty def) => LExpr' def -> Doc
175prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
176 where
177 needed =
178 case expr of
179 Binop _ _ _ -> True
180 Lambda _ _ -> True
181 App _ _ -> True
182 MultiIf _ -> True
183 Let _ _ -> True
184 Case _ _ -> True
185 Data name (_:_) -> name /= "::"
186 _ -> False