git.iko.soy/elk
on d87affe help sign in
elk/src/AST/Type.hs
144 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 (fields, Nothing) ->
66 P.sep
67 [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))
68 , P.rbrace
69 ]
71 (fields, Just x) ->
72 P.hang
73 (P.lbrace <+> P.text x <+> P.text "|")
74 4
75 (P.sep
76 [ P.cat (zipWith (<+>) (P.space : repeat P.comma) (map prettyField fields))
77 , P.rbrace
78 ])
79 where
80 prettyField (field, tipe) =
81 P.text field <+> P.text ":" <+> pretty tipe
83 Aliased name t ->
84 let t' = pretty t in
85 if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]
86 then t'
87 else pretty name
89collectLambdas :: Type var -> [Type var]
90collectLambdas tipe =
91 case tipe of
92 Lambda arg body -> arg : collectLambdas body
93 _ -> [tipe]
95prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
96prettyParens tipe = parensIf (needed tipe) (pretty tipe)
97 where
98 needed t =
99 case t of
100 Aliased _ t' -> needed t'
102 Lambda _ _ -> True
104 App (Type name) _ | Help.isTuple (Var.toString name) -> False
105 App t' [] -> needed t'
106 App _ _ -> True
108 _ -> False
110flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
111flattenRecord tipe =
112 case tipe of
113 Var x -> ([], Just x)
115 Record fields Nothing -> (fields, Nothing)
117 Record fields (Just ext) ->
118 let (fields',ext') = flattenRecord ext
119 in (fields' ++ fields, ext')
121 Aliased _ tipe' -> flattenRecord tipe'
123 _ -> error "Trying to flatten ill-formed record."
125instance Binary var => Binary (Type var) where
126 put tipe =
127 case tipe of
128 Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2
129 Var x -> putWord8 1 >> put x
130 Type name -> putWord8 2 >> put name
131 App t1 t2 -> putWord8 3 >> put t1 >> put t2
132 Record fs ext -> putWord8 4 >> put fs >> put ext
133 Aliased var t -> putWord8 5 >> put var >> put t
135 get = do
136 n <- getWord8
137 case n of
138 0 -> Lambda <$> get <*> get
139 1 -> Var <$> get
140 2 -> Type <$> get
141 3 -> App <$> get <*> get
142 4 -> Record <$> get <*> get
143 5 -> Aliased <$> get <*> get
144 _ -> error "Error reading a valid type from serialized string"