git.iko.soy/elk
on ab17521 help sign in
elk/compiler/AST/Type.hs
124 lines 3.7 kB history raw
1{-# OPTIONS_GHC -W #-}
2module AST.Type where
4import Control.Applicative ((<$>), (<*>))
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
13data Type var
14 = Lambda (Type var) (Type var)
15 | Var String
16 | Data 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 = Data (Var.Raw "_List") [t]
34tupleOf :: [RawType] -> RawType
35tupleOf ts = Data (Var.Raw $ "_Tuple" ++ show (length ts)) ts
37instance (Var.ToString var, Pretty var) => Pretty (Type var) where
38 pretty tipe =
39 case tipe of
40 Lambda _ _ -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
41 where
42 t:ts = map prettyLambda (collectLambdas tipe)
43 prettyLambda t = case t of
44 Lambda _ _ -> P.parens (pretty t)
45 _ -> pretty t
47 Var x -> P.text x
49 Data name [t] | Var.toString name == "_List" ->
50 P.brackets (pretty t)
52 Data name tipes
53 | Help.isTuple (Var.toString name) ->
54 P.parens . P.sep . P.punctuate P.comma $ map pretty tipes
55 | otherwise ->
56 P.hang (P.text (Var.toString name)) 2 (P.sep $ map prettyParens tipes)
58 Record _ _ ->
59 P.braces $ case flattenRecord tipe of
60 (fields, Nothing) -> prettyFields fields
61 (fields, Just x) ->
62 P.hang (P.text x <+> P.text "|") 4 (prettyFields fields)
63 where
64 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t
65 prettyFields fields = commaSep (map prettyField fields)
67 Aliased name _ -> pretty name
69collectLambdas :: Type var -> [Type var]
70collectLambdas tipe =
71 case tipe of
72 Lambda arg body -> arg : collectLambdas body
73 _ -> [tipe]
75prettyParens :: (Var.ToString var, Pretty var) => Type var -> Doc
76prettyParens tipe = parensIf (needed tipe) (pretty tipe)
77 where
78 needed t =
79 case t of
80 Aliased _ t' -> needed t'
81 Lambda _ _ -> True
82 Data name [_] | Var.toString name == "_List" -> False
83 Data _ [] -> False
84 Data _ _ -> True
85 _ -> False
87flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
88flattenRecord tipe =
89 case tipe of
90 Var x -> ([], Just x)
92 Record fields Nothing -> (fields, Nothing)
94 Record fields (Just ext) ->
95 let (fields',ext') = flattenRecord ext
96 in (fields' ++ fields, ext')
98 Aliased _ tipe' -> flattenRecord tipe'
100 _ -> error "Trying to flatten ill-formed record."
102instance Binary var => Binary (Type var) where
103 put tipe =
104 case tipe of
105 Lambda t1 t2 ->
106 putWord8 0 >> put t1 >> put t2
107 Var x ->
108 putWord8 1 >> put x
109 Data ctor tipes ->
110 putWord8 2 >> put ctor >> put tipes
111 Record fs ext ->
112 putWord8 3 >> put fs >> put ext
113 Aliased var t ->
114 putWord8 4 >> put var >> put t
116 get = do
117 n <- getWord8
118 case n of
119 0 -> Lambda <$> get <*> get
120 1 -> Var <$> get
121 2 -> Data <$> get <*> get
122 3 -> Record <$> get <*> get
123 4 -> Aliased <$> get <*> get
124 _ -> error "Error reading a valid type from serialized string"