git.iko.soy/elk
on master help sign in
Take steps to allow higher kinded polymorphism
e2a0b46Evan Czaplicki
compiler/AST/Module.hs+4−1
compare with master
unifiedsplit
@@ -44,8 +44,11 @@ type CanonicalModule = Module [Var.Value] CanonicalBody
44type Interfaces = Map.Map String Interface
44type Interfaces = Map.Map String Interface
45
45
46type Types = Map.Map String Type.CanonicalType
46type Types = Map.Map String Type.CanonicalType
47−type ADTs = Map.Map String ( [String], [(String, [Type.CanonicalType])] )
48type Aliases = Map.Map String ( [String], Type.CanonicalType )
47type Aliases = Map.Map String ( [String], Type.CanonicalType )
48+type ADTs = Map.Map String (AdtInfo String)
49+
50+type AdtInfo v = ( [String], [(v, [Type.CanonicalType])] )
51+type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical)
49
52
50data Interface = Interface
53data Interface = Interface
51 { iVersion :: Version.Version
54 { iVersion :: Version.Version
compiler/AST/Type.hs+34−20
@@ -13,7 +13,8 @@ import Text.PrettyPrint as P
13data Type var
13data Type var
14 = Lambda (Type var) (Type var)
14 = Lambda (Type var) (Type var)
15 | Var String
15 | Var String
16+ | Type var
16− | Data var [Type var]
17+ | App (Type var) [Type var]
17 | Record [(String, Type var)] (Maybe (Type var))
18 | Record [(String, Type var)] (Maybe (Type var))
18 | Aliased Var.Canonical (Type var)
19 | Aliased Var.Canonical (Type var)
19 deriving (Eq,Show)
20 deriving (Eq,Show)
@@ -29,10 +30,12 @@ recordOf :: [(String, Type var)] -> Type var
29recordOf fields = Record fields Nothing
30recordOf fields = Record fields Nothing
30
31
31listOf :: RawType -> RawType
32listOf :: RawType -> RawType
32−listOf t = Data (Var.Raw "_List") [t]
33+listOf t = App (Type (Var.Raw "_List")) [t]
33
34
34tupleOf :: [RawType] -> RawType
35tupleOf :: [RawType] -> RawType
36+tupleOf ts = App (Type t) ts
37+ where
35−tupleOf ts = Data (Var.Raw $ "_Tuple" ++ show (length ts)) ts
38+ t = Var.Raw ("_Tuple" ++ show (length ts))
36
39
37instance (Var.ToString var, Pretty var) => Pretty (Type var) where
40instance (Var.ToString var, Pretty var) => Pretty (Type var) where
38 pretty tipe =
41 pretty tipe =
@@ -46,14 +49,18 @@ instance (Var.ToString var, Pretty var) => Pretty (Type var) where
46
49
47 Var x -> P.text x
50 Var x -> P.text x
48
51
52+ Type v -> P.text (Var.toString v)
53+
54+ App f args ->
55+ case (f,args) of
56+ (Type name, [t])
49− Data name [t] | Var.toString name == "_List" ->
57+ | Var.toString name == "_List" -> P.brackets (pretty t)
50− P.brackets (pretty t)
58+
59+ (Type name, _)
60+ | Help.isTuple (Var.toString name) ->
61+ P.parens . P.sep . P.punctuate P.comma $ map pretty args
51
62
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)
63+ _ -> P.hang (pretty f) 2 (P.sep $ map prettyParens args)
57
64
58 Record _ _ ->
65 Record _ _ ->
59 P.braces $ case flattenRecord tipe of
66 P.braces $ case flattenRecord tipe of
@@ -78,10 +85,14 @@ prettyParens tipe = parensIf (needed tipe) (pretty tipe)
78 needed t =
85 needed t =
79 case t of
86 case t of
80 Aliased _ t' -> needed t'
87 Aliased _ t' -> needed t'
88+
81 Lambda _ _ -> True
89 Lambda _ _ -> True
90+
82− Data name [_] | Var.toString name == "_List" -> False
91+ App (Type name) [_] | Var.toString name == "_List" -> False
83− Data _ [] -> False
92+ App (Type name) _ | Help.isTuple (Var.toString name) -> False
93+ App t' [] -> needed t'
84− Data _ _ -> True
94+ App _ _ -> True
95+
85 _ -> False
96 _ -> False
86
97
87flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
98flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )
@@ -106,19 +117,22 @@ instance Binary var => Binary (Type var) where
106 putWord8 0 >> put t1 >> put t2
117 putWord8 0 >> put t1 >> put t2
107 Var x ->
118 Var x ->
108 putWord8 1 >> put x
119 putWord8 1 >> put x
109− Data ctor tipes ->
120+ Type name ->
110− putWord8 2 >> put ctor >> put tipes
121+ putWord8 2 >> put name
122+ App t1 t2 ->
123+ putWord8 3 >> put t1 >> put t2
111 Record fs ext ->
124 Record fs ext ->
112− putWord8 3 >> put fs >> put ext
125+ putWord8 4 >> put fs >> put ext
113 Aliased var t ->
126 Aliased var t ->
114− putWord8 4 >> put var >> put t
127+ putWord8 5 >> put var >> put t
115
128
116 get = do
129 get = do
117 n <- getWord8
130 n <- getWord8
118 case n of
131 case n of
119 0 -> Lambda <$> get <*> get
132 0 -> Lambda <$> get <*> get
120 1 -> Var <$> get
133 1 -> Var <$> get
121− 2 -> Data <$> get <*> get
134+ 2 -> Type <$> get
135+ 3 -> App <$> get <*> get
122− 3 -> Record <$> get <*> get
136+ 4 -> Record <$> get <*> get
123− 4 -> Aliased <$> get <*> get
137+ 5 -> Aliased <$> get <*> get
124 _ -> error "Error reading a valid type from serialized string"
138 _ -> error "Error reading a valid type from serialized string"
compiler/Generate/JavaScript/Ports.hs+55−51
@@ -2,7 +2,6 @@
2module Generate.JavaScript.Ports (incoming, outgoing) where
2module Generate.JavaScript.Ports (incoming, outgoing) where
3
3
4import Generate.JavaScript.Helpers
4import Generate.JavaScript.Helpers
5−import qualified AST.Helpers as Help
6import AST.Type as T
5import AST.Type as T
7import qualified AST.Variable as Var
6import qualified AST.Variable as Var
8import Language.ECMAScript3.Syntax
7import Language.ECMAScript3.Syntax
@@ -29,8 +28,8 @@ incoming tipe =
29 case tipe of
28 case tipe of
30 Aliased _ t -> incoming t
29 Aliased _ t -> incoming t
31
30
32− Data (Var.Canonical (Var.Module "Signal") "Signal") [t] ->
31+ App (Type v) [t]
33− obj "Native.Ports.incomingSignal" <| incoming t
32+ | Var.isSignal v -> obj "Native.Ports.incomingSignal" <| incoming t
34
33
35 _ -> ["v"] ==> inc tipe (ref "v")
34 _ -> ["v"] ==> inc tipe (ref "v")
36
35
@@ -42,42 +41,44 @@ inc tipe x =
42 Aliased _ t ->
41 Aliased _ t ->
43 inc t x
42 inc t x
44
43
45− Data (Var.Canonical (Var.Module "Json") "Value") [] ->
46− obj "Native.Json.fromJS" <| x
47−
48− Data (Var.Canonical Var.BuiltIn ctor) []
44+ Type (Var.Canonical Var.BuiltIn name)
49− | ctor == "Int" -> from JSNumber
45+ | name == "Int" -> from JSNumber
50− | ctor == "Float" -> from JSNumber
46+ | name == "Float" -> from JSNumber
51− | ctor == "Bool" -> from JSBoolean
47+ | name == "Bool" -> from JSBoolean
52− | ctor == "String" -> from JSString
48+ | name == "String" -> from JSString
53 where
49 where
54 from checks = check x checks x
50 from checks = check x checks x
55
51
56− Data (Var.Canonical (Var.Module "Maybe") "Maybe") [t] ->
52+ Type name
57− CondExpr () (equal x (NullLit ()))
53+ | Var.isJson name -> obj "Native.Json.fromJS" <| x
58− (obj "Maybe.Nothing")
54+ | otherwise -> error "bad type got to incoming port generation code"
59− (obj "Maybe.Just" <| inc t x)
60
55
61− Data (Var.Canonical Var.BuiltIn ctor) [t]
56+ App f args ->
62− | ctor == "_List" ->
57+ case f : args of
63− check x JSArray (obj "_L.fromArray" <| array)
58+ Type name : [t]
59+ | Var.isMaybe name -> CondExpr () (equal x (NullLit ()))
60+ (obj "Maybe.Nothing")
61+ (obj "Maybe.Just" <| inc t x)
64
62
65− | ctor == "Array.Array" ->
66− check x JSArray (obj "_A.fromJSArray" <| array)
63+ | Var.isList name -> check x JSArray (obj "_L.fromArray" <| array)
67
64
65+ | Var.isArray name -> check x JSArray (obj "_A.fromJSArray" <| array)
68− where
66+ where
69− array = DotRef () x (var "map") <| incoming t
67+ array = DotRef () x (var "map") <| incoming t
70
68
71− Data (Var.Canonical Var.BuiltIn ctor) ts
69+ Type name : ts
72− | Help.isTuple ctor -> check x JSArray tuple
70+ | Var.isTuple name -> check x JSArray tuple
73− where
71+ where
74− tuple = ObjectLit () $ (prop "ctor", string ctor) : values
72+ tuple = ObjectLit () $ (prop "ctor", ctor) : values
73+
74+ ctor = string ("_Tuple" ++ show (length ts))
75− values = zipWith convert [0..] ts
75+ values = zipWith convert [0..] ts
76+
76− convert n t = ( prop ('_':show n)
77+ convert n t = ( prop ('_':show n)
77− , inc t (BracketRef () x (IntLit () n)))
78+ , inc t (BracketRef () x (IntLit () n))
79+ )
78
80
79− Data _ _ ->
80− error "bad ADT got to incoming port generation code"
81+ _ -> error "bad ADT got to incoming port generation code"
81
82
82 Record _ (Just _) ->
83 Record _ (Just _) ->
83 error "bad record got to incoming port generation code"
84 error "bad record got to incoming port generation code"
@@ -94,8 +95,8 @@ outgoing tipe =
94 case tipe of
95 case tipe of
95 Aliased _ t -> outgoing t
96 Aliased _ t -> outgoing t
96
97
97− Data (Var.Canonical (Var.Module "Signal") "Signal") [t] ->
98+ App (Type v) [t]
98− obj "Native.Ports.outgoingSignal" <| outgoing t
99+ | Var.isSignal v -> obj "Native.Ports.outgoingSignal" <| outgoing t
99
100
100 _ -> ["v"] ==> out tipe (ref "v")
101 _ -> ["v"] ==> out tipe (ref "v")
101
102
@@ -120,30 +121,33 @@ out tipe x =
120
121
121 Var _ -> error "type variables should not be allowed through input ports"
122 Var _ -> error "type variables should not be allowed through input ports"
122
123
123− Data (Var.Canonical Var.BuiltIn ctor) []
124+ Type (Var.Canonical Var.BuiltIn name)
124− | ctor `elem` ["Int","Float","Bool","String"] -> x
125+ | name `elem` ["Int","Float","Bool","String"] -> x
125
126
126− Data (Var.Canonical (Var.Module "Json") "Value") [] ->
127+ Type name
127− obj "Native.Json.toJS" <| x
128+ | Var.isJson name -> obj "Native.Json.toJS" <| x
129+ | otherwise -> error "bad type got to outgoing port generation code"
128
130
129− Data (Var.Canonical (Var.Module "Maybe") "Maybe") [t] ->
131+ App f args ->
132+ case f : args of
133+ Type name : [t]
134+ | Var.isMaybe name ->
130− CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
135+ CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))
131− (NullLit ())
136+ (NullLit ())
132− (out t (DotRef () x (var "_0")))
137+ (out t (DotRef () x (var "_0")))
133
138
134− Data (Var.Canonical (Var.Module "Array") "Array") [t] ->
139+ | Var.isArray name ->
135− DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t
140+ DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t
136
141
137− Data (Var.Canonical Var.BuiltIn "_List") [t] ->
142+ | Var.isList name ->
138− DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t
143+ DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t
139
144
140− Data (Var.Canonical Var.BuiltIn ctor) ts
145+ Type name : ts
141− | Help.isTuple ctor ->
146+ | Var.isTuple name ->
142− let convert n t = out t $ DotRef () x $ var ('_':show n)
147+ let convert n t = out t $ DotRef () x $ var ('_':show n)
143− in ArrayLit () $ zipWith convert [0..] ts
148+ in ArrayLit () $ zipWith convert [0..] ts
144
149
145− Data _ _ ->
146− error "bad ADT got to outgoing port generation code"
150+ _ -> error "bad ADT got to outgoing port generation code"
147
151
148 Record _ (Just _) ->
152 Record _ (Just _) ->
149 error "bad record got to outgoing port generation code"
153 error "bad record got to outgoing port generation code"
compiler/Parse/Type.hs+7−4
@@ -47,20 +47,23 @@ capTypeVar = intercalate "." <$> dotSep1 capVar
47constructor0 :: IParser T.RawType
47constructor0 :: IParser T.RawType
48constructor0 =
48constructor0 =
49 do name <- capTypeVar
49 do name <- capTypeVar
50− return (T.Data (Var.Raw name) [])
50+ return (T.Type (Var.Raw name))
51
51
52term :: IParser T.RawType
52term :: IParser T.RawType
53term = list <|> tuple <|> record <|> tvar <|> constructor0
53term = list <|> tuple <|> record <|> tvar <|> constructor0
54
54
55app :: IParser T.RawType
55app :: IParser T.RawType
56app =
56app =
57− do name <- capTypeVar <|> try tupleCtor <?> "type constructor"
57+ do f <- constructor0 <|> tvar <|> try tupleCtor <?> "type constructor"
58 args <- spacePrefix term
58 args <- spacePrefix term
59− return (T.Data (Var.Raw name) args)
59+ return $ case args of
60+ [] -> f
61+ _ -> T.App f args
60 where
62 where
61 tupleCtor = do
63 tupleCtor = do
62 n <- length <$> parens (many (char ','))
64 n <- length <$> parens (many (char ','))
63− return $ "_Tuple" ++ show (if n == 0 then 0 else n+1)
65+ let ctor = "_Tuple" ++ show (if n == 0 then 0 else n+1)
66+ return (T.Type (Var.Raw ctor))
64
67
65expr :: IParser T.RawType
68expr :: IParser T.RawType
66expr =
69expr =
compiler/Transform/Canonicalize/Type.hs+51−51
@@ -1,8 +1,9 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2−module Transform.Canonicalize.Type where
2+module Transform.Canonicalize.Type (tipe) where
3
3
4import Control.Arrow (second)
4import Control.Arrow (second)
5import Control.Applicative ((<$>),(<*>))
5import Control.Applicative ((<$>),(<*>))
6+import Control.Monad (when)
6import qualified Data.Map as Map
7import qualified Data.Map as Map
7import Data.Traversable (traverse)
8import Data.Traversable (traverse)
8
9
@@ -16,56 +17,55 @@ tipe :: Environment -> T.RawType -> Either String T.CanonicalType
16tipe env typ =
17tipe env typ =
17 let go = tipe env in
18 let go = tipe env in
18 case typ of
19 case typ of
19− T.Lambda a b ->
20+ T.Var x -> return (T.Var x)
20− T.Lambda <$> go a <*> go b
21+ T.Type _ -> canonicalizeApp env typ []
22+ T.App t ts -> canonicalizeApp env t ts
21
23
22− T.Var x ->
24+ T.Lambda a b -> T.Lambda <$> go a <*> go b
23− return (T.Var x)
25+ T.Aliased name t -> T.Aliased name <$> go t
24
26
25 T.Record fields ext ->
27 T.Record fields ext ->
28+ let go' (f,t) = (,) f <$> go t
26− T.Record <$> mapM go' fields <*> traverse go ext
29+ in T.Record <$> mapM go' fields <*> traverse go ext
27− where
30+
28− go' (f,t) = (,) f <$> go t
31+canonicalizeApp :: Environment -> T.RawType -> [T.RawType]
29−
32+ -> Either String T.CanonicalType
30− T.Aliased name t ->
33+canonicalizeApp env f args =
31− T.Aliased name <$> go t
34+ case f of
32−
33− T.Data (Var.Raw name) ts ->
35+ T.Type (Var.Raw rawName) ->
34− case tvar env name of
36+ do answer <- tvar env rawName
35− Left err -> Left err
37+ case answer of
36−
38+ Right alias -> canonicalizeAlias env alias args
37− Right (Left name') ->
39+ Left name -> case args of
38− T.Data name' <$> mapM go ts
40+ [] -> return (T.Type name)
39−
41+ _:_ -> T.App (T.Type name) <$> mapM (tipe env) args
40− Right (Right (name', tvars, t))
42+
43+ _ -> T.App <$> tipe env f <*> mapM (tipe env) args
44+
45+canonicalizeAlias :: Environment -> (Var.Canonical, [String], T.CanonicalType)
46+ -> [T.RawType]
47+ -> Either String T.CanonicalType
48+canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =
41− | tsLen /= tvarsLen -> Left msg
49+ do when (tipesLen /= tvarsLen) (Left msg)
42− | otherwise ->
50+ tipes' <- mapM (tipe env) tipes
43− do ts' <- mapM go ts
44− let t' = replace (Map.fromList (zip tvars ts')) t
51+ let tipe' = replace (Map.fromList (zip tvars tipes')) dealiasedTipe
45− return $ T.Aliased name' t'
52+ return $ T.Aliased name tipe'
46− where
53+ where
47− tsLen = length ts
54+ tipesLen = length tipes
48− tvarsLen = length tvars
55+ tvarsLen = length tvars
49−
56+
57+ msg :: String
50− msg = "Type alias '" ++ name ++ "' expects " ++ show tvarsLen ++
58+ msg = "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++
51− " type argument" ++ (if tvarsLen == 1 then "" else "s") ++
59+ " type argument" ++ (if tvarsLen == 1 then "" else "s") ++
52− " but was given " ++ show tsLen
60+ " but was given " ++ show tipesLen
53−
61+
54−replace :: Map.Map String T.CanonicalType -> T.CanonicalType -> T.CanonicalType
62+ replace :: Map.Map String T.CanonicalType -> T.CanonicalType -> T.CanonicalType
55−replace typeTable t =
63+ replace typeTable t =
56− let go = replace typeTable in
64+ let go = replace typeTable in
57− case t of
65+ case t of
58− T.Lambda a b ->
59− T.Lambda (go a) (go b)
66+ T.Lambda a b -> T.Lambda (go a) (go b)
60−
61− T.Var x ->
62− Map.findWithDefault t x typeTable
67+ T.Var x -> Map.findWithDefault t x typeTable
63−
64− T.Record fields ext ->
65− T.Record (map (second go) fields) (fmap go ext)
68+ T.Record fields ext -> T.Record (map (second go) fields) (fmap go ext)
66−
67− T.Aliased original t' ->
68− T.Aliased original (go t')
69+ T.Aliased original t' -> T.Aliased original (go t')
69−
70+ T.Type _ -> t
70− T.Data name ts ->
71+ T.App f args -> T.App (go f) (map go args)
71− T.Data name (map go ts)
compiler/Transform/Check.hs+4−2
@@ -79,7 +79,8 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
79 case tipe of
79 case tipe of
80 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
80 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)
81 T.Var x -> Set.singleton x
81 T.Var x -> Set.singleton x
82+ T.Type _ -> Set.empty
82− T.Data _ ts -> Set.unions (map freeVars ts)
83+ T.App t ts -> Set.unions (map freeVars (t:ts))
83 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
84 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)
84 where ext' = maybe Set.empty freeVars ext
85 where ext' = maybe Set.empty freeVars ext
85 T.Aliased _ t -> freeVars t
86 T.Aliased _ t -> freeVars t
@@ -126,7 +127,8 @@ infiniteTypeAliases decls =
126 case tipe of
127 case tipe of
127 T.Lambda a b -> infinite a || infinite b
128 T.Lambda a b -> infinite a || infinite b
128 T.Var _ -> False
129 T.Var _ -> False
129− T.Data (Var.Raw name') ts -> name == name' || any infinite ts
130+ T.Type (Var.Raw name') -> name == name'
131+ T.App t ts -> any infinite (t:ts)
130 T.Record fields _ -> any (infinite . snd) fields
132 T.Record fields _ -> any (infinite . snd) fields
131 T.Aliased _ t -> infinite t
133 T.Aliased _ t -> infinite t
132
134
compiler/Transform/Declaration.hs+6−5
@@ -70,11 +70,12 @@ combineAnnotations = go
70 _ -> (:) (D.Port (D.In name tipe)) <$> go portRest
70 _ -> (:) (D.Port (D.In name tipe)) <$> go portRest
71
71
72
72
73−toExpr :: [D.CanonicalDecl] -> [Canonical.Def]
73+toExpr :: String -> [D.CanonicalDecl] -> [Canonical.Def]
74−toExpr = concatMap toDefs
74+toExpr moduleName = concatMap (toDefs moduleName)
75
75
76−toDefs :: D.CanonicalDecl -> [Canonical.Def]
76+toDefs :: String -> D.CanonicalDecl -> [Canonical.Def]
77−toDefs decl =
77+toDefs moduleName decl =
78+ let typeVar = Var.Canonical (Var.Module moduleName) in
78 case decl of
79 case decl of
79 D.Definition def -> [def]
80 D.Definition def -> [def]
80
81
@@ -82,7 +83,7 @@ toDefs decl =
82 where
83 where
83 toDefs' (ctor, tipes) =
84 toDefs' (ctor, tipes) =
84 let vars = take (length tipes) arguments
85 let vars = take (length tipes) arguments
85− tbody = T.Data (Var.local name) $ map T.Var tvars
86+ tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)
86 body = A.none . E.Data ctor $ map (A.none . E.localVar) vars
87 body = A.none . E.Data ctor $ map (A.none . E.localVar) vars
87 in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
88 in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
88
89
compiler/Type/ExtraChecks.hs+22−21
@@ -1,4 +1,4 @@
1−{-# OPTIONS_GHC -W #-}
1+{-# OPTIONS_GHC -Wall #-}
2
2
3{-| This module contains checks to be run *after* type inference has completed
3{-| This module contains checks to be run *after* type inference has completed
4successfully. At that point we still need to do occurs checks and ensure that
4successfully. At that point we still need to do occurs checks and ensure that
@@ -14,9 +14,7 @@ import qualified Data.UnionFind.IO as UF
14import Text.PrettyPrint as P
14import Text.PrettyPrint as P
15
15
16import qualified AST.Annotation as A
16import qualified AST.Annotation as A
17−import qualified AST.Expression.General as E
18import qualified AST.Expression.Canonical as Canonical
17import qualified AST.Expression.Canonical as Canonical
19−import qualified AST.Helpers as Help
20import qualified AST.PrettyPrint as PP
18import qualified AST.PrettyPrint as PP
21import qualified AST.Type as ST
19import qualified AST.Type as ST
22import qualified AST.Variable as V
20import qualified AST.Variable as V
@@ -25,26 +23,28 @@ import qualified Type.Type as TT
25import qualified Type.State as TS
23import qualified Type.State as TS
26import qualified Type.Alias as Alias
24import qualified Type.Alias as Alias
27
25
26+throw :: [Doc] -> Either [Doc] a
28throw err = Left [ P.vcat err ]
27throw err = Left [ P.vcat err ]
29
28
30mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.CanonicalType))
29mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.CanonicalType))
30+mainType aliasRules environment =
31−mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env
31+ mainCheck aliasRules <$> Traverse.traverse TT.toSrcType environment
32 where
32 where
33 mainCheck :: Alias.Rules -> Map.Map String ST.CanonicalType -> Either [P.Doc] (Map.Map String ST.CanonicalType)
33 mainCheck :: Alias.Rules -> Map.Map String ST.CanonicalType -> Either [P.Doc] (Map.Map String ST.CanonicalType)
34 mainCheck rules env =
34 mainCheck rules env =
35 case Map.lookup "main" env of
35 case Map.lookup "main" env of
36 Nothing -> Right env
36 Nothing -> Right env
37− Just mainType
37+ Just typeOfMain
38 | tipe `elem` acceptable -> Right env
38 | tipe `elem` acceptable -> Right env
39 | otherwise -> throw err
39 | otherwise -> throw err
40 where
40 where
41 acceptable = [ "Graphics.Element.Element"
41 acceptable = [ "Graphics.Element.Element"
42 , "Signal.Signal Graphics.Element.Element" ]
42 , "Signal.Signal Graphics.Element.Element" ]
43
43
44− tipe = PP.renderPretty $ Alias.canonicalRealias (fst rules) mainType
44+ tipe = PP.renderPretty $ Alias.canonicalRealias (fst rules) typeOfMain
45 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
45 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
46 , P.text "Instead 'main' has type:\n"
46 , P.text "Instead 'main' has type:\n"
47− , P.nest 4 . PP.pretty $ Alias.realias rules mainType
47+ , P.nest 4 . PP.pretty $ Alias.realias rules typeOfMain
48 , P.text " " ]
48 , P.text " " ]
49
49
50data Direction = In | Out
50data Direction = In | Out
@@ -56,24 +56,25 @@ portTypes rules expr =
56 check = isValid True False False
56 check = isValid True False False
57 isValid isTopLevel seenFunc seenSignal direction name tipe =
57 isValid isTopLevel seenFunc seenSignal direction name tipe =
58 case tipe of
58 case tipe of
59− ST.Data (V.Canonical (V.Module "Signal") "Signal") [t] ->
59+ ST.Aliased _ t -> valid t
60− handleSignal t
61
60
62− ST.Data (V.Canonical (V.Module "Maybe") "Maybe") [t] ->
61+ ST.Type v
63− valid t
62+ | V.isJson v -> return ()
63+ | V.isPrimitive v -> return ()
64+ | otherwise -> err' True "an unsupported type"
64
65
65− ST.Data (V.Canonical (V.Module "Array") "Array") [t] ->
66− valid t
66+ ST.App t [] -> valid t
67
67
68− ST.Data (V.Canonical (V.Module "Json") "Value") [] ->
68+ ST.App (ST.Type v) [t]
69− return ()
69+ | V.isSignal v -> handleSignal t
70+ | V.isMaybe v -> valid t
71+ | V.isArray v -> valid t
72+ | V.isList v -> valid t
70
73
71− ST.Data (V.Canonical V.BuiltIn ctor) ts
74+ ST.App (ST.Type v) ts
72− | ctor `elem` primitives || Help.isTuple ctor -> mapM_ valid ts
75+ | V.isTuple v -> mapM_ valid ts
73− where
74− primitives = ["Int","Float","String","Bool","_List"]
75
76
76− ST.Data _ _ -> err' True "an unsupported type"
77+ ST.App _ _ -> err' True "an unsupported type"
77
78
78 ST.Var _ -> err "free type variables"
79 ST.Var _ -> err "free type variables"
79
80
@@ -130,7 +131,7 @@ occurs (name, variable) =
130 desc <- liftIO $ UF.descriptor var
131 desc <- liftIO $ UF.descriptor var
131 case TT.structure desc of
132 case TT.structure desc of
132 Nothing ->
133 Nothing ->
133− modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
134+ modify $ \s -> s { TS.sErrors = fallback : TS.sErrors s }
134 Just _ ->
135 Just _ ->
135 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
136 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
136 var' <- liftIO $ UF.fresh desc
137 var' <- liftIO $ UF.fresh desc
tests/compiler/Tests/Property/Arbitrary.hs+5−2
@@ -89,7 +89,8 @@ instance Arbitrary v => Arbitrary (T.Type v) where
89 oneof
89 oneof
90 [ T.Lambda <$> depthTipe <*> depthTipe
90 [ T.Lambda <$> depthTipe <*> depthTipe
91 , T.Var <$> lowVar
91 , T.Var <$> lowVar
92+ , T.Type <$> arbitrary
92− , T.Data <$> arbitrary <*> genVector n tipe
93+ , T.App <$> arbitrary <*> genVector n tipe
93 , T.Record <$> fields <*> pure Nothing
94 , T.Record <$> fields <*> pure Nothing
94 , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar)
95 , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar)
95 ]
96 ]
@@ -98,7 +99,9 @@ instance Arbitrary v => Arbitrary (T.Type v) where
98 case tipe of
99 case tipe of
99 T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)
100 T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)
100 T.Var _ -> []
101 T.Var _ -> []
102+ T.Aliased _ t -> [t]
103+ T.Type _ -> []
101− T.Data n ts -> ts ++ (T.Data <$> shrink n <*> shrink ts)
104+ T.App t ts -> t : ts ++ (T.App <$> shrink t <*> shrink ts)
102 T.Record fs t -> map snd fs ++ record
105 T.Record fs t -> map snd fs ++ record
103 where
106 where
104 record =
107 record =