git.iko.soy/elk
on 329077f help sign in
elk/compiler/SourceSyntax/Expression.hs
178 lines 6.4 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
12{-| This is a located expression. -}
13type LExpr' def = Location.Located (Expr' def)
15{-| This is a fully general expression. The compilation process will enrich
16this data structure with additional information after the initial parse.
17The type holes let us reflect these structural changes in the types.
19 def: Parsing allows two kinds of definitions (type annotations or definitions),
20 but later checks will see that they are well formed and combine them.
22-}
23data Expr' def
24 = Literal Literal.Literal
25 | Var String
26 | Range (LExpr' def) (LExpr' def)
27 | ExplicitList [LExpr' def]
28 | Binop String (LExpr' def) (LExpr' def)
29 | Lambda Pattern.Pattern (LExpr' def)
30 | App (LExpr' def) (LExpr' def)
31 | MultiIf [(LExpr' def,LExpr' def)]
32 | Let [def] (LExpr' def)
33 | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
34 | Data String [LExpr' def]
35 | Access (LExpr' def) String
36 | Remove (LExpr' def) String
37 | Insert (LExpr' def) String (LExpr' def)
38 | Modify (LExpr' def) [(String, LExpr' def)]
39 | Record [(String, LExpr' def)]
40 | Markdown String String [LExpr' def]
41 -- for type checking and code gen only
42 | PortIn String SrcType.Type
43 | PortOut String SrcType.Type (LExpr' def)
45type ParseExpr = Expr' ParseDef
46type LParseExpr = LExpr' ParseDef
47type LExpr = LExpr' Def
48type Expr = Expr' Def
50{-| Style of definitions as they are parsed. Users specify them
51separately, and other checks will make sure they can be combined.
52-}
53data ParseDef
54 = Def Pattern.Pattern LParseExpr
55 | TypeAnnotation String SrcType.Type
56 deriving (Show)
58{-| After checking that type annotations and definitions are all
59valid, they can be combined.
60-}
61data Def = Definition Pattern.Pattern (LExpr' Def) (Maybe SrcType.Type)
62 deriving (Show)
64tuple :: [LExpr' def] -> Expr' def
65tuple es = Data ("_Tuple" ++ show (length es)) es
67delist :: LExpr' def -> [LExpr' def]
68delist (Location.L _ (Data "::" [h,t])) = h : delist t
69delist _ = []
71saveEnvName :: String
72saveEnvName = "_save_the_environment!!!"
74dummyLet :: Pretty def => [def] -> LExpr' def
75dummyLet defs =
76 Location.none $ Let defs (Location.none $ Var saveEnvName)
78instance Pretty def => Show (Expr' def) where
79 show = render . pretty
81instance Pretty def => Pretty (Expr' def) where
82 pretty expr =
83 case expr of
84 Literal lit -> pretty lit
85 Var x -> variable x
86 Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
87 ExplicitList es -> P.brackets (commaCat (map pretty es))
88 Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->
89 P.text "-" <> prettyParens e
90 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
91 where op' = if Help.isOp op then op else "`" ++ op ++ "`"
92 Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)
93 in P.text "\\" <> P.sep ps <+> P.text "->" <+> pretty body
94 App _ _ -> P.hang func 2 (P.sep args)
95 where func:args = map prettyParens (collectApps (Location.none expr))
96 MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
97 where
98 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
99 Let defs e ->
100 P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
101 , P.text "in" <+> pretty e ]
102 Case e pats ->
103 P.hang pexpr 2 (P.vcat (map pretty' pats))
104 where
105 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
106 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
107 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
108 Data "[]" [] -> P.text "[]"
109 Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
110 Access e x -> prettyParens e <> P.text "." <> variable x
111 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
112 Insert (Location.L _ (Remove e y)) x v ->
113 P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
114 Insert e x v ->
115 P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
117 Modify e fs ->
118 P.braces $ P.hang (pretty e <+> P.text "|")
119 4
120 (commaSep $ map field fs)
121 where
122 field (k,v) = variable k <+> P.text "<-" <+> pretty v
124 Record fs ->
125 P.braces $ P.nest 2 (commaSep $ map field fs)
126 where
127 field (x,e) = variable x <+> P.equals <+> pretty e
129 Markdown _ _ _ -> P.text "[markdown| ... |]"
131 PortIn name _ -> P.text $ "<port:" ++ name ++ ">"
133 PortOut _ _ signal -> pretty signal
135instance Pretty ParseDef where
136 pretty def =
137 case def of
138 TypeAnnotation name tipe ->
139 variable name <+> P.colon <+> pretty tipe
140 Def pattern expr ->
141 pretty pattern <+> P.equals <+> pretty expr
143instance Pretty Def where
144 pretty (Definition pattern expr maybeTipe) =
145 P.vcat [ annotation, definition ]
146 where
147 definition = pretty pattern <+> P.equals <+> pretty expr
148 annotation = case maybeTipe of
149 Nothing -> P.empty
150 Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
152collectApps :: LExpr' def -> [LExpr' def]
153collectApps lexpr@(Location.L _ expr) =
154 case expr of
155 App a b -> collectApps a ++ [b]
156 _ -> [lexpr]
158collectLambdas :: LExpr' def -> ([Doc], LExpr' def)
159collectLambdas lexpr@(Location.L _ expr) =
160 case expr of
161 Lambda pattern body ->
162 let (ps, body') = collectLambdas body
163 in (pretty pattern : ps, body')
164 _ -> ([], lexpr)
166prettyParens :: (Pretty def) => LExpr' def -> Doc
167prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
168 where
169 needed =
170 case expr of
171 Binop _ _ _ -> True
172 Lambda _ _ -> True
173 App _ _ -> True
174 MultiIf _ -> True
175 Let _ _ -> True
176 Case _ _ -> True
177 Data name (_:_) -> name /= "::"
178 _ -> False