git.iko.soy/elk
on d92ac79 help sign in
elk/compiler/SourceSyntax/Expression.hs
179 lines 6.5 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-}
24data Expr' def
25 = Literal Literal.Literal
26 | Var String
27 | Range (LExpr' def) (LExpr' def)
28 | ExplicitList [LExpr' def]
29 | Binop String (LExpr' def) (LExpr' def)
30 | Lambda Pattern.Pattern (LExpr' def)
31 | App (LExpr' def) (LExpr' def)
32 | MultiIf [(LExpr' def,LExpr' def)]
33 | Let [def] (LExpr' def)
34 | Case (LExpr' def) [(Pattern.Pattern, LExpr' def)]
35 | Data String [LExpr' def]
36 | Access (LExpr' def) String
37 | Remove (LExpr' def) String
38 | Insert (LExpr' def) String (LExpr' def)
39 | Modify (LExpr' def) [(String, LExpr' def)]
40 | Record [(String, LExpr' def)]
41 | Markdown String String [LExpr' def]
42 -- for type checking and code gen only
43 | PortIn String SrcType.Type Type.Variable (Maybe (LExpr' def))
44 | PortOut String SrcType.Type (LExpr' def)
46type ParseExpr = Expr' ParseDef
47type LParseExpr = LExpr' ParseDef
48type LExpr = LExpr' Def
49type Expr = Expr' Def
51{-| Style of definitions as they are parsed. Users specify them
52separately, and other checks will make sure they can be combined.
53-}
54data ParseDef
55 = Def Pattern.Pattern LParseExpr
56 | TypeAnnotation String SrcType.Type
57 deriving (Show)
59{-| After checking that type annotations and definitions are all
60valid, they can be combined.
61-}
62data Def = Definition Pattern.Pattern (LExpr' Def) (Maybe SrcType.Type)
63 deriving (Show)
65tuple :: [LExpr' def] -> Expr' def
66tuple es = Data ("_Tuple" ++ show (length es)) es
68delist :: LExpr' def -> [LExpr' def]
69delist (Location.L _ (Data "::" [h,t])) = h : delist t
70delist _ = []
72saveEnvName :: String
73saveEnvName = "_save_the_environment!!!"
75dummyLet :: Pretty def => [def] -> LExpr' def
76dummyLet defs =
77 Location.none $ Let defs (Location.none $ Var saveEnvName)
79instance Pretty def => Show (Expr' def) where
80 show = render . pretty
82instance Pretty def => Pretty (Expr' def) where
83 pretty expr =
84 case expr of
85 Literal lit -> pretty lit
86 Var x -> variable x
87 Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
88 ExplicitList es -> P.brackets (commaCat (map pretty es))
89 Binop "-" (Location.L _ (Literal (Literal.IntNum 0))) e ->
90 P.text "-" <> prettyParens e
91 Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op', prettyParens e2 ]
92 where op' = if Help.isOp op then op else "`" ++ op ++ "`"
93 Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)
94 in P.text "\\" <> P.sep ps <+> P.text "->" <+> pretty body
95 App _ _ -> P.hang func 2 (P.sep args)
96 where func:args = map prettyParens (collectApps (Location.none expr))
97 MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
98 where
99 iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
100 Let defs e ->
101 P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
102 , P.text "in" <+> pretty e ]
103 Case e pats ->
104 P.hang pexpr 2 (P.vcat (map pretty' pats))
105 where
106 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
107 pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b
108 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
109 Data "[]" [] -> P.text "[]"
110 Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
111 Access e x -> prettyParens e <> P.text "." <> variable x
112 Remove e x -> P.braces (pretty e <+> P.text "-" <+> variable x)
113 Insert (Location.L _ (Remove e y)) x v ->
114 P.braces (pretty e <+> P.text "-" <+> variable y <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
115 Insert e x v ->
116 P.braces (pretty e <+> P.text "|" <+> variable x <+> P.equals <+> pretty v)
118 Modify e fs ->
119 P.braces $ P.hang (pretty e <+> P.text "|")
120 4
121 (commaSep $ map field fs)
122 where
123 field (k,v) = variable k <+> P.text "<-" <+> pretty v
125 Record fs ->
126 P.braces $ P.nest 2 (commaSep $ map field fs)
127 where
128 field (x,e) = variable x <+> P.equals <+> pretty e
130 Markdown _ _ _ -> P.text "[markdown| ... |]"
132 PortIn _ _ _ _ -> P.text "<port in>"
134 PortOut _ _ signal -> pretty signal
136instance Pretty ParseDef where
137 pretty def =
138 case def of
139 TypeAnnotation name tipe ->
140 variable name <+> P.colon <+> pretty tipe
141 Def pattern expr ->
142 pretty pattern <+> P.equals <+> pretty expr
144instance Pretty Def where
145 pretty (Definition pattern expr maybeTipe) =
146 P.vcat [ annotation, definition ]
147 where
148 definition = pretty pattern <+> P.equals <+> pretty expr
149 annotation = case maybeTipe of
150 Nothing -> P.empty
151 Just tipe -> pretty pattern <+> P.colon <+> pretty tipe
153collectApps :: LExpr' def -> [LExpr' def]
154collectApps lexpr@(Location.L _ expr) =
155 case expr of
156 App a b -> collectApps a ++ [b]
157 _ -> [lexpr]
159collectLambdas :: LExpr' def -> ([Doc], LExpr' def)
160collectLambdas lexpr@(Location.L _ expr) =
161 case expr of
162 Lambda pattern body ->
163 let (ps, body') = collectLambdas body
164 in (pretty pattern : ps, body')
165 _ -> ([], lexpr)
167prettyParens :: (Pretty def) => LExpr' def -> Doc
168prettyParens (Location.L _ expr) = parensIf needed (pretty expr)
169 where
170 needed =
171 case expr of
172 Binop _ _ _ -> True
173 Lambda _ _ -> True
174 App _ _ -> True
175 MultiIf _ -> True
176 Let _ _ -> True
177 Case _ _ -> True
178 Data name (_:_) -> name /= "::"
179 _ -> False