git.iko.soy/elk
on 306a7ee help sign in
elk/src/AST/Type.hs
301 lines 6.9 kB history raw
1module AST.Type
2 ( Type(..), RawType, CanonicalType, PortType(..)
3 , portTypeToType, 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
40data PortType var
41 = Inbound (Type var)
42 | Internal (Type var)
43 | Outbound (Type var)
44 deriving (Show)
47portTypeToType :: PortType Var.Canonical -> CanonicalType
48portTypeToType portType =
49 let makeType name tipe =
50 App (Type (Var.fromModule ["Port"] name)) [tipe]
51 in
52 case portType of
53 Inbound tipe -> makeType "InboundPort" tipe
54 Internal tipe -> makeType "Port" tipe
55 Outbound tipe -> makeType "OutboundPort" tipe
58fieldMap :: [(String,a)] -> Map.Map String [a]
59fieldMap fields =
60 let add r (field,tipe) =
61 Map.insertWith (++) field [tipe] r
62 in
63 foldl add Map.empty fields
66recordOf :: [(String, Type var)] -> Type var
67recordOf fields =
68 Record fields Nothing
71listOf :: RawType -> RawType
72listOf tipe =
73 App (Type (Var.Raw "List")) [tipe]
76tupleOf :: [RawType] -> RawType
77tupleOf types =
78 let name = Var.Raw ("_Tuple" ++ show (length types))
79 in
80 App (Type name) types
83-- DEALIASING
85deepDealias :: Type v -> Type v
86deepDealias tipe =
87 let go = deepDealias in
88 case tipe of
89 Lambda a b ->
90 Lambda (go a) (go b)
92 Var _ ->
93 tipe
95 Record fields ext ->
96 Record (map (second go) fields) (fmap go ext)
98 Aliased _name args tipe' ->
99 deepDealias (dealias args tipe')
101 Type _ ->
102 tipe
104 App f args ->
105 App (go f) (map go args)
108dealias :: [(String, Type v)] -> Type v -> Type v
109dealias args tipe =
110 replace (Map.fromList args) tipe
113replace :: Map.Map String (Type var) -> Type var -> Type var
114replace typeTable t =
115 let go = replace typeTable in
116 case t of
117 Lambda a b ->
118 Lambda (go a) (go b)
120 Var x ->
121 Map.findWithDefault t x typeTable
123 Record fields ext ->
124 Record (map (second go) fields) (fmap go ext)
126 Aliased original args t' ->
127 let typeTable' = foldr Map.delete typeTable (map fst args)
128 in
129 Aliased original (map (second go) args) (replace typeTable' t')
131 Type _ ->
132 t
134 App f args ->
135 App (go f) (map go args)
138-- PRETTY PRINTING
140instance (Pretty var, Var.ToString var) => Pretty (PortType var) where
141 pretty portType =
142 case portType of
143 Inbound tipe ->
144 P.text "InboundPort" <+> pretty tipe
146 Internal tipe ->
147 P.text "Port" <+> pretty tipe
149 Outbound tipe ->
150 P.text "OutboundPort" <+> pretty tipe
153instance (Var.ToString var, Pretty var) => Pretty (Type var) where
154 pretty tipe =
155 case tipe of
156 Lambda _ _ ->
157 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
158 where
159 t:ts = map prettyLambda (collectLambdas tipe)
160 prettyLambda t =
161 case t of
162 Lambda _ _ -> P.parens (pretty t)
163 _ -> pretty t
165 Var x ->
166 P.text x
168 Type var ->
169 let v = Var.toString var
170 in
171 P.text (if v == "_Tuple0" then "()" else v)
173 App f args ->
174 case (f,args) of
175 (Type name, _)
176 | Help.isTuple (Var.toString name) ->
177 P.parens (P.sep (P.punctuate P.comma (map pretty args)))
179 _ -> P.hang (pretty f) 2 (P.sep (map prettyParens args))
181 Record _ _ ->
182 case flattenRecord tipe of
183 ([], Nothing) ->
184 P.text "{}"
186 (fields, Nothing) ->
187 P.sep
188 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
189 , P.rbrace
190 ]
192 (fields, Just x) ->
193 P.hang
194 (P.lbrace <+> P.text x <+> P.text "|")
195 4
196 (P.sep
197 [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
198 , P.rbrace
199 ])
200 where
201 prettyField (field, tipe) =
202 P.text field <+> P.text ":" <+> pretty tipe
204 Aliased name [] t ->
205 let t' = pretty t
206 in
207 if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]
208 then t'
209 else pretty name
211 Aliased name args _ ->
212 P.hang (pretty name) 2 (P.sep (map (prettyParens . snd) args))
215collectLambdas :: Type var -> [Type var]
216collectLambdas tipe =
217 case tipe of
218 Lambda arg body ->
219 arg : collectLambdas body
221 _ ->
222 [tipe]
225prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
226prettyParens tipe =
227 parensIf (needed tipe) (pretty tipe)
228 where
229 needed t =
230 case t of
231 Aliased _ [] _ -> False
233 Aliased _ _ _ -> True
235 Lambda _ _ -> True
237 App (Type name) _
238 | Help.isTuple (Var.toString name) ->
239 False
241 App t' [] -> needed t'
243 App _ _ -> True
245 _ -> False
248flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
249flattenRecord tipe =
250 case tipe of
251 Var x ->
252 ([], Just x)
254 Record fields Nothing ->
255 (fields, Nothing)
257 Record fields (Just ext) ->
258 let (fields',ext') = flattenRecord ext
259 in
260 (fields' ++ fields, ext')
262 Aliased _ _ tipe' ->
263 flattenRecord tipe'
265 _ ->
266 error "Trying to flatten ill-formed record."
269-- BINARY
271instance Binary var => Binary (Type var) where
272 put tipe =
273 case tipe of
274 Lambda t1 t2 ->
275 putWord8 0 >> put t1 >> put t2
277 Var x ->
278 putWord8 1 >> put x
280 Type name ->
281 putWord8 2 >> put name
283 App t1 t2 ->
284 putWord8 3 >> put t1 >> put t2
286 Record fs ext ->
287 putWord8 4 >> put fs >> put ext
289 Aliased var args t ->
290 putWord8 5 >> put var >> put args >> put t
292 get = do
293 n <- getWord8
294 case n of
295 0 -> Lambda <$> get <*> get
296 1 -> Var <$> get
297 2 -> Type <$> get
298 3 -> App <$> get <*> get
299 4 -> Record <$> get <*> get
300 5 -> Aliased <$> get <*> get <*> get
301 _ -> error "Error reading a valid type from serialized string"