git.iko.soy/elk
on 3e63279 help sign in
elk/compiler/SourceSyntax/Expression.hs
189 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)
52 | GLShader String String
54type ParseExpr = Expr' ParseDef
55type LParseExpr = LExpr' ParseDef
56type LExpr = LExpr' Def
57type Expr = Expr' Def
59{-| Style of definitions as they are parsed. Users specify them
60separately, and other checks will make sure they can be combined.
61-}
62data ParseDef
63 = Def Pattern.Pattern LParseExpr
64 | TypeAnnotation String SrcType.Type
65 deriving (Show)
67{-| After checking that type annotations and definitions are all
68valid, they can be combined.
69-}
70data Def = Definition Pattern.Pattern (LExpr' Def) (Maybe SrcType.Type)
71 deriving (Show)
73tuple :: [LExpr' def] -> Expr' def
74tuple es = Data ("_Tuple" ++ show (length es)) es
76delist :: LExpr' def -> [LExpr' def]
77delist (Location.L _ (Data "::" [h,t])) = h : delist t
78delist _ = []
80saveEnvName :: String
81saveEnvName = "_save_the_environment!!!"
83dummyLet :: Pretty def => [def] -> LExpr' def
84dummyLet defs =
85 Location.none $ Let defs (Location.none $ Var saveEnvName)
87instance Pretty def => Show (Expr' def) where
88 show = render . pretty
90instance Pretty def => Pretty (Expr' def) where
91 pretty expr =
92 case expr of
93 Literal lit -> pretty lit
94 Var x -> variable x
95 Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
96 ExplicitList es -> P.brackets (commaCat (map pretty es))
97 Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->
98 P.text "-" <> prettyParens e
99 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
100 where op' = if Help.isOp op then op else "`" ++ op ++ "`"
101 Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)
102 in P.text "\\" <> P.sep ps <+> P.text "->" <+> pretty body
103 App _ _ -> P.hang func 2 (P.sep args)
104 where func:args = map prettyParens (collectApps (Location.none expr))
105 MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
106 where
107 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
108 Let defs e ->
109 P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
110 , P.text "in" <+> pretty e ]
111 Case e pats ->
112 P.hang pexpr 2 (P.vcat (map pretty' pats))
113 where
114 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
115 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
116 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
117 Data "[]" [] -> P.text "[]"
118 Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
119 Access e x -> prettyParens e <> P.text "." <> variable x
120 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
121 Insert (Location.L _ (Remove e y)) x v ->
122 P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
123 Insert e x v ->
124 P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
126 Modify e fs ->
127 P.braces $ P.hang (pretty e <+> P.text "|")
128 4
129 (commaSep $ map field fs)
130 where
131 field (k,v) = variable k <+> P.text "<-" <+> pretty v
133 Record fs ->
134 P.braces $ P.nest 2 (commaSep $ map field fs)
135 where
136 field (x,e) = variable x <+> P.equals <+> pretty e
138 Markdown _ _ _ -> P.text "[markdown| ... |]"
140 GLShader _ _ -> P.text "[glShader| ... |]"
142 PortIn _ _ _ handler -> pretty handler
144 PortOut _ _ signal -> pretty signal
146instance Pretty ParseDef where
147 pretty def =
148 case def of
149 TypeAnnotation name tipe ->
150 variable name <+> P.colon <+> pretty tipe
151 Def pattern expr ->
152 pretty pattern <+> P.equals <+> pretty expr
154instance Pretty Def where
155 pretty (Definition pattern expr maybeTipe) =
156 P.vcat [ annotation, definition ]
157 where
158 definition = pretty pattern <+> P.equals <+> pretty expr
159 annotation = case maybeTipe of
160 Nothing -> P.empty
161 Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
163collectApps :: LExpr' def -> [LExpr' def]
164collectApps lexpr@(Location.L _ expr) =
165 case expr of
166 App a b -> collectApps a ++ [b]
167 _ -> [lexpr]
169collectLambdas :: LExpr' def -> ([Doc], LExpr' def)
170collectLambdas lexpr@(Location.L _ expr) =
171 case expr of
172 Lambda pattern body ->
173 let (ps, body') = collectLambdas body
174 in (pretty pattern : ps, body')
175 _ -> ([], lexpr)
177prettyParens :: (Pretty def) => LExpr' def -> Doc
178prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
179 where
180 needed =
181 case expr of
182 Binop _ _ _ -> True
183 Lambda _ _ -> True
184 App _ _ -> True
185 MultiIf _ -> True
186 Let _ _ -> True
187 Case _ _ -> True
188 Data name (_:_) -> name /= "::"
189 _ -> False