git.iko.soy/elk
on 8a87749 help sign in
elk/src/AST/Type.hs
314 lines 6.9 kB history raw
1module AST.Type
2 ( Type(..), AliasType(..)
3 , RawType, CanonicalType
4 , PortType(..), portType
5 , fieldMap, recordOf, listOf, tupleOf
6 , deepDealias, dealias
7 , collectLambdas
8 , prettyParens
9 ) where
11import Control.Applicative ((<$>), (<*>))
12import Control.Arrow (second)
13import Data.Binary
14import qualified Data.Map as Map
16import qualified AST.Variable as Var
17import AST.PrettyPrint
18import qualified AST.Helpers as Help
19import Text.PrettyPrint as P
22-- DEFINITION
24data Type var
25 = Lambda (Type var) (Type var)
26 | Var String
27 | Type var
28 | App (Type var) [Type var]
29 | Record [(String, Type var)] (Maybe (Type var))
30 | Aliased Var.Canonical [(String, Type var)] (AliasType var)
31 deriving (Eq,Show)
34data AliasType var
35 = Holey (Type var)
36 | Filled (Type var)
37 deriving (Eq,Show)
40type RawType =
41 Type Var.Raw
44type CanonicalType =
45 Type Var.Canonical
48data PortType var
49 = Normal (Type var)
50 | Signal { root :: Type var, arg :: Type var }
51 deriving (Show)
54portType :: PortType var -> Type var
55portType portType =
56 case portType of
57 Normal tipe -> tipe
58 Signal tipe _ -> tipe
61fieldMap :: [(String,a)] -> Map.Map String [a]
62fieldMap fields =
63 let add r (field,tipe) =
64 Map.insertWith (++) field [tipe] r
65 in
66 foldl add Map.empty fields
69recordOf :: [(String, Type var)] -> Type var
70recordOf fields =
71 Record fields Nothing
74listOf :: RawType -> RawType
75listOf tipe =
76 App (Type (Var.Raw "List")) [tipe]
79tupleOf :: [RawType] -> RawType
80tupleOf types =
81 let name = Var.Raw ("_Tuple" ++ show (length types))
82 in
83 App (Type name) types
86-- DEALIASING
88deepDealias :: Type v -> Type v
89deepDealias tipe =
90 let go = deepDealias in
91 case tipe of
92 Lambda a b ->
93 Lambda (go a) (go b)
95 Var _ ->
96 tipe
98 Record fields ext ->
99 Record (map (second go) fields) (fmap go ext)
101 Aliased _name args tipe' ->
102 deepDealias (dealias args tipe')
104 Type _ ->
105 tipe
107 App f args ->
108 App (go f) (map go args)
111dealias :: [(String, Type v)] -> AliasType v -> Type v
112dealias args aliasType =
113 case aliasType of
114 Holey tipe ->
115 dealiasHelp (Map.fromList args) tipe
117 Filled tipe ->
118 tipe
121dealiasHelp :: Map.Map String (Type var) -> Type var -> Type var
122dealiasHelp typeTable tipe =
123 let go = dealiasHelp typeTable in
124 case tipe of
125 Lambda a b ->
126 Lambda (go a) (go b)
128 Var x ->
129 Map.findWithDefault tipe x typeTable
131 Record fields ext ->
132 Record (map (second go) fields) (fmap go ext)
134 Aliased original args t' ->
135 Aliased original (map (second go) args) t'
137 Type _ ->
138 tipe
140 App f args ->
141 App (go f) (map go args)
144-- PRETTY PRINTING
146instance (Pretty var, Var.ToString var) => Pretty (PortType var) where
147 pretty portType =
148 case portType of
149 Normal tipe ->
150 pretty tipe
152 Signal tipe _ ->
153 pretty tipe
156instance (Var.ToString var, Pretty var) => Pretty (Type var) where
157 pretty tipe =
158 case tipe of
159 Lambda _ _ ->
160 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
161 where
162 t:ts = map prettyLambda (collectLambdas tipe)
163 prettyLambda t =
164 case t of
165 Lambda _ _ -> P.parens (pretty t)
166 _ -> pretty t
168 Var x ->
169 P.text x
171 Type var ->
172 let v = Var.toString var
173 in
174 P.text (if v == "_Tuple0" then "()" else v)
176 App f args ->
177 case (f,args) of
178 (Type name, _)
179 | Help.isTuple (Var.toString name) ->
180 P.parens (P.sep (P.punctuate P.comma (map pretty args)))
182 _ -> P.hang (pretty f) 2 (P.sep (map prettyParens args))
184 Record _ _ ->
185 case flattenRecord tipe of
186 ([], Nothing) ->
187 P.text "{}"
189 (fields, Nothing) ->
190 P.sep
191 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
192 , P.rbrace
193 ]
195 (fields, Just x) ->
196 P.hang
197 (P.lbrace <+> P.text x <+> P.text "|")
198 4
199 (P.sep
200 [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
201 , P.rbrace
202 ])
203 where
204 prettyField (field, tipe) =
205 P.text field <+> P.text ":" <+> pretty tipe
207 Aliased name args _ ->
208 P.hang (pretty name) 2 (P.sep (map (prettyParens . snd) args))
211collectLambdas :: Type var -> [Type var]
212collectLambdas tipe =
213 case tipe of
214 Lambda arg body ->
215 arg : collectLambdas body
217 _ ->
218 [tipe]
221prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
222prettyParens tipe =
223 parensIf (needed tipe) (pretty tipe)
224 where
225 needed t =
226 case t of
227 Aliased _ [] _ -> False
229 Aliased _ _ _ -> True
231 Lambda _ _ -> True
233 App (Type name) _
234 | Help.isTuple (Var.toString name) ->
235 False
237 App t' [] -> needed t'
239 App _ _ -> True
241 _ -> False
244flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
245flattenRecord tipe =
246 case tipe of
247 Var x ->
248 ([], Just x)
250 Record fields Nothing ->
251 (fields, Nothing)
253 Record fields (Just ext) ->
254 let (fields',ext') = flattenRecord ext
255 in
256 (fields' ++ fields, ext')
258 Aliased _ args tipe' ->
259 flattenRecord (dealias args tipe')
261 _ ->
262 error "Trying to flatten ill-formed record."
265-- BINARY
267instance Binary var => Binary (Type var) where
268 put tipe =
269 case tipe of
270 Lambda t1 t2 ->
271 putWord8 0 >> put t1 >> put t2
273 Var x ->
274 putWord8 1 >> put x
276 Type name ->
277 putWord8 2 >> put name
279 App t1 t2 ->
280 putWord8 3 >> put t1 >> put t2
282 Record fs ext ->
283 putWord8 4 >> put fs >> put ext
285 Aliased var args t ->
286 putWord8 5 >> put var >> put args >> put t
288 get = do
289 n <- getWord8
290 case n of
291 0 -> Lambda <$> get <*> get
292 1 -> Var <$> get
293 2 -> Type <$> get
294 3 -> App <$> get <*> get
295 4 -> Record <$> get <*> get
296 5 -> Aliased <$> get <*> get <*> get
297 _ -> error "Error reading a valid type from serialized string"
300instance Binary var => Binary (AliasType var) where
301 put aliasType =
302 case aliasType of
303 Holey tipe ->
304 putWord8 0 >> put tipe
306 Filled tipe ->
307 putWord8 1 >> put tipe
309 get = do
310 n <- getWord8
311 case n of
312 0 -> Holey <$> get
313 1 -> Filled <$> get
314 _ -> error "Error reading a valid type from serialized string"