git.iko.soy/elk
on 2aa7dcd help sign in
elk/src/AST/Type.hs
321 lines 7.2 kB history raw
1module AST.Type
2 ( Raw, Raw'(..)
3 , Canonical(..), Aliased(..)
4 , Port(..), portType
5 , deepDealias, dealias
6 , collectLambdas
7 , fieldMap
8 , tuple
9 ) where
11import Control.Applicative ((<$>), (<*>))
12import Control.Arrow (second)
13import Data.Binary
14import qualified Data.Map as Map
15import Text.PrettyPrint as P
17import qualified AST.Variable as Var
18import qualified AST.Helpers as Help
19import qualified Reporting.Annotation as A
20import qualified Reporting.PrettyPrint as P
21import qualified Reporting.Region as R
24-- DEFINITION
26type Raw =
27 A.Located Raw'
30data Raw'
31 = RLambda Raw Raw
32 | RVar String
33 | RType Var.Raw
34 | RApp Raw [Raw]
35 | RRecord [(String, Raw)] (Maybe Raw)
36 deriving (Show)
39data Canonical
40 = Lambda Canonical Canonical
41 | Var String
42 | Type Var.Canonical
43 | App Canonical [Canonical]
44 | Record [(String, Canonical)] (Maybe Canonical)
45 | Aliased Var.Canonical [(String, Canonical)] (Aliased Canonical)
46 deriving (Eq, Ord, Show)
49data Aliased t
50 = Holey t
51 | Filled t
52 deriving (Eq, Ord, Show)
55data Port t
56 = Normal t
57 | Signal { root :: t, arg :: t }
58 deriving (Show)
61portType :: Port tipe -> tipe
62portType portType =
63 case portType of
64 Normal tipe -> tipe
65 Signal tipe _ -> tipe
68fieldMap :: [(String,a)] -> Map.Map String [a]
69fieldMap fields =
70 let add r (field,tipe) =
71 Map.insertWith (++) field [tipe] r
72 in
73 foldl add Map.empty fields
75{--
76recordOf :: [(String, Type var)] -> Type var
77recordOf fields =
78 Record fields Nothing
81listOf :: RawType -> RawType
82listOf tipe =
83 App (Type (Var.Raw "List")) [tipe]
84--}
86tuple :: R.Region -> [Raw] -> Raw
87tuple region types =
88 let name = Var.Raw ("_Tuple" ++ show (length types))
89 in
90 A.A region (RApp (A.A region (RType name)) types)
93-- DEALIASING
95deepDealias :: Canonical -> Canonical
96deepDealias tipe =
97 let go = deepDealias in
98 case tipe of
99 Lambda a b ->
100 Lambda (go a) (go b)
102 Var _ ->
103 tipe
105 Record fields ext ->
106 Record (map (second go) fields) (fmap go ext)
108 Aliased _name args tipe' ->
109 deepDealias (dealias args tipe')
111 Type _ ->
112 tipe
114 App f args ->
115 App (go f) (map go args)
118dealias :: [(String, Canonical)] -> Aliased Canonical -> Canonical
119dealias args aliasType =
120 case aliasType of
121 Holey tipe ->
122 dealiasHelp (Map.fromList args) tipe
124 Filled tipe ->
125 tipe
128dealiasHelp :: Map.Map String Canonical -> Canonical -> Canonical
129dealiasHelp typeTable tipe =
130 let go = dealiasHelp typeTable in
131 case tipe of
132 Lambda a b ->
133 Lambda (go a) (go b)
135 Var x ->
136 Map.findWithDefault tipe x typeTable
138 Record fields ext ->
139 Record (map (second go) fields) (fmap go ext)
141 Aliased original args t' ->
142 Aliased original (map (second go) args) t'
144 Type _ ->
145 tipe
147 App f args ->
148 App (go f) (map go args)
151-- PRETTY PRINTING
153instance (P.Pretty t) => P.Pretty (Port t) where
154 pretty needsParens portType =
155 case portType of
156 Normal tipe ->
157 P.pretty needsParens tipe
159 Signal tipe _ ->
160 P.pretty needsParens tipe
163instance P.Pretty Raw' where
164 pretty _ tipe =
165 P.text (show tipe)
168instance P.Pretty Canonical where
169 pretty needsParens tipe =
170 case tipe of
171 Lambda _ _ ->
172 P.parensIf needsParens $
173 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
174 where
175 t:ts =
176 map prettyLambda (collectLambdas tipe)
178 prettyLambda t =
179 case t of
180 Lambda _ _ ->
181 P.pretty True t
182 _ ->
183 P.pretty False t
185 Var x ->
186 P.text x
188 Type var ->
189 let v = Var.toString var
190 in
191 P.text (if v == "_Tuple0" then "()" else v)
193 App f args ->
194 case (f,args) of
195 (Type name, _)
196 | Help.isTuple (Var.toString name) ->
197 P.parens $ P.sep $
198 P.punctuate P.comma (map (P.pretty False) args)
200 (_, []) ->
201 P.pretty True f
203 (_, _) ->
204 P.parensIf needsParens $
205 P.hang
206 (P.pretty True f)
207 2
208 (P.sep (map (P.pretty True) args))
210 Record _ _ ->
211 case flattenRecord tipe of
212 ([], Nothing) ->
213 P.text "{}"
215 (fields, Nothing) ->
216 P.sep
217 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
218 , P.rbrace
219 ]
221 (fields, Just x) ->
222 P.hang
223 (P.lbrace <+> P.text x <+> P.text "|")
224 4
225 (P.sep
226 [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
227 , P.rbrace
228 ])
229 where
230 prettyField (field, tipe) =
231 P.text field <+> P.text ":" <+> P.pretty False tipe
233 Aliased name args _ ->
234 P.parensIf (needsParens && not (null args)) $
235 P.hang
236 (P.pretty False name)
237 2
238 (P.sep (map (P.pretty True . snd) args))
241collectLambdas :: Canonical -> [Canonical]
242collectLambdas tipe =
243 case tipe of
244 Lambda arg body ->
245 arg : collectLambdas body
247 _ ->
248 [tipe]
251flattenRecord :: Canonical -> ( [(String, Canonical)], Maybe String )
252flattenRecord tipe =
253 case tipe of
254 Var x ->
255 ([], Just x)
257 Record fields Nothing ->
258 (fields, Nothing)
260 Record fields (Just ext) ->
261 let (fields',ext') = flattenRecord ext
262 in
263 (fields' ++ fields, ext')
265 Aliased _ args tipe' ->
266 flattenRecord (dealias args tipe')
268 _ ->
269 error "Trying to flatten ill-formed record."
272-- BINARY
274instance Binary Canonical where
275 put tipe =
276 case tipe of
277 Lambda t1 t2 ->
278 putWord8 0 >> put t1 >> put t2
280 Var x ->
281 putWord8 1 >> put x
283 Type name ->
284 putWord8 2 >> put name
286 App t1 t2 ->
287 putWord8 3 >> put t1 >> put t2
289 Record fs ext ->
290 putWord8 4 >> put fs >> put ext
292 Aliased var args t ->
293 putWord8 5 >> put var >> put args >> put t
295 get = do
296 n <- getWord8
297 case n of
298 0 -> Lambda <$> get <*> get
299 1 -> Var <$> get
300 2 -> Type <$> get
301 3 -> App <$> get <*> get
302 4 -> Record <$> get <*> get
303 5 -> Aliased <$> get <*> get <*> get
304 _ -> error "Error reading a valid type from serialized string"
307instance Binary t => Binary (Aliased t) where
308 put aliasType =
309 case aliasType of
310 Holey tipe ->
311 putWord8 0 >> put tipe
313 Filled tipe ->
314 putWord8 1 >> put tipe
316 get = do
317 n <- getWord8
318 case n of
319 0 -> Holey <$> get
320 1 -> Filled <$> get
321 _ -> error "Error reading a valid type from serialized string"