git.iko.soy/elk
on 2ec798e help sign in
elk/src/AST/Type.hs
209 lines 4.9 kB history raw
1module AST.Type where
3import Control.Applicative ((<$>), (<*>))
4import Control.Arrow (second)
5import Data.Binary
6import qualified Data.Map as Map
8import qualified AST.Variable as Var
9import AST.PrettyPrint
10import qualified AST.Helpers as Help
11import Text.PrettyPrint as P
14data Type var
15 = Lambda (Type var) (Type var)
16 | Var String
17 | Type var
18 | App (Type var) [Type var]
19 | Record [(String, Type var)] (Maybe (Type var))
20 | Aliased Var.Canonical (Type var)
21 deriving (Eq,Show)
24type RawType =
25 Type Var.Raw
28type CanonicalType =
29 Type Var.Canonical
32fieldMap :: [(String,a)] -> Map.Map String [a]
33fieldMap fields =
34 let add r (field,tipe) =
35 Map.insertWith (++) field [tipe] r
36 in
37 foldl add Map.empty fields
40recordOf :: [(String, Type var)] -> Type var
41recordOf fields =
42 Record fields Nothing
45listOf :: RawType -> RawType
46listOf tipe =
47 App (Type (Var.Raw "List")) [tipe]
50tupleOf :: [RawType] -> RawType
51tupleOf types =
52 let name = Var.Raw ("_Tuple" ++ show (length types))
53 in
54 App (Type name) types
57dealias :: Type v -> Type v
58dealias tipe =
59 case tipe of
60 Lambda arg body ->
61 Lambda (dealias arg) (dealias body)
63 Var _ ->
64 tipe
66 Type _ ->
67 tipe
69 App f args ->
70 App (dealias f) (map dealias args)
72 Record fields ext ->
73 Record (map (second dealias) fields) (fmap dealias ext)
75 Aliased _ t ->
76 dealias t
79instance (Var.ToString var, Pretty var) => Pretty (Type var) where
80 pretty tipe =
81 case tipe of
82 Lambda _ _ ->
83 P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
84 where
85 t:ts = map prettyLambda (collectLambdas tipe)
86 prettyLambda t =
87 case t of
88 Lambda _ _ -> P.parens (pretty t)
89 _ -> pretty t
91 Var x ->
92 P.text x
94 Type var ->
95 let v = Var.toString var
96 in
97 P.text (if v == "_Tuple0" then "()" else v)
99 App f args ->
100 case (f,args) of
101 (Type name, _)
102 | Help.isTuple (Var.toString name) ->
103 P.parens (P.sep (P.punctuate P.comma (map pretty args)))
105 _ -> P.hang (pretty f) 2 (P.sep (map prettyParens args))
107 Record _ _ ->
108 case flattenRecord tipe of
109 ([], Nothing) ->
110 P.text "{}"
112 (fields, Nothing) ->
113 P.sep
114 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
115 , P.rbrace
116 ]
118 (fields, Just x) ->
119 P.hang
120 (P.lbrace <+> P.text x <+> P.text "|")
121 4
122 (P.sep
123 [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
124 , P.rbrace
125 ])
126 where
127 prettyField (field, tipe) =
128 P.text field <+> P.text ":" <+> pretty tipe
130 Aliased name t ->
131 let t' = pretty t
132 in
133 if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]
134 then t'
135 else pretty name
138collectLambdas :: Type var -> [Type var]
139collectLambdas tipe =
140 case tipe of
141 Lambda arg body ->
142 arg : collectLambdas body
144 _ ->
145 [tipe]
148prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
149prettyParens tipe =
150 parensIf (needed tipe) (pretty tipe)
151 where
152 needed t =
153 case t of
154 Aliased _ t' -> needed t'
156 Lambda _ _ -> True
158 App (Type name) _
159 | Help.isTuple (Var.toString name) ->
160 False
162 App t' [] -> needed t'
164 App _ _ -> True
166 _ -> False
169flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
170flattenRecord tipe =
171 case tipe of
172 Var x ->
173 ([], Just x)
175 Record fields Nothing ->
176 (fields, Nothing)
178 Record fields (Just ext) ->
179 let (fields',ext') = flattenRecord ext
180 in
181 (fields' ++ fields, ext')
183 Aliased _ tipe' ->
184 flattenRecord tipe'
186 _ ->
187 error "Trying to flatten ill-formed record."
190instance Binary var => Binary (Type var) where
191 put tipe =
192 case tipe of
193 Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2
194 Var x -> putWord8 1 >> put x
195 Type name -> putWord8 2 >> put name
196 App t1 t2 -> putWord8 3 >> put t1 >> put t2
197 Record fs ext -> putWord8 4 >> put fs >> put ext
198 Aliased var t -> putWord8 5 >> put var >> put t
200 get = do
201 n <- getWord8
202 case n of
203 0 -> Lambda <$> get <*> get
204 1 -> Var <$> get
205 2 -> Type <$> get
206 3 -> App <$> get <*> get
207 4 -> Record <$> get <*> get
208 5 -> Aliased <$> get <*> get
209 _ -> error "Error reading a valid type from serialized string"