git.iko.soy/elk
on master help sign in
Verify that port types can actually pass between Elm and JS
32834faEvan Czaplicki
src/AST/Expression/Canonical.hs+7−1
compare with master
unifiedsplit
@@ -17,6 +17,7 @@ module AST.Expression.Canonical
17 , Union(..)
17 , Union(..)
18 , Binop(..)
18 , Binop(..)
19 , Effects(..)
19 , Effects(..)
20+ , Port(..)
20 , Exports(..)
21 , Exports(..)
21 , Export(..)
22 , Export(..)
22 , Docs(..)
23 , Docs(..)
@@ -158,12 +159,17 @@ data Binop = Binop_ Binop.Associativity Binop.Precedence N.Name
158
159
159data Effects
160data Effects
160 = NoEffects
161 = NoEffects
161− | Ports (Map.Map N.Name Type.Canonical)
162+ | Ports (Map.Map N.Name Port)
162 | Cmd N.Name
163 | Cmd N.Name
163 | Sub N.Name
164 | Sub N.Name
164 | Fx N.Name N.Name
165 | Fx N.Name N.Name
165
166
166
167
168+data Port
169+ = Incoming Type.Canonical
170+ | Outgoing Type.Canonical
171+
172+
167data Exports
173data Exports
168 = ExportEverything
174 = ExportEverything
169 | Export (Map.Map N.Name Export)
175 | Export (Map.Map N.Name Export)
src/Canonicalize/Effects.hs+114−100
@@ -2,155 +2,169 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Effects
3module Canonicalize.Effects
4 ( canonicalize
4 ( canonicalize
5− , toExposedValues
5+ , checkPayload
6− , checkPortType
7 )
6 )
8 where
7 where
9
8
10import qualified Data.Foldable as F
9import qualified Data.Foldable as F
10+import qualified Data.Map as Map
11import qualified Data.Set as Set
11import qualified Data.Set as Set
12import Data.Text (Text)
12import Data.Text (Text)
13
13
14−import qualified AST.Effects as Effects
14+import qualified AST.Expression.Canonical as Can
15+import qualified AST.Expression.Valid as Valid
16+import qualified AST.Module.Name as ModuleName
15−import qualified AST.Type as T
17+import qualified AST.Type as Type
16−import qualified AST.Variable as Var
18+import qualified Canonicalize.Environment as Env
19+import qualified Canonicalize.Type as Type
20+import qualified Elm.Name as N
17import qualified Reporting.Annotation as A
21import qualified Reporting.Annotation as A
18import qualified Reporting.Error.Canonicalize as Error
22import qualified Reporting.Error.Canonicalize as Error
19−import qualified Reporting.Region as R
20import qualified Reporting.Result as Result
23import qualified Reporting.Result as Result
21−import qualified Canonicalize.Environment as Env
24+import qualified Reporting.Warning as Warning
22−import qualified Canonicalize.Type as Canonicalize
25+
23−import Canonicalize.Variable (Result)
26+
27+
28+-- RESULT
29+
24
30
31+type Result a =
32+ Result.Result () Warning.Warning Error.Error a
25
33
26
34
27−-- TO EXPORT VALUES
35+
36+-- CANONICALIZE
28
37
29
38
30−toExposedValues :: Effects.Raw -> [Text]
39+canonicalize :: Env.Env -> Map.Map N.Name a -> Valid.Effects -> Result Can.Effects
31−toExposedValues effects =
40+canonicalize env unions effects =
32 case effects of
41 case effects of
33− Effects.None ->
42+ Valid.NoEffects ->
34− []
43+ Result.ok Can.NoEffects
35
44
36− Effects.Manager _ _ ->
45+ Valid.Ports ports ->
37− []
46+ do pairs <- traverse (canonicalizePort env) ports
47+ return $ Can.Ports (Map.fromList pairs)
38
48
39− Effects.Port ports ->
49+ Valid.Cmd cmdType ->
40− map (Effects._rawName . A.drop) ports
50+ Can.Cmd <$> verifyEffectType cmdType unions
41
51
52+ Valid.Sub subType ->
53+ Can.Sub <$> verifyEffectType subType unions
42
54
55+ Valid.Fx cmdType subType ->
56+ Can.Fx
57+ <$> verifyEffectType cmdType unions
58+ <*> verifyEffectType subType unions
43
59
44−-- CANONICALIZE
45
60
61+verifyEffectType :: A.Located N.Name -> Map.Map N.Name a -> Result N.Name
62+verifyEffectType (A.A region name) unions =
63+ if Map.member name unions then
64+ Result.ok name
65+ else
66+ Result.throw region (Error.EffectNotFound name)
46
67
47−canonicalize :: Env.Env -> Effects.Raw -> Result Effects.Canonical
48−canonicalize env effects =
49− case effects of
50− Effects.None ->
51− Result.ok Effects.None
52
68
53− Effects.Manager _ info ->
69+canonicalizePort :: Env.Env -> Valid.Port -> Result (N.Name, Can.Port)
54− Result.ok (Effects.Manager (Env.getPackage env) info)
70+canonicalizePort env (Valid.Port (A.A region portName) tipe) =
71+ do ctipe <- Type.canonicalize env tipe
72+ case Type.deepDealias ctipe of
73+ Type.Lambda outgoingType (Type.Type home name [Type.Var _])
74+ | home == ModuleName.cmd && name == "Cmd" ->
75+ case checkPayload outgoingType of
76+ Left (badType, err) ->
77+ Result.throw region (Error.PortPayloadInvalid portName badType err)
78+
79+ Right () ->
80+ Result.ok (portName, Can.Outgoing ctipe)
81+
82+ Type.Lambda (Type.Lambda incomingType (Type.Var msg1)) (Type.Type home name [Type.Var msg2])
83+ | home == ModuleName.sub && name == "Sub" && msg1 == msg2 ->
84+ case checkPayload incomingType of
85+ Left (badType, err) ->
86+ Result.throw region (Error.PortPayloadInvalid portName badType err)
55
87
56− Effects.Port rawPorts ->
88+ Right () ->
57− Effects.Port <$> traverse (canonicalizeRawPort env) rawPorts
89+ Result.ok (portName, Can.Incoming ctipe)
58
90
91+ _ ->
92+ Result.throw region (Error.PortTypeInvalid portName ctipe)
59
93
60−canonicalizeRawPort
61− :: Env.Env
62− -> A.Commented Effects.PortRaw
63− -> Result (A.Commented Effects.PortCanonical)
64−canonicalizeRawPort env (A.A ann (Effects.PortRaw name rawType)) =
65− do tipe <- Canonicalize.tipe env rawType
66− kind <- figureOutKind (fst ann) name tipe
67− Result.ok (A.A ann (Effects.PortCanonical name kind tipe))
68
94
69
95
70−figureOutKind :: R.Region -> Text -> T.Canonical -> Result Effects.Kind
96+-- CHECK PAYLOAD TYPES
71−figureOutKind region name rootType =
72− case T.deepDealias rootType of
73− T.Lambda outgoingType (T.Type effect [T.Var _])
74− | effect == Var.cmd ->
75− pure (Effects.Outgoing outgoingType)
76− <* checkPortType (makeError region name) outgoingType
77
97
78− T.Lambda (T.Lambda incomingType (T.Var msg1)) (T.Type effect [T.Var msg2])
79− | effect == Var.sub && msg1 == msg2 ->
80− pure (Effects.Incoming incomingType)
81− <* checkPortType (makeError region name) incomingType
82
98
83− _ ->
99+checkPayload :: Type.Canonical -> Either (Type.Canonical, Error.InvalidPayload) ()
84− Result.throw region (Error.BadPort name rootType)
100+checkPayload tipe =
101+ case tipe of
102+ Type.Aliased _ _ args aliasedType ->
103+ checkPayload (Type.dealias args aliasedType)
85
104
105+ Type.Type home name args ->
106+ case args of
107+ []
108+ | isPrim home name -> Right ()
109+ | isJson home name -> Right ()
86
110
87−makeError :: R.Region -> Text -> T.Canonical -> Maybe Text -> A.Located Error.Error
111+ [arg]
88−makeError region name tipe maybeMessage =
112+ | isList home name -> checkPayload arg
89− A.A region (Error.port name tipe maybeMessage)
113+ | isMaybe home name -> checkPayload arg
114+ | isArray home name -> checkPayload arg
90
115
116+ _ ->
117+ Left (tipe, Error.UnsupportedType name)
91
118
119+ Type.Unit ->
120+ Right ()
92
121
93−-- CHECK INCOMING AND OUTGOING TYPES
122+ Type.Tuple a b cs ->
123+ F.traverse_ checkPayload (a:b:cs)
94
124
125+ Type.Var name ->
126+ Left (tipe, Error.TypeVariable name)
95
127
96−checkPortType
128+ Type.Lambda _ _ ->
97− :: (Monoid i)
129+ Left (tipe, Error.Function)
98− => (T.Canonical -> Maybe Text -> A.Located e)
99− -> T.Canonical
100− -> Result.Result i w e ()
101−checkPortType mkError tipe =
102− let
103− check =
104− checkPortType mkError
105
130
106− throw maybeMsg =
131+ Type.Record _ (Just _) ->
107− Result.throwMany [mkError tipe maybeMsg]
132+ Left (tipe, Error.ExtendedRecord)
108− in
109− case tipe of
110− T.Aliased _ args aliasedType ->
111− check (T.dealias args aliasedType)
112
133
113− T.Type name [] ->
134+ Type.Record fields Nothing ->
114− if Var.isJson name || isPrimitive name || Var.isTuple name then
135+ F.traverse_ checkPayload fields
115− return ()
116
136
117− else
118− throw Nothing
119
137
120− T.Type name [arg]
138+isPrim :: ModuleName.Canonical -> N.Name -> Bool
121− | Var.isMaybe name -> check arg
139+isPrim home name =
122− | Var.isArray name -> check arg
140+ home == ModuleName.basics
123− | Var.isList name -> check arg
141+ && Set.member name primitives
124
142
125− T.Type name args ->
126− if Var.isTuple name then
127− F.traverse_ check args
128− else
129− throw Nothing
130
143
131− T.Var _ ->
144+primitives :: Set.Set Text
132− throw (Just "free type variable")
145+primitives =
146+ Set.fromList [ "Int", "Float", "String", "Bool" ]
133
147
134− T.Lambda _ _ ->
135− throw (Just "function")
136
148
137− T.Record _ (Just _) ->
149+isJson :: ModuleName.Canonical -> N.Name -> Bool
138− throw (Just "extended record")
150+isJson home name =
151+ home == ModuleName.jsonEncode
152+ && name == "Value"
139
153
140− T.Record fields Nothing ->
141− F.traverse_ (\(k,v) -> (,) k <$> check v) fields
142
154
155+isList :: ModuleName.Canonical -> N.Name -> Bool
156+isList home name =
157+ home == ModuleName.list
158+ && name == "List"
143
159
144−isPrimitive :: Var.Canonical -> Bool
145−isPrimitive var =
146− case var of
147− Var.Canonical Var.BuiltIn name ->
148− Set.member name primitiveSet
149
160
150− _ ->
161+isMaybe :: ModuleName.Canonical -> N.Name -> Bool
151− False
162+isMaybe home name =
163+ home == ModuleName.maybe
164+ && name == "Maybe"
152
165
153
166
154−primitiveSet :: Set.Set Text
167+isArray :: ModuleName.Canonical -> N.Name -> Bool
155−primitiveSet =
168+isArray home name =
156− Set.fromList ["Int","Float","String","Bool"]
169+ home == ModuleName.array
170+ && name == "Array"
src/Canonicalize/Module.hs+3−41
@@ -14,6 +14,7 @@ import qualified AST.Expression.Source as Src
14import qualified AST.Expression.Valid as Valid
14import qualified AST.Expression.Valid as Valid
15import qualified AST.Module.Name as ModuleName
15import qualified AST.Module.Name as ModuleName
16import qualified AST.Type as Type
16import qualified AST.Type as Type
17+import qualified Canonicalize.Effects as Effects
17import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment as Env
18import qualified Canonicalize.Environment.Dups as Dups
19import qualified Canonicalize.Environment.Dups as Dups
19import qualified Canonicalize.Expression as Expr
20import qualified Canonicalize.Expression as Expr
@@ -43,7 +44,7 @@ type Result a =
43
44
44canonicalize
45canonicalize
45 :: Pkg.Name
46 :: Pkg.Name
46− -> Map.Map ModuleName.Raw ModuleName.Canonical
47+ -> Map.Map N.Name ModuleName.Canonical
47 -> I.Interfaces
48 -> I.Interfaces
48 -> Valid.Module
49 -> Valid.Module
49 -> Result Can.Module
50 -> Result Can.Module
@@ -57,7 +58,7 @@ canonicalize pkg importDict interfaces module_ =
57 <*> (Map.fromList <$> traverse (canonicalizeAlias env) aliases)
58 <*> (Map.fromList <$> traverse (canonicalizeAlias env) aliases)
58
59
59 let cbinops = Map.fromList (map canonicalizeBinop binops)
60 let cbinops = Map.fromList (map canonicalizeBinop binops)
60− ceffects <- canonicalizeEffects env cunions effects
61+ ceffects <- Effects.canonicalize env cunions effects
61 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
62 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports
62
63
63 let home = ModuleName.Canonical pkg name
64 let home = ModuleName.Canonical pkg name
@@ -212,45 +213,6 @@ detectBadCyclesHelp decl =
212
213
213
214
214
215
215−-- CANONICALIZE EFFECTS
216−
217−
218−canonicalizeEffects :: Env.Env -> Map.Map N.Name a -> Valid.Effects -> Result Can.Effects
219−canonicalizeEffects env unions effects =
220− case effects of
221− Valid.NoEffects ->
222− Result.ok Can.NoEffects
223−
224− Valid.Ports ports ->
225− do pairs <- traverse (canonicalizePort env) ports
226− return $ Can.Ports (Map.fromList pairs)
227−
228− Valid.Cmd cmdType ->
229− Can.Cmd <$> verifyEffectType cmdType unions
230−
231− Valid.Sub subType ->
232− Can.Sub <$> verifyEffectType subType unions
233−
234− Valid.Fx cmdType subType ->
235− Can.Fx
236− <$> verifyEffectType cmdType unions
237− <*> verifyEffectType subType unions
238−
239−
240−canonicalizePort :: Env.Env -> Valid.Port -> Result (N.Name, Type.Canonical)
241−canonicalizePort env (Valid.Port (A.A _ name) tipe) =
242− (,) name <$> Type.canonicalize env tipe
243−
244−
245−verifyEffectType :: A.Located N.Name -> Map.Map N.Name a -> Result N.Name
246−verifyEffectType (A.A region name) unions =
247− if Map.member name unions then
248− Result.ok name
249− else
250− Result.throw region (Error.EffectNotFound name)
251−
252−
253−
254-- CANONICALIZE EXPORTS
216-- CANONICALIZE EXPORTS
255
217
256
218