git.iko.soy/elk
on 501c607 help sign in
elk/src/AST/Type.hs
270 lines 6.1 kB history raw
1module AST.Type
2 ( Type(..), RawType, CanonicalType
3 , fieldMap, recordOf, listOf, tupleOf
4 , deepDealias, dealias
5 , collectLambdas
6 , prettyParens
7 ) where
9import Control.Applicative ((<$>), (<*>))
10import Control.Arrow (second)
11import Data.Binary
12import qualified Data.Map as Map
14import qualified AST.Variable as Var
15import AST.PrettyPrint
16import qualified AST.Helpers as Help
17import Text.PrettyPrint as P
20-- DEFINITION
22data Type var
23 = Lambda (Type var) (Type var)
24 | Var String
25 | Type var
26 | App (Type var) [Type var]
27 | Record [(String, Type var)] (Maybe (Type var))
28 | Aliased Var.Canonical [(String, Type var)] (Type var)
29 deriving (Eq,Show)
32type RawType =
33 Type Var.Raw
36type CanonicalType =
37 Type Var.Canonical
40fieldMap :: [(String,a)] -> Map.Map String [a]
41fieldMap fields =
42 let add r (field,tipe) =
43 Map.insertWith (++) field [tipe] r
44 in
45 foldl add Map.empty fields
48recordOf :: [(String, Type var)] -> Type var
49recordOf fields =
50 Record fields Nothing
53listOf :: RawType -> RawType
54listOf tipe =
55 App (Type (Var.Raw "List")) [tipe]
58tupleOf :: [RawType] -> RawType
59tupleOf types =
60 let name = Var.Raw ("_Tuple" ++ show (length types))
61 in
62 App (Type name) types
65-- DEALIASING
67deepDealias :: Type v -> Type v
68deepDealias tipe =
69 let go = deepDealias in
70 case tipe of
71 Lambda a b ->
72 Lambda (go a) (go b)
74 Var _ ->
75 tipe
77 Record fields ext ->
78 Record (map (second go) fields) (fmap go ext)
80 Aliased _name args tipe' ->
81 deepDealias (dealias args tipe')
83 Type _ ->
84 tipe
86 App f args ->
87 App (go f) (map go args)
90dealias :: [(String, Type v)] -> Type v -> Type v
91dealias args tipe =
92 replace (Map.fromList args) tipe
95replace :: Map.Map String (Type var) -> Type var -> Type var
96replace typeTable t =
97 let go = replace typeTable in
98 case t of
99 Lambda a b ->
100 Lambda (go a) (go b)
102 Var x ->
103 Map.findWithDefault t x typeTable
105 Record fields ext ->
106 Record (map (second go) fields) (fmap go ext)
108 Aliased original args t' ->
109 let typeTable' = foldr Map.delete typeTable (map fst args)
110 in
111 Aliased original (map (second go) args) (replace typeTable' t')
113 Type _ ->
114 t
116 App f args ->
117 App (go f) (map go args)
120-- PRETTY PRINTING
122instance (Var.ToString var, Pretty var) => Pretty (Type var) where
123 pretty tipe =
124 case tipe of
125 Lambda _ _ ->
126 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
127 where
128 t:ts = map prettyLambda (collectLambdas tipe)
129 prettyLambda t =
130 case t of
131 Lambda _ _ -> P.parens (pretty t)
132 _ -> pretty t
134 Var x ->
135 P.text x
137 Type var ->
138 let v = Var.toString var
139 in
140 P.text (if v == "_Tuple0" then "()" else v)
142 App f args ->
143 case (f,args) of
144 (Type name, _)
145 | Help.isTuple (Var.toString name) ->
146 P.parens (P.sep (P.punctuate P.comma (map pretty args)))
148 _ -> P.hang (pretty f) 2 (P.sep (map prettyParens args))
150 Record _ _ ->
151 case flattenRecord tipe of
152 ([], Nothing) ->
153 P.text "{}"
155 (fields, Nothing) ->
156 P.sep
157 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
158 , P.rbrace
159 ]
161 (fields, Just x) ->
162 P.hang
163 (P.lbrace <+> P.text x <+> P.text "|")
164 4
165 (P.sep
166 [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
167 , P.rbrace
168 ])
169 where
170 prettyField (field, tipe) =
171 P.text field <+> P.text ":" <+> pretty tipe
173 Aliased name [] t ->
174 let t' = pretty t
175 in
176 if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]
177 then t'
178 else pretty name
180 Aliased name args _ ->
181 P.hang (pretty name) 2 (P.sep (map (prettyParens . snd) args))
184collectLambdas :: Type var -> [Type var]
185collectLambdas tipe =
186 case tipe of
187 Lambda arg body ->
188 arg : collectLambdas body
190 _ ->
191 [tipe]
194prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
195prettyParens tipe =
196 parensIf (needed tipe) (pretty tipe)
197 where
198 needed t =
199 case t of
200 Aliased _ [] _ -> False
202 Aliased _ _ _ -> True
204 Lambda _ _ -> True
206 App (Type name) _
207 | Help.isTuple (Var.toString name) ->
208 False
210 App t' [] -> needed t'
212 App _ _ -> True
214 _ -> False
217flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
218flattenRecord tipe =
219 case tipe of
220 Var x ->
221 ([], Just x)
223 Record fields Nothing ->
224 (fields, Nothing)
226 Record fields (Just ext) ->
227 let (fields',ext') = flattenRecord ext
228 in
229 (fields' ++ fields, ext')
231 Aliased _ _ tipe' ->
232 flattenRecord tipe'
234 _ ->
235 error "Trying to flatten ill-formed record."
238-- BINARY
240instance Binary var => Binary (Type var) where
241 put tipe =
242 case tipe of
243 Lambda t1 t2 ->
244 putWord8 0 >> put t1 >> put t2
246 Var x ->
247 putWord8 1 >> put x
249 Type name ->
250 putWord8 2 >> put name
252 App t1 t2 ->
253 putWord8 3 >> put t1 >> put t2
255 Record fs ext ->
256 putWord8 4 >> put fs >> put ext
258 Aliased var args t ->
259 putWord8 5 >> put var >> put args >> put t
261 get = do
262 n <- getWord8
263 case n of
264 0 -> Lambda <$> get <*> get
265 1 -> Var <$> get
266 2 -> Type <$> get
267 3 -> App <$> get <*> get
268 4 -> Record <$> get <*> get
269 5 -> Aliased <$> get <*> get <*> get
270 _ -> error "Error reading a valid type from serialized string"