git.iko.soy/elk
on 68fdeff help sign in
elk/src/AST/Type.hs
183 lines 4.5 kB history raw
1module AST.Type where
3import Control.Applicative ((<$>), (<*>))
4import Data.Binary
5import qualified Data.Map as Map
7import qualified AST.Variable as Var
8import AST.PrettyPrint
9import qualified AST.Helpers as Help
10import Text.PrettyPrint as P
13data Type var
14 = Lambda (Type var) (Type var)
15 | Var String
16 | Type var
17 | App (Type var) [Type var]
18 | Record [(String, Type var)] (Maybe (Type var))
19 | Aliased Var.Canonical (Type var)
20 deriving (Eq,Show)
23type RawType =
24 Type Var.Raw
27type CanonicalType =
28 Type Var.Canonical
31fieldMap :: [(String,a)] -> Map.Map String [a]
32fieldMap fields =
33 foldl (\r (field,tipe) -> Map.insertWith (++) field [tipe] r) Map.empty fields
36recordOf :: [(String, Type var)] -> Type var
37recordOf fields =
38 Record fields Nothing
41listOf :: RawType -> RawType
42listOf tipe =
43 App (Type (Var.Raw "List")) [tipe]
46tupleOf :: [RawType] -> RawType
47tupleOf types =
48 let name = Var.Raw ("_Tuple" ++ show (length types))
49 in
50 App (Type name) types
53instance (Var.ToString var, Pretty var) => Pretty (Type var) where
54 pretty tipe =
55 case tipe of
56 Lambda _ _ ->
57 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
58 where
59 t:ts = map prettyLambda (collectLambdas tipe)
60 prettyLambda t =
61 case t of
62 Lambda _ _ -> P.parens (pretty t)
63 _ -> pretty t
65 Var x ->
66 P.text x
68 Type var ->
69 let v = Var.toString var
70 in
71 P.text (if v == "_Tuple0" then "()" else v)
73 App f args ->
74 case (f,args) of
75 (Type name, _)
76 | Help.isTuple (Var.toString name) ->
77 P.parens (P.sep (P.punctuate P.comma (map pretty args)))
79 _ -> P.hang (pretty f) 2 (P.sep (map prettyParens args))
81 Record _ _ ->
82 case flattenRecord tipe of
83 ([], Nothing) ->
84 P.text "{}"
86 (fields, Nothing) ->
87 P.sep
88 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
89 , P.rbrace
90 ]
92 (fields, Just x) ->
93 P.hang
94 (P.lbrace <+> P.text x <+> P.text "|")
95 4
96 (P.sep
97 [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
98 , P.rbrace
99 ])
100 where
101 prettyField (field, tipe) =
102 P.text field <+> P.text ":" <+> pretty tipe
104 Aliased name t ->
105 let t' = pretty t
106 in
107 if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]
108 then t'
109 else pretty name
112collectLambdas :: Type var -> [Type var]
113collectLambdas tipe =
114 case tipe of
115 Lambda arg body ->
116 arg : collectLambdas body
118 _ ->
119 [tipe]
122prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
123prettyParens tipe =
124 parensIf (needed tipe) (pretty tipe)
125 where
126 needed t =
127 case t of
128 Aliased _ t' -> needed t'
130 Lambda _ _ -> True
132 App (Type name) _
133 | Help.isTuple (Var.toString name) ->
134 False
136 App t' [] -> needed t'
138 App _ _ -> True
140 _ -> False
143flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
144flattenRecord tipe =
145 case tipe of
146 Var x ->
147 ([], Just x)
149 Record fields Nothing ->
150 (fields, Nothing)
152 Record fields (Just ext) ->
153 let (fields',ext') = flattenRecord ext
154 in
155 (fields' ++ fields, ext')
157 Aliased _ tipe' ->
158 flattenRecord tipe'
160 _ ->
161 error "Trying to flatten ill-formed record."
164instance Binary var => Binary (Type var) where
165 put tipe =
166 case tipe of
167 Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2
168 Var x -> putWord8 1 >> put x
169 Type name -> putWord8 2 >> put name
170 App t1 t2 -> putWord8 3 >> put t1 >> put t2
171 Record fs ext -> putWord8 4 >> put fs >> put ext
172 Aliased var t -> putWord8 5 >> put var >> put t
174 get = do
175 n <- getWord8
176 case n of
177 0 -> Lambda <$> get <*> get
178 1 -> Var <$> get
179 2 -> Type <$> get
180 3 -> App <$> get <*> get
181 4 -> Record <$> get <*> get
182 5 -> Aliased <$> get <*> get
183 _ -> error "Error reading a valid type from serialized string"