git.iko.soy/elk
on 87ba2bc help sign in
elk/src/AST/Type.hs
133 lines 4.0 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 P.braces $ case flattenRecord tipe of
65 (fields, Nothing) -> prettyFields fields
66 (fields, Just x) ->
67 P.hang (P.text x <+> P.text "|") 4 (prettyFields fields)
68 where
69 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
70 prettyFields fields = commaSep (map prettyField fields)
72 Aliased name t ->
73 let t' = pretty t in
74 if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]
75 then t'
76 else pretty name
78collectLambdas :: Type var -> [Type var]
79collectLambdas tipe =
80 case tipe of
81 Lambda arg body -> arg : collectLambdas body
82 _ -> [tipe]
84prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
85prettyParens tipe = parensIf (needed tipe) (pretty tipe)
86 where
87 needed t =
88 case t of
89 Aliased _ t' -> needed t'
91 Lambda _ _ -> True
93 App (Type name) _ | Help.isTuple (Var.toString name) -> False
94 App t' [] -> needed t'
95 App _ _ -> True
97 _ -> False
99flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
100flattenRecord tipe =
101 case tipe of
102 Var x -> ([], Just x)
104 Record fields Nothing -> (fields, Nothing)
106 Record fields (Just ext) ->
107 let (fields',ext') = flattenRecord ext
108 in (fields' ++ fields, ext')
110 Aliased _ tipe' -> flattenRecord tipe'
112 _ -> error "Trying to flatten ill-formed record."
114instance Binary var => Binary (Type var) where
115 put tipe =
116 case tipe of
117 Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2
118 Var x -> putWord8 1 >> put x
119 Type name -> putWord8 2 >> put name
120 App t1 t2 -> putWord8 3 >> put t1 >> put t2
121 Record fs ext -> putWord8 4 >> put fs >> put ext
122 Aliased var t -> putWord8 5 >> put var >> put t
124 get = do
125 n <- getWord8
126 case n of
127 0 -> Lambda <$> get <*> get
128 1 -> Var <$> get
129 2 -> Type <$> get
130 3 -> App <$> get <*> get
131 4 -> Record <$> get <*> get
132 5 -> Aliased <$> get <*> get
133 _ -> error "Error reading a valid type from serialized string"