git.iko.soy/elk
on fdcaaed help sign in
elk/src/AST/Type.hs
137 lines 4.1 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, [t])
58 | Var.toString name == "_List" -> P.brackets (pretty t)
60 (Type name, _)
61 | Help.isTuple (Var.toString name) ->
62 P.parens . P.sep . P.punctuate P.comma $ map pretty args
64 _ -> P.hang (pretty f) 2 (P.sep $ map prettyParens args)
66 Record _ _ ->
67 P.braces $ case flattenRecord tipe of
68 (fields, Nothing) -> prettyFields fields
69 (fields, Just x) ->
70 P.hang (P.text x <+> P.text "|") 4 (prettyFields fields)
71 where
72 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
73 prettyFields fields = commaSep (map prettyField fields)
75 Aliased name t ->
76 let t' = pretty t in
77 if show t' `elem` ["Int", "Float", "String", "Char", "Bool"]
78 then t'
79 else pretty name
81collectLambdas :: Type var -> [Type var]
82collectLambdas tipe =
83 case tipe of
84 Lambda arg body -> arg : collectLambdas body
85 _ -> [tipe]
87prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
88prettyParens tipe = parensIf (needed tipe) (pretty tipe)
89 where
90 needed t =
91 case t of
92 Aliased _ t' -> needed t'
94 Lambda _ _ -> True
96 App (Type name) [_] | Var.toString name == "_List" -> False
97 App (Type name) _ | Help.isTuple (Var.toString name) -> False
98 App t' [] -> needed t'
99 App _ _ -> True
101 _ -> False
103flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
104flattenRecord tipe =
105 case tipe of
106 Var x -> ([], Just x)
108 Record fields Nothing -> (fields, Nothing)
110 Record fields (Just ext) ->
111 let (fields',ext') = flattenRecord ext
112 in (fields' ++ fields, ext')
114 Aliased _ tipe' -> flattenRecord tipe'
116 _ -> error "Trying to flatten ill-formed record."
118instance Binary var => Binary (Type var) where
119 put tipe =
120 case tipe of
121 Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2
122 Var x -> putWord8 1 >> put x
123 Type name -> putWord8 2 >> put name
124 App t1 t2 -> putWord8 3 >> put t1 >> put t2
125 Record fs ext -> putWord8 4 >> put fs >> put ext
126 Aliased var t -> putWord8 5 >> put var >> put t
128 get = do
129 n <- getWord8
130 case n of
131 0 -> Lambda <$> get <*> get
132 1 -> Var <$> get
133 2 -> Type <$> get
134 3 -> App <$> get <*> get
135 4 -> Record <$> get <*> get
136 5 -> Aliased <$> get <*> get
137 _ -> error "Error reading a valid type from serialized string"