git.iko.soy/elk
on dfdb2c0 help sign in
elk/src/AST/Type.hs
290 lines 6.5 kB history raw
1module AST.Type
2 ( Type(..), RawType, CanonicalType
3 , PortType(..), PortDirection(..)
4 , fieldMap, recordOf, listOf, tupleOf
5 , deepDealias, dealias
6 , collectLambdas
7 , prettyParens
8 ) where
10import Control.Applicative ((<$>), (<*>))
11import Control.Arrow (second)
12import Data.Binary
13import qualified Data.Map as Map
15import qualified AST.Variable as Var
16import AST.PrettyPrint
17import qualified AST.Helpers as Help
18import Text.PrettyPrint as P
21-- DEFINITION
23data Type var
24 = Lambda (Type var) (Type var)
25 | Var String
26 | Type var
27 | App (Type var) [Type var]
28 | Record [(String, Type var)] (Maybe (Type var))
29 | Aliased Var.Canonical [(String, Type var)] (Type var)
30 deriving (Eq,Show)
33type RawType =
34 Type Var.Raw
37type CanonicalType =
38 Type Var.Canonical
41data PortType var = PortType
42 { direction :: PortDirection var
43 , tipe :: Type var
44 }
45 deriving (Show)
48data PortDirection var
49 = Inbound (Type var)
50 | Internal
51 | Outbound (Type var)
52 deriving (Show)
55fieldMap :: [(String,a)] -> Map.Map String [a]
56fieldMap fields =
57 let add r (field,tipe) =
58 Map.insertWith (++) field [tipe] r
59 in
60 foldl add Map.empty fields
63recordOf :: [(String, Type var)] -> Type var
64recordOf fields =
65 Record fields Nothing
68listOf :: RawType -> RawType
69listOf tipe =
70 App (Type (Var.Raw "List")) [tipe]
73tupleOf :: [RawType] -> RawType
74tupleOf types =
75 let name = Var.Raw ("_Tuple" ++ show (length types))
76 in
77 App (Type name) types
80-- DEALIASING
82deepDealias :: Type v -> Type v
83deepDealias tipe =
84 let go = deepDealias in
85 case tipe of
86 Lambda a b ->
87 Lambda (go a) (go b)
89 Var _ ->
90 tipe
92 Record fields ext ->
93 Record (map (second go) fields) (fmap go ext)
95 Aliased _name args tipe' ->
96 deepDealias (dealias args tipe')
98 Type _ ->
99 tipe
101 App f args ->
102 App (go f) (map go args)
105dealias :: [(String, Type v)] -> Type v -> Type v
106dealias args tipe =
107 replace (Map.fromList args) tipe
110replace :: Map.Map String (Type var) -> Type var -> Type var
111replace typeTable t =
112 let go = replace typeTable in
113 case t of
114 Lambda a b ->
115 Lambda (go a) (go b)
117 Var x ->
118 Map.findWithDefault t x typeTable
120 Record fields ext ->
121 Record (map (second go) fields) (fmap go ext)
123 Aliased original args t' ->
124 let typeTable' = foldr Map.delete typeTable (map fst args)
125 in
126 Aliased original (map (second go) args) (replace typeTable' t')
128 Type _ ->
129 t
131 App f args ->
132 App (go f) (map go args)
135-- PRETTY PRINTING
137instance (Pretty var, Var.ToString var) => Pretty (PortType var) where
138 pretty portType =
139 pretty (tipe portType)
142instance (Var.ToString var, Pretty var) => Pretty (Type var) where
143 pretty tipe =
144 case tipe of
145 Lambda _ _ ->
146 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
147 where
148 t:ts = map prettyLambda (collectLambdas tipe)
149 prettyLambda t =
150 case t of
151 Lambda _ _ -> P.parens (pretty t)
152 _ -> pretty t
154 Var x ->
155 P.text x
157 Type var ->
158 let v = Var.toString var
159 in
160 P.text (if v == "_Tuple0" then "()" else v)
162 App f args ->
163 case (f,args) of
164 (Type name, _)
165 | Help.isTuple (Var.toString name) ->
166 P.parens (P.sep (P.punctuate P.comma (map pretty args)))
168 _ -> P.hang (pretty f) 2 (P.sep (map prettyParens args))
170 Record _ _ ->
171 case flattenRecord tipe of
172 ([], Nothing) ->
173 P.text "{}"
175 (fields, Nothing) ->
176 P.sep
177 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
178 , P.rbrace
179 ]
181 (fields, Just x) ->
182 P.hang
183 (P.lbrace <+> P.text x <+> P.text "|")
184 4
185 (P.sep
186 [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
187 , P.rbrace
188 ])
189 where
190 prettyField (field, tipe) =
191 P.text field <+> P.text ":" <+> pretty tipe
193 Aliased name [] t ->
194 let t' = pretty t
195 in
196 if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]
197 then t'
198 else pretty name
200 Aliased name args _ ->
201 P.hang (pretty name) 2 (P.sep (map (prettyParens . snd) args))
204collectLambdas :: Type var -> [Type var]
205collectLambdas tipe =
206 case tipe of
207 Lambda arg body ->
208 arg : collectLambdas body
210 _ ->
211 [tipe]
214prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
215prettyParens tipe =
216 parensIf (needed tipe) (pretty tipe)
217 where
218 needed t =
219 case t of
220 Aliased _ [] _ -> False
222 Aliased _ _ _ -> True
224 Lambda _ _ -> True
226 App (Type name) _
227 | Help.isTuple (Var.toString name) ->
228 False
230 App t' [] -> needed t'
232 App _ _ -> True
234 _ -> False
237flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
238flattenRecord tipe =
239 case tipe of
240 Var x ->
241 ([], Just x)
243 Record fields Nothing ->
244 (fields, Nothing)
246 Record fields (Just ext) ->
247 let (fields',ext') = flattenRecord ext
248 in
249 (fields' ++ fields, ext')
251 Aliased _ _ tipe' ->
252 flattenRecord tipe'
254 _ ->
255 error "Trying to flatten ill-formed record."
258-- BINARY
260instance Binary var => Binary (Type var) where
261 put tipe =
262 case tipe of
263 Lambda t1 t2 ->
264 putWord8 0 >> put t1 >> put t2
266 Var x ->
267 putWord8 1 >> put x
269 Type name ->
270 putWord8 2 >> put name
272 App t1 t2 ->
273 putWord8 3 >> put t1 >> put t2
275 Record fs ext ->
276 putWord8 4 >> put fs >> put ext
278 Aliased var args t ->
279 putWord8 5 >> put var >> put args >> put t
281 get = do
282 n <- getWord8
283 case n of
284 0 -> Lambda <$> get <*> get
285 1 -> Var <$> get
286 2 -> Type <$> get
287 3 -> App <$> get <*> get
288 4 -> Record <$> get <*> get
289 5 -> Aliased <$> get <*> get <*> get
290 _ -> error "Error reading a valid type from serialized string"