@@ -18,7 +18,7 @@ import qualified AST.Annotation as A
1818import qualified AST.Expression.Canonical as Canonical
1919import qualified AST.PrettyPrint as PP
2020import qualified AST.Type as ST
21−import qualified AST.Variable as V
21+import qualified AST.Variable as Var
2222import qualified Transform.Expression as Expr
2323import qualified Type.Hint as Hint
2424import qualified Type.Type as TT
@@ -30,42 +30,91 @@ throw err =
3030 Left [ P.vcat err ]
3131
3232
33+-- MAIN TYPE
34+
3335mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
3436mainType environment =
3537 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
3638 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− ]
6739
6840
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+
69118data Direction = In | Out
70119
71120
@@ -81,27 +130,27 @@ portTypes expr =
81130 ST.Aliased _ t -> valid t
82131
83132 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
85134 True -> return ()
86135 False -> err "an unsupported type"
87136
88137 ST.App t [] -> valid t
89138
90139 ST.App (ST.Type v) [t]
91− | V.isSignal v -> handleSignal t
92− | V.isMaybe v -> valid t
93− | V.isArray v -> valid t
94− | V.isList v -> valid t
140+ | Var.isSignal v -> handleSignal t
141+ | Var.isMaybe v -> valid t
142+ | Var.isArray v -> valid t
143+ | Var.isList v -> valid t
95144
96145 ST.App (ST.Type v) [_, _]
97− | V.isPromise v ->
146+ | Var.isPromise v ->
98147 case direction of
99148 In -> err "promises"
100149 Out -> return ()
101150
102151 ST.App (ST.Type v) ts
103− | V.isTuple v -> mapM_ valid ts
104−
152+ | Var.isTuple v -> mapM_ valid ts
153+
105154 ST.App _ _ -> err "an unsupported type"
106155
107156 ST.Var _ -> err "free type variables"