git.iko.soy/elk
on master help sign in
Make mainType check able to handle any aliases
94b3091Evan Czaplicki
src/AST/Variable.hs+5
compare with master
unifiedsplit
@@ -37,6 +37,11 @@ builtin :: String -> Canonical
37builtin x = Canonical BuiltIn x
37builtin x = Canonical BuiltIn x
38
38
39
39
40+fromModule :: [String] -> String -> Canonical
41+fromModule home name =
42+ Canonical (Module home) name
43+
44+
40-- VARIABLE RECOGNIZERS
45-- VARIABLE RECOGNIZERS
41
46
42is :: [String] -> String -> Canonical -> Bool
47is :: [String] -> String -> Canonical -> Bool
src/Type/ExtraChecks.hs+88−39
@@ -18,7 +18,7 @@ import qualified AST.Annotation as A
18import qualified AST.Expression.Canonical as Canonical
18import qualified AST.Expression.Canonical as Canonical
19import qualified AST.PrettyPrint as PP
19import qualified AST.PrettyPrint as PP
20import qualified AST.Type as ST
20import qualified AST.Type as ST
21−import qualified AST.Variable as V
21+import qualified AST.Variable as Var
22import qualified Transform.Expression as Expr
22import qualified Transform.Expression as Expr
23import qualified Type.Hint as Hint
23import qualified Type.Hint as Hint
24import qualified Type.Type as TT
24import qualified Type.Type as TT
@@ -30,42 +30,91 @@ throw err =
30 Left [ P.vcat err ]
30 Left [ P.vcat err ]
31
31
32
32
33+-- MAIN TYPE
34+
33mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
35mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
34mainType environment =
36mainType environment =
35 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
37 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
36 mainCheck environment'
38 mainCheck environment'
37− where
38− mainCheck
39− :: (Monad m) => Map.Map String ST.CanonicalType
40− -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
41− mainCheck env =
42− case Map.lookup "main" env of
43− Nothing -> return env
44− Just typeOfMain
45− | tipe `elem` acceptable -> return env
46− | otherwise -> throwError [ err ]
47− where
48− acceptable =
49− [ "Graphics.Element.Element"
50− , "Signal.Signal Graphics.Element.Element"
51− , "Html.Html"
52− , "Signal.Signal Html.Html"
53− ]
54−
55− tipe = PP.renderPretty typeOfMain
56−
57− err =
58− P.vcat
59− [ P.text "Type Error: 'main' must have one of the following types:"
60− , P.text " "
61− , P.text " Element, Html, Signal Element, Signal Html"
62− , P.text " "
63− , P.text "Instead 'main' has type:\n"
64− , P.nest 4 (PP.pretty typeOfMain)
65− , P.text " "
66− ]
67
39
68
40
41+mainCheck
42+ :: (Monad m)
43+ => Map.Map String ST.CanonicalType
44+ -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
45+mainCheck env =
46+ case Map.lookup "main" env of
47+ Nothing ->
48+ return env
49+
50+ Just typeOfMain ->
51+ let tipe = ST.dealias typeOfMain
52+ in
53+ if tipe `elem` validMainTypes
54+ then return env
55+ else throwError [ badMainMessage typeOfMain ]
56+
57+
58+validMainTypes :: [ST.CanonicalType]
59+validMainTypes =
60+ [ element
61+ , html
62+ , varying element
63+ , varying html
64+ ]
65+ where
66+ fromModule :: [String] -> String -> ST.CanonicalType
67+ fromModule home name =
68+ ST.Type (Var.fromModule home name)
69+
70+ html =
71+ fromModule ["VirtualDom"] "Node"
72+
73+ varying tipe =
74+ ST.App (fromModule ["Signal"] "Varying") [ tipe ]
75+
76+ element =
77+ let builtin name =
78+ ST.Type (Var.builtin name)
79+
80+ maybe tipe =
81+ ST.App (fromModule ["Maybe"] "Maybe") [ tipe ]
82+ in
83+ ST.Record
84+ [ ("element", fromModule ["Graphics","Element"] "ElementPrim")
85+ , ("props",
86+ ST.Record
87+ [ ("click" , builtin "_Tuple0")
88+ , ("color" , maybe (fromModule ["Color"] "Color"))
89+ , ("height" , builtin "Int")
90+ , ("hover" , builtin "_Tuple0")
91+ , ("href" , builtin "String")
92+ , ("id" , builtin "Int")
93+ , ("opacity", builtin "Float")
94+ , ("tag" , builtin "String")
95+ , ("width" , builtin "Int")
96+ ]
97+ Nothing
98+ )
99+ ]
100+ Nothing
101+
102+
103+badMainMessage :: ST.CanonicalType -> P.Doc
104+badMainMessage typeOfMain =
105+ P.vcat
106+ [ P.text "Type Error: 'main' must have one of the following types:"
107+ , P.text " "
108+ , P.text " Element, Html, Varying Element, Varying Html"
109+ , P.text " "
110+ , P.text "Instead 'main' has type:\n"
111+ , P.nest 4 (PP.pretty typeOfMain)
112+ , P.text " "
113+ ]
114+
115+
116+-- PORT TYPES
117+
69data Direction = In | Out
118data Direction = In | Out
70
119
71
120
@@ -81,27 +130,27 @@ portTypes expr =
81 ST.Aliased _ t -> valid t
130 ST.Aliased _ t -> valid t
82
131
83 ST.Type v ->
132 ST.Type v ->
84− case any ($ v) [ V.isJson, V.isPrimitive, V.isTuple ] of
133+ case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of
85 True -> return ()
134 True -> return ()
86 False -> err "an unsupported type"
135 False -> err "an unsupported type"
87
136
88 ST.App t [] -> valid t
137 ST.App t [] -> valid t
89
138
90 ST.App (ST.Type v) [t]
139 ST.App (ST.Type v) [t]
91− | V.isSignal v -> handleSignal t
140+ | Var.isSignal v -> handleSignal t
92− | V.isMaybe v -> valid t
141+ | Var.isMaybe v -> valid t
93− | V.isArray v -> valid t
142+ | Var.isArray v -> valid t
94− | V.isList v -> valid t
143+ | Var.isList v -> valid t
95
144
96 ST.App (ST.Type v) [_, _]
145 ST.App (ST.Type v) [_, _]
97− | V.isPromise v ->
146+ | Var.isPromise v ->
98 case direction of
147 case direction of
99 In -> err "promises"
148 In -> err "promises"
100 Out -> return ()
149 Out -> return ()
101
150
102 ST.App (ST.Type v) ts
151 ST.App (ST.Type v) ts
103− | V.isTuple v -> mapM_ valid ts
152+ | Var.isTuple v -> mapM_ valid ts
104−
153+
105 ST.App _ _ -> err "an unsupported type"
154 ST.App _ _ -> err "an unsupported type"
106
155
107 ST.Var _ -> err "free type variables"
156 ST.Var _ -> err "free type variables"