git.iko.soy/elk
on master help sign in
Create a source syntax for types that will get converted into the internal type representation during type checking.
e4ca967Evan Czaplicki
compiler/Parse/Declaration.hsnew file+32
compare with master
unifiedsplit
@@ -0,0 +1,32 @@
1+
2+module Parse.Declaration where
3+
4+import Control.Applicative ((<$>), (<*>))
5+import Data.List (foldl')
6+import Text.Parsec hiding (newline,spaces)
7+import Text.Parsec.Indent
8+import qualified Text.Pandoc as Pan
9+
10+import Parse.Helpers
11+import qualified Parse.Expression as Expr
12+import qualified Parse.Type as Type
13+
14+import SourceSyntax.Declaration (Declaration(..))
15+
16+import Unique
17+
18+
19+definition :: IParser (Declaration t v)
20+definition = Definition <$> Expr.def
21+
22+alias :: IParser [Declaration t v]
23+alias = do
24+ start <- getPosition
25+ reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
26+ forcedWS
27+ alias <- capVar
28+ args <- spacePrefix lowVar
29+ whitespace ; string "=" ; whitespace
30+ tipe <- Type.expr
31+ end <- getPosition
32+ return [TypeAlias alias args tipe]
compiler/Parse/Expression.hs+9−6
@@ -20,7 +20,6 @@ import SourceSyntax.Expression
20import SourceSyntax.Declaration (Declaration(Definition))
20import SourceSyntax.Declaration (Declaration(Definition))
21
21
22import Unique
22import Unique
23−import Types.Types (Type (VarT), Scheme (Forall))
24
23
25
24
26-------- Basic Terms --------
25-------- Basic Terms --------
@@ -159,7 +158,7 @@ lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
159 return (makeFunction args body)
158 return (makeFunction args body)
160
159
161defSet :: IParser [Def t v]
160defSet :: IParser [Def t v]
162−defSet = block (do d <- anyDef ; whitespace ; return d)
161+defSet = block (do d <- def ; whitespace ; return d)
163
162
164letExpr :: IParser (Expr t v)
163letExpr :: IParser (Expr t v)
165letExpr = do
164letExpr = do
@@ -206,11 +205,15 @@ assignExpr = withPos $ do
206 body <- expr
205 body <- expr
207 return . Def name $ makeFunction args body
206 return . Def name $ makeFunction args body
208
207
209−anyDef :: IParser (Def t v)
208+typeAnnotation :: IParser (Def t v)
210−anyDef = Type.annotation <|> assignExpr
209+typeAnnotation = TypeAnnotation <$> try start <*> Type.expr
210+ where
211+ start = do v <- lowVar <|> parens symOp
212+ whitespace ; hasType ; whitespace
213+ return v
211
214
212−def :: IParser (Declaration t v)
215+def :: IParser (Def t v)
213−def = Definition <$> anyDef
216+def = typeAnnotation <|> assignExpr
214
217
215parseDef str =
218parseDef str =
216 case iParse def "" str of
219 case iParse def "" str of
compiler/Parse/Type.hs+76−112
@@ -8,106 +8,69 @@ import Text.Parsec
8import Text.Parsec.Indent
8import Text.Parsec.Indent
9
9
10import SourceSyntax.Location as Located
10import SourceSyntax.Location as Located
11+--import SourceSyntax.PrettyPrint
12+import SourceSyntax.Type as T
11−import SourceSyntax.Expression
13+--import qualified SourceSyntax.Expression as Expr
12−import SourceSyntax.Declaration
14+--import qualified SourceSyntax.Declaration as Decl
13import Parse.Helpers
15import Parse.Helpers
14−import Types.Types hiding (parens,string)
15import Unique
16import Unique
16
17
17−data ParseType = VarPT String
18+tvar :: IParser T.Type
18− | LambdaPT ParseType ParseType
19+tvar = T.Var <$> lowVar <?> "type variable"
19− | ADTPT String [ParseType]
20− | RecordPT (Maybe ParseType) [(String,ParseType)]
21− deriving (Show)
22−
23−listPT t = ADTPT "List" [t]
24−tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts
25−
26−typeVar :: IParser ParseType
27−typeVar = VarPT <$> lowVar <?> "type variable"
28−
29−typeList :: IParser ParseType
30−typeList = listPT <$> braces typeExpr
31−
32−typeTuple :: IParser ParseType
33−typeTuple = do ts <- parens (commaSep typeExpr)
34− return $ case ts of { [t] -> t ; _ -> tuplePT ts }
35−
36−typeRecord :: IParser ParseType
37−typeRecord = brackets (RecordPT <$> extend <*> fields)
38− where extend = optionMaybe . try $ do
39− t <- typeVar
40− whitespace >> string "|" >> whitespace
41− return t
42− fields = commaSep $ do
43− lbl <- rLabel
44− whitespace >> hasType >> whitespace
45− (,) lbl <$> typeExpr
46−
47−typeUnambiguous :: IParser ParseType
48−typeUnambiguous = typeList <|> typeTuple <|> typeRecord
49−
50−typeSimple :: IParser ParseType
51−typeSimple = VarPT <$> var
52−
53−typeApp :: IParser ParseType
54−typeApp = do name <- capVar <?> "type constructor"
55− args <- spacePrefix (typeUnambiguous <|> typeSimple)
56− return $ case args of
57− [] -> VarPT name
58− _ -> ADTPT name args
59−
60−typeExpr :: IParser ParseType
61−typeExpr = do
62− t1 <- typeVar <|> typeApp <|> typeUnambiguous
63− whitespace ; arr <- optionMaybe arrow ; whitespace
64− case arr of
65− Just _ -> LambdaPT t1 <$> typeExpr
66− Nothing -> return t1
67−
68−typeConstructor :: IParser (String, [ParseType])
69−typeConstructor = (,) <$> (capVar <?> "another type constructor")
70− <*> spacePrefix (typeSimple <|> typeUnambiguous)
71−
72−typeAlias :: IParser [Declaration t v]
73−typeAlias = do
74− start <- getPosition
75− reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
76− forcedWS
77− alias <- capVar
78− args <- spacePrefix lowVar
79− whitespace ; string "=" ; whitespace
80− let n = length args
81− tipe <- typeExpr
82− end <- getPosition
83− case toTypeWith alias (zip args [1..n]) tipe of
84− Left msg -> fail msg
85− Right t -> return (TypeAlias alias [1..n] t : ctor)
86− where ctor = case tipe of
87− RecordPT extension kvs ->
88− [] --toConstructor start end alias extension kvs]
89− _ -> []
90−{--
91−toConstructor start end alias Nothing kvs =
92− Definition (Def alias args (loc (Record rec)))
93− where
94− loc = Located.at start end
95− args = map fst kvs
96− rec = map (\a -> (a, loc (Var a))) args
97
20
98−toConstructor start end alias (Just _) kvs =
21+list :: IParser T.Type
99− Definition (Def alias (args++["_ext_"]) (loc rec))
22+list = listOf <$> braces expr
23+
24+tuple :: IParser T.Type
25+tuple = do ts <- parens (commaSep expr)
26+ return $ case ts of
27+ [t] -> t
28+ _ -> tupleOf ts
29+
30+record :: IParser T.Type
31+record = brackets $ do
32+ ext <- extend
33+ fs <- fields
34+ return (T.Record (fieldMap fs) ext)
100 where
35 where
101− loc = Located.at start end
36+ extend = option T.EmptyRecord . try $ do
102− args = map fst kvs
37+ t <- tvar
103− rec = foldl insert (Var "_ext_") (zip args (map (loc . Var) args))
38+ whitespace >> string "|" >> whitespace
104− insert e (k,v) = Insert (loc e) k v
39+ return t
105−--}
40+ fields = commaSep $ do
106−annotation :: IParser (Def t v)
41+ lbl <- rLabel
107−annotation = TypeAnnotation <$> try start <*> (toType <$> typeExpr)
108− where start = do v <- lowVar <|> parens symOp
109− whitespace ; hasType ; whitespace ; return v
42+ whitespace >> hasType >> whitespace
43+ (,) lbl <$> expr
44+
45+constructor0 :: IParser T.Type
46+constructor0 =
47+ do name <- capVar
48+ return (T.Data name [])
49+
50+term :: IParser T.Type
51+term = list <|> tuple <|> record <|> tvar <|> constructor0
52+
53+app :: IParser T.Type
54+app =
55+ do name <- capVar <?> "type constructor"
56+ args <- spacePrefix term
57+ return (T.Data name args)
58+
59+expr :: IParser T.Type
60+expr =
61+ do t1 <- app <|> term
62+ whitespace
63+ arr <- optionMaybe arrow
64+ whitespace
65+ case arr of
66+ Just _ -> T.Lambda t1 <$> expr
67+ Nothing -> return t1
68+
69+constructor :: IParser (String, [T.Type])
70+constructor = (,) <$> (capVar <?> "another type constructor")
71+ <*> spacePrefix term
110
72
73+{--
111datatype :: IParser (Declaration t v)
74datatype :: IParser (Declaration t v)
112datatype = do
75datatype = do
113 reserved "data" <?> "datatype definition (data T = A | B | ...)"
76 reserved "data" <?> "datatype definition (data T = A | B | ...)"
@@ -118,41 +81,41 @@ datatype = do
118 Right dt -> return dt
81 Right dt -> return dt
119 Left msg -> fail msg
82 Left msg -> fail msg
120
83
121−beta = liftM VarT guid
84+beta = liftM T.Var guid
122
85
123−toType :: ParseType -> Type
86+toType :: T.Type -> Type
124toType pt =
87toType pt =
125− let frees :: ParseType -> [String]
88+ let frees :: T.Type -> [String]
126 frees pt = case pt of
89 frees pt = case pt of
127 LambdaPT a b -> frees a ++ frees b
90 LambdaPT a b -> frees a ++ frees b
128 ADTPT _ ts -> concatMap frees ts
91 ADTPT _ ts -> concatMap frees ts
129 RecordPT t fs -> maybe [] frees t ++ concatMap (frees . snd) fs
92 RecordPT t fs -> maybe [] frees t ++ concatMap (frees . snd) fs
130 VarPT (c:cs) | isLower c -> [c:cs]
93 VarPT (c:cs) | isLower c -> [c:cs]
131 | otherwise -> []
94 | otherwise -> []
132− in case toTypeWith "" (zip (frees pt) [1..]) pt of
95+ in case toTypeWith "" (zip (frees pt) ['a'..]) pt of
133 Right t -> t
96 Right t -> t
134− Left _ -> VarT 0
97+ Left _ -> T.Var 0
135
98
136−toTypeWith :: String -> [(String,X)] -> ParseType -> Either String Type
99+toTypeWith :: String -> [(String,String)] -> T.Type -> Either String Type
137toTypeWith name tvarDict pt =
100toTypeWith name tvarDict pt =
138 let msg x = "Type variable '" ++ x ++ "' is unbound in type '" ++ name ++ "'."
101 let msg x = "Type variable '" ++ x ++ "' is unbound in type '" ++ name ++ "'."
139 toT = toTypeWith name tvarDict
102 toT = toTypeWith name tvarDict
140 in case pt of
103 in case pt of
141− LambdaPT t1 t2 -> (==>) <$> toT t1 <*> toT t2
104+ LambdaPT t1 t2 -> T.Lambda <$> toT t1 <*> toT t2
142− ADTPT name args -> ADT name <$> mapM toT args
105+ ADTPT name args -> T.Data name <$> mapM toT args
143 RecordPT t fs -> do fs' <- mapM (\(x,pt) -> (,) x <$> toT pt) fs
106 RecordPT t fs -> do fs' <- mapM (\(x,pt) -> (,) x <$> toT pt) fs
144− ext <- maybe (return EmptyRecord) toT t
107+ ext <- maybe (return T.EmptyRecord) toT t
145− return (RecordT (recordT fs') ext)
108+ return (T.Record (T.record fs') ext)
146 VarPT x@(c:_)
109 VarPT x@(c:_)
147− | not (isLower c) -> return $ ADT x []
110+ | not (isLower c) -> return $ T.Data x []
148− | otherwise -> VarT <$> case lookup x tvarDict of
111+ | otherwise -> T.Var <$> case lookup x tvarDict of
149− Just v -> Right v
112+ Just v -> Right v
150− Nothing -> Left (msg x)
113+ Nothing -> Left (msg x)
151
114
152
115
153toDatatype name args tcs = Datatype name [1..n] <$> mapM toC tcs
116toDatatype name args tcs = Datatype name [1..n] <$> mapM toC tcs
154 where n = length args
117 where n = length args
155− toType = toTypeWith name (zip args [1..n])
118+ toType = toTypeWith name (zip args (map (:[]) ['a'..]))
156 toC (name,pt) = (,) name <$> mapM toType pt
119 toC (name,pt) = (,) name <$> mapM toType pt
157
120
158
121
@@ -161,18 +124,19 @@ toForeignType (LambdaPT t1 t2) =
161 "Only simple values can be imported and exported in this release."
124 "Only simple values can be imported and exported in this release."
162
125
163toForeignType (ADTPT "JSArray" args) =
126toForeignType (ADTPT "JSArray" args) =
164− ADT "JSArray" <$> mapM toForeignType args
127+ T.Data "JSArray" <$> mapM toForeignType args
165
128
166toForeignType (ADTPT name _) =
129toForeignType (ADTPT name _) =
167 Left $ "'" ++ name ++ "' is not an exportable type " ++
130 Left $ "'" ++ name ++ "' is not an exportable type " ++
168 "constructor. Only 'JSArray' is exportable."
131 "constructor. Only 'JSArray' is exportable."
169
132
170toForeignType (VarPT x@(c:_))
133toForeignType (VarPT x@(c:_))
171− | x `elem` jsTypes = Right (ADT x [])
134+ | x `elem` jsTypes = Right (T.Data x [])
172 | isLower c =
135 | isLower c =
173 Left $ "All exported types must be concrete types." ++ msg
136 Left $ "All exported types must be concrete types." ++ msg
174 | otherwise =
137 | otherwise =
175 Left $ "'" ++ x ++ "' is not an exportable type." ++ msg
138 Left $ "'" ++ x ++ "' is not an exportable type." ++ msg
176 where
139 where
177 msg = " The following types are exportable: " ++ intercalate ", " jsTypes
140 msg = " The following types are exportable: " ++ intercalate ", " jsTypes
178− jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]
141+ jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]
142+--}
compiler/SourceSyntax/Declaration.hs+5−5
@@ -3,16 +3,16 @@ module SourceSyntax.Declaration where
3
3
4import Data.Data
4import Data.Data
5import qualified SourceSyntax.Expression as Expr
5import qualified SourceSyntax.Expression as Expr
6−import Types.Types
6+import SourceSyntax.Type
7
7
8data Declaration tipe var
8data Declaration tipe var
9 = Definition (Expr.Def tipe var)
9 = Definition (Expr.Def tipe var)
10− | Datatype String [X] [(String,[Type])]
10+ | Datatype String [String] [(String,[Type])]
11− | TypeAlias String [X] Type
11+ | TypeAlias String [String] Type
12 | ImportEvent String (Expr.LExpr tipe var) String Type
12 | ImportEvent String (Expr.LExpr tipe var) String Type
13 | ExportEvent String String Type
13 | ExportEvent String String Type
14 | Fixity Assoc Int String
14 | Fixity Assoc Int String
15− deriving (Eq, Show, Data, Typeable, Show)
15+ deriving (Eq, Show)
16
16
17data Assoc = L | N | R
17data Assoc = L | N | R
18− deriving (Eq, Show, Data, Typeable, Show)
18+ deriving (Eq, Show)
compiler/SourceSyntax/Expression.hs+34−36
@@ -1,16 +1,14 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
2module SourceSyntax.Expression where
1module SourceSyntax.Expression where
3
2
4−import Data.Data
5import Data.List (intercalate)
3import Data.List (intercalate)
6import qualified Text.Pandoc as Pandoc
4import qualified Text.Pandoc as Pandoc
7import SourceSyntax.PrettyPrint
5import SourceSyntax.PrettyPrint
8−import Text.PrettyPrint as PP
6+import Text.PrettyPrint as P
9import qualified SourceSyntax.Helpers as Help
7import qualified SourceSyntax.Helpers as Help
10import qualified SourceSyntax.Location as Location
8import qualified SourceSyntax.Location as Location
11import qualified SourceSyntax.Pattern as Pattern
9import qualified SourceSyntax.Pattern as Pattern
10+import qualified SourceSyntax.Type as Type
12import qualified SourceSyntax.Literal as Literal
11import qualified SourceSyntax.Literal as Literal
13−import Types.Types
14
12
15type LExpr tipe var = Location.Located (Expr tipe var)
13type LExpr tipe var = Location.Located (Expr tipe var)
16data Expr t v
14data Expr t v
@@ -31,12 +29,12 @@ data Expr t v
31 | Modify (LExpr t v) [(String, LExpr t v)]
29 | Modify (LExpr t v) [(String, LExpr t v)]
32 | Record [(String, LExpr t v)]
30 | Record [(String, LExpr t v)]
33 | Markdown Pandoc.Pandoc
31 | Markdown Pandoc.Pandoc
34− deriving (Eq, Data, Typeable, Show)
32+ deriving (Eq, Show)
35
33
36data Def tipe var
34data Def tipe var
37 = Def Pattern.Pattern (LExpr tipe var)
35 = Def Pattern.Pattern (LExpr tipe var)
38− | TypeAnnotation String Type
36+ | TypeAnnotation String Type.Type
39− deriving (Eq, Data, Typeable, Show)
37+ deriving (Eq, Show)
40
38
41tuple es = Data ("Tuple" ++ show (length es)) es
39tuple es = Data ("Tuple" ++ show (length es)) es
42
40
@@ -47,56 +45,56 @@ instance Pretty (Expr t v) where
47 pretty expr =
45 pretty expr =
48 case expr of
46 case expr of
49 Literal lit -> pretty lit
47 Literal lit -> pretty lit
50− Var x@(c:_) -> parensIf (Help.isOp c) (PP.text x)
48+ Var x@(c:_) -> parensIf (Help.isOp c) (P.text x)
51− Range e1 e2 -> PP.brackets (pretty e1 <> PP.text ".." <> pretty e2)
49+ Range e1 e2 -> P.brackets (pretty e1 <> P.text ".." <> pretty e2)
52− ExplicitList es -> PP.brackets (commaCat (map pretty es))
50+ ExplicitList es -> P.brackets (commaCat (map pretty es))
53− Binop op e1 e2 -> PP.sep [ prettyParens e1 <+> PP.text op, prettyParens e2 ]
51+ Binop op e1 e2 -> P.sep [ prettyParens e1 <+> P.text op, prettyParens e2 ]
54 Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)
52 Lambda p e -> let (ps,body) = collectLambdas (Location.none $ Lambda p e)
55− in PP.text "\\" <> PP.sep ps <+> PP.text "->" <+> pretty body
53+ in P.text "\\" <> P.sep ps <+> P.text "->" <+> pretty body
56− App _ _ -> PP.hang func 2 (PP.sep args)
54+ App _ _ -> P.hang func 2 (P.sep args)
57 where func:args = map prettyParens (collectApps (Location.none expr))
55 where func:args = map prettyParens (collectApps (Location.none expr))
58− MultiIf branches -> PP.text "if" $$ nest 3 (vcat $ map iff branches)
56+ MultiIf branches -> P.text "if" $$ nest 3 (vcat $ map iff branches)
59 where
57 where
60− iff (b,e) = PP.text "|" <+> PP.hang (pretty b <+> PP.text "->") 2 (pretty e)
58+ iff (b,e) = P.text "|" <+> P.hang (pretty b <+> P.text "->") 2 (pretty e)
61 Let defs e ->
59 Let defs e ->
62− PP.sep [ PP.hang (PP.text "let") 4 (PP.vcat (map pretty defs))
60+ P.sep [ P.hang (P.text "let") 4 (P.vcat (map pretty defs))
63− , PP.text "in" <+> pretty e ]
61+ , P.text "in" <+> pretty e ]
64 Case e pats ->
62 Case e pats ->
65− PP.hang pexpr 2 (PP.vcat (map pretty' pats))
63+ P.hang pexpr 2 (P.vcat (map pretty' pats))
66 where
64 where
67− pexpr = PP.sep [ PP.text "case" <+> pretty e, PP.text "of" ]
65+ pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]
68− pretty' (p,e) = pretty p <+> PP.text "->" <+> pretty e
66+ pretty' (p,e) = pretty p <+> P.text "->" <+> pretty e
69− Data "::" [hd,tl] -> pretty hd <+> PP.text "::" <+> pretty tl
67+ Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl
70− Data "[]" [] -> PP.text "[]"
68+ Data "[]" [] -> P.text "[]"
71− Data name es -> PP.hang (PP.text name) 2 (PP.sep (map prettyParens es))
69+ Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))
72− Access e x -> prettyParens e <> PP.text "." <> PP.text x
70+ Access e x -> prettyParens e <> P.text "." <> P.text x
73− Remove e x -> PP.braces (pretty e <+> PP.text "-" <+> PP.text x)
71+ Remove e x -> P.braces (pretty e <+> P.text "-" <+> P.text x)
74 Insert (Location.L _ _ (Remove e y)) x v ->
72 Insert (Location.L _ _ (Remove e y)) x v ->
75− PP.braces (pretty e <+> PP.text "-" <+> PP.text y <+> PP.text "|" <+> PP.text x <+> PP.text "=" <+> pretty v)
73+ P.braces (pretty e <+> P.text "-" <+> P.text y <+> P.text "|" <+> P.text x <+> P.text "=" <+> pretty v)
76 Insert e x v ->
74 Insert e x v ->
77− PP.braces (pretty e <+> PP.text "|" <+> PP.text x <+> PP.text "=" <+> pretty v)
75+ P.braces (pretty e <+> P.text "|" <+> P.text x <+> P.text "=" <+> pretty v)
78
76
79 Modify e fs ->
77 Modify e fs ->
80− PP.braces $ PP.hang (pretty e <+> PP.text "|")
78+ P.braces $ P.hang (pretty e <+> P.text "|")
81− 4
79+ 4
82− (PP.sep . PP.punctuate PP.comma $ map field fs)
80+ (P.sep . P.punctuate P.comma $ map field fs)
83 where
81 where
84− field (x,e) = PP.text x <+> PP.text "<-" <+> pretty e
82+ field (x,e) = P.text x <+> P.text "<-" <+> pretty e
85
83
86 Record fs ->
84 Record fs ->
87− PP.braces $ PP.nest 2 (PP.sep . PP.punctuate PP.comma $ map field fs)
85+ P.braces $ P.nest 2 (P.sep . P.punctuate P.comma $ map field fs)
88 where
86 where
89− field (x,e) = PP.text x <+> PP.text "=" <+> pretty e
87+ field (x,e) = P.text x <+> P.text "=" <+> pretty e
90
88
91− Markdown _ -> PP.text "[markdown| ... |]"
89+ Markdown _ -> P.text "[markdown| ... |]"
92
90
93instance Pretty (Def t v) where
91instance Pretty (Def t v) where
94 pretty def =
92 pretty def =
95 case def of
93 case def of
96 TypeAnnotation name tipe ->
94 TypeAnnotation name tipe ->
97− PP.text name <+> PP.text ":" <+> PP.text (show tipe)
95+ P.text name <+> P.text ":" <+> P.text (show tipe)
98 Def pattern expr ->
96 Def pattern expr ->
99− pretty pattern <+> PP.text "=" <+> pretty expr
97+ pretty pattern <+> P.text "=" <+> pretty expr
100
98
101collectApps lexpr@(Location.L _ _ expr) =
99collectApps lexpr@(Location.L _ _ expr) =
102 case expr of
100 case expr of
compiler/SourceSyntax/Type.hsnew file+51
@@ -0,0 +1,51 @@
1+
2+module SourceSyntax.Type where
3+
4+import qualified Data.Map as Map
5+import SourceSyntax.PrettyPrint
6+import Text.PrettyPrint as P
7+
8+data Type = Lambda Type Type
9+ | Var String
10+ | Data String [Type]
11+ | EmptyRecord
12+ | Record (Map.Map String [Type]) Type
13+ deriving (Eq, Show)
14+
15+fieldMap :: [(String,Type)] -> Map.Map String [Type]
16+fieldMap fields =
17+ foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields
18+
19+recordOf :: [(String,Type)] -> Type
20+recordOf fields = Record (fieldMap fields) EmptyRecord
21+
22+listOf :: Type -> Type
23+listOf t = Data "List" [t]
24+
25+tupleOf :: [Type] -> Type
26+tupleOf ts = Data ("Tuple" ++ show (length ts)) ts
27+
28+
29+instance Pretty Type where
30+ pretty tipe =
31+ case tipe of
32+ Lambda t1 t2 -> P.sep [ t, P.sep (map (P.text "->" <+>) ts) ]
33+ where t:ts = collectLambdas tipe
34+ Var x -> P.text x
35+ Data name tipes -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)
36+ EmptyRecord -> P.braces P.empty
37+ Record fields ext -> error "not done yet"
38+
39+collectLambdas tipe =
40+ case tipe of
41+ Lambda arg@(Lambda _ _) body -> P.parens (pretty arg) : collectLambdas body
42+ Lambda arg body -> pretty arg : collectLambdas body
43+ _ -> [pretty tipe]
44+
45+prettyParens tipe = parensIf needed (pretty tipe)
46+ where
47+ needed =
48+ case tipe of
49+ Lambda _ _ -> True
50+ Data _ _ -> True
51+ _ -> False