git.iko.soy/elk
on cfaeff9 help sign in
elk/src/AST/Type.hs
148 lines 4.3 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
12data Type var
13 = Lambda (Type var) (Type var)
14 | Var String
15 | Type var
16 | App (Type var) [Type var]
17 | Record [(String, Type var)] (Maybe (Type var))
18 | Aliased Var.Canonical (Type var)
19 deriving (Eq,Show)
21type RawType = Type Var.Raw
22type CanonicalType = Type Var.Canonical
24fieldMap :: [(String,a)] -> Map.Map String [a]
25fieldMap fields =
26 foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
28recordOf :: [(String, Type var)] -> Type var
29recordOf fields = Record fields Nothing
31listOf :: RawType -> RawType
32listOf t = App (Type (Var.Raw "List")) [t]
34tupleOf :: [RawType] -> RawType
35tupleOf ts = App (Type t) ts
36 where
37 t = Var.Raw ("_Tuple" ++ show (length ts))
39instance (Var.ToString var, Pretty var) => Pretty (Type var) where
40 pretty tipe =
41 case tipe of
42 Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
43 where
44 t:ts = map prettyLambda (collectLambdas tipe)
45 prettyLambda t = case t of
46 Lambda _ _ -> P.parens (pretty t)
47 _ -> pretty t
49 Var x -> P.text x
51 Type var ->
52 let v = Var.toString var in
53 P.text (if v == "_Tuple0" then "()" else v)
55 App f args ->
56 case (f,args) of
57 (Type name, _)
58 | Help.isTuple (Var.toString name) ->
59 P.parens . P.sep . P.punctuate P.comma $ map pretty args
61 _ -> P.hang (pretty f) 2 (P.sep $ map prettyParens args)
63 Record _ _ ->
64 case flattenRecord tipe of
65 ([], Nothing) ->
66 P.text "{}"
68 (fields, Nothing) ->
69 P.sep
70 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
71 , P.rbrace
72 ]
74 (fields, Just x) ->
75 P.hang
76 (P.lbrace <+> P.text x <+> P.text "|")
77 4
78 (P.sep
79 [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
80 , P.rbrace
81 ])
82 where
83 prettyField (field, tipe) =
84 P.text field <+> P.text ":" <+> pretty tipe
86 Aliased name t ->
87 let t' = pretty t in
88 if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]
89 then t'
90 else pretty name
93collectLambdas :: Type var -> [Type var]
94collectLambdas tipe =
95 case tipe of
96 Lambda arg body -> arg : collectLambdas body
97 _ -> [tipe]
99prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
100prettyParens tipe = parensIf (needed tipe) (pretty tipe)
101 where
102 needed t =
103 case t of
104 Aliased _ t' -> needed t'
106 Lambda _ _ -> True
108 App (Type name) _ | Help.isTuple (Var.toString name) -> False
109 App t' [] -> needed t'
110 App _ _ -> True
112 _ -> False
114flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
115flattenRecord tipe =
116 case tipe of
117 Var x -> ([], Just x)
119 Record fields Nothing -> (fields, Nothing)
121 Record fields (Just ext) ->
122 let (fields',ext') = flattenRecord ext
123 in (fields' ++ fields, ext')
125 Aliased _ tipe' -> flattenRecord tipe'
127 _ -> error "Trying to flatten ill-formed record."
129instance Binary var => Binary (Type var) where
130 put tipe =
131 case tipe of
132 Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2
133 Var x -> putWord8 1 >> put x
134 Type name -> putWord8 2 >> put name
135 App t1 t2 -> putWord8 3 >> put t1 >> put t2
136 Record fs ext -> putWord8 4 >> put fs >> put ext
137 Aliased var t -> putWord8 5 >> put var >> put t
139 get = do
140 n <- getWord8
141 case n of
142 0 -> Lambda <$> get <*> get
143 1 -> Var <$> get
144 2 -> Type <$> get
145 3 -> App <$> get <*> get
146 4 -> Record <$> get <*> get
147 5 -> Aliased <$> get <*> get
148 _ -> error "Error reading a valid type from serialized string"