@@ -2,155 +2,169 @@
22{-# LANGUAGE OverloadedStrings #-}
33module Canonicalize.Effects
44 ( canonicalize
5− , toExposedValues
6− , checkPortType
5+ , checkPayload
76 )
87 where
98
109import qualified Data.Foldable as F
10+import qualified Data.Map as Map
1111import qualified Data.Set as Set
1212import Data.Text (Text)
1313
14−import qualified AST.Effects as Effects
15−import qualified AST.Type as T
16−import qualified AST.Variable as Var
14+import qualified AST.Expression.Canonical as Can
15+import qualified AST.Expression.Valid as Valid
16+import qualified AST.Module.Name as ModuleName
17+import qualified AST.Type as Type
18+import qualified Canonicalize.Environment as Env
19+import qualified Canonicalize.Type as Type
20+import qualified Elm.Name as N
1721import qualified Reporting.Annotation as A
1822import qualified Reporting.Error.Canonicalize as Error
19−import qualified Reporting.Region as R
2023import qualified Reporting.Result as Result
21−import qualified Canonicalize.Environment as Env
22−import qualified Canonicalize.Type as Canonicalize
23−import Canonicalize.Variable (Result)
24+import qualified Reporting.Warning as Warning
25+
26+
27+
28+-- RESULT
29+
2430
31+type Result a =
32+ Result.Result () Warning.Warning Error.Error a
2533
2634
27−-- TO EXPORT VALUES
35+
36+-- CANONICALIZE
2837
2938
30−toExposedValues :: Effects.Raw -> [Text]
31−toExposedValues effects =
39+canonicalize :: Env.Env -> Map.Map N.Name a -> Valid.Effects -> Result Can.Effects
40+canonicalize env unions effects =
3241 case effects of
33− Effects.None ->
34− []
42+ Valid.NoEffects ->
43+ Result.ok Can.NoEffects
3544
36− Effects.Manager _ _ ->
37− []
45+ Valid.Ports ports ->
46+ do pairs <- traverse (canonicalizePort env) ports
47+ return $ Can.Ports (Map.fromList pairs)
3848
39− Effects.Port ports ->
40− map (Effects._rawName . A.drop) ports
49+ Valid.Cmd cmdType ->
50+ Can.Cmd <$> verifyEffectType cmdType unions
4151
52+ Valid.Sub subType ->
53+ Can.Sub <$> verifyEffectType subType unions
4254
55+ Valid.Fx cmdType subType ->
56+ Can.Fx
57+ <$> verifyEffectType cmdType unions
58+ <*> verifyEffectType subType unions
4359
44−-- CANONICALIZE
4560
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)
4667
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
5268
53− Effects.Manager _ info ->
54− Result.ok (Effects.Manager (Env.getPackage env) info)
69+canonicalizePort :: Env.Env -> Valid.Port -> Result (N.Name, Can.Port)
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)
5587
56− Effects.Port rawPorts ->
57− Effects.Port <$> traverse (canonicalizeRawPort env) rawPorts
88+ Right () ->
89+ Result.ok (portName, Can.Incoming ctipe)
5890
91+ _ ->
92+ Result.throw region (Error.PortTypeInvalid portName ctipe)
5993
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))
6894
6995
70−figureOutKind :: R.Region -> Text -> T.Canonical -> Result Effects.Kind
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
96+-- CHECK PAYLOAD TYPES
7797
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
8298
83− _ ->
84− Result.throw region (Error.BadPort name rootType)
99+checkPayload :: Type.Canonical -> Either (Type.Canonical, Error.InvalidPayload) ()
100+checkPayload tipe =
101+ case tipe of
102+ Type.Aliased _ _ args aliasedType ->
103+ checkPayload (Type.dealias args aliasedType)
85104
105+ Type.Type home name args ->
106+ case args of
107+ []
108+ | isPrim home name -> Right ()
109+ | isJson home name -> Right ()
86110
87−makeError :: R.Region -> Text -> T.Canonical -> Maybe Text -> A.Located Error.Error
88−makeError region name tipe maybeMessage =
89− A.A region (Error.port name tipe maybeMessage)
111+ [arg]
112+ | isList home name -> checkPayload arg
113+ | isMaybe home name -> checkPayload arg
114+ | isArray home name -> checkPayload arg
90115
116+ _ ->
117+ Left (tipe, Error.UnsupportedType name)
91118
119+ Type.Unit ->
120+ Right ()
92121
93−-- CHECK INCOMING AND OUTGOING TYPES
122+ Type.Tuple a b cs ->
123+ F.traverse_ checkPayload (a:b:cs)
94124
125+ Type.Var name ->
126+ Left (tipe, Error.TypeVariable name)
95127
96−checkPortType
97− :: (Monoid i)
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
128+ Type.Lambda _ _ ->
129+ Left (tipe, Error.Function)
105130
106− throw maybeMsg =
107− Result.throwMany [mkError tipe maybeMsg]
108− in
109− case tipe of
110− T.Aliased _ args aliasedType ->
111− check (T.dealias args aliasedType)
131+ Type.Record _ (Just _) ->
132+ Left (tipe, Error.ExtendedRecord)
112133
113− T.Type name [] ->
114− if Var.isJson name || isPrimitive name || Var.isTuple name then
115− return ()
134+ Type.Record fields Nothing ->
135+ F.traverse_ checkPayload fields
116136
117− else
118− throw Nothing
119137
120− T.Type name [arg]
121− | Var.isMaybe name -> check arg
122− | Var.isArray name -> check arg
123− | Var.isList name -> check arg
138+isPrim :: ModuleName.Canonical -> N.Name -> Bool
139+isPrim home name =
140+ home == ModuleName.basics
141+ && Set.member name primitives
124142
125− T.Type name args ->
126− if Var.isTuple name then
127− F.traverse_ check args
128− else
129− throw Nothing
130143
131− T.Var _ ->
132− throw (Just "free type variable")
144+primitives :: Set.Set Text
145+primitives =
146+ Set.fromList [ "Int", "Float", "String", "Bool" ]
133147
134− T.Lambda _ _ ->
135− throw (Just "function")
136148
137− T.Record _ (Just _) ->
138− throw (Just "extended record")
149+isJson :: ModuleName.Canonical -> N.Name -> Bool
150+isJson home name =
151+ home == ModuleName.jsonEncode
152+ && name == "Value"
139153
140− T.Record fields Nothing ->
141− F.traverse_ (\(k,v) -> (,) k <$> check v) fields
142154
155+isList :: ModuleName.Canonical -> N.Name -> Bool
156+isList home name =
157+ home == ModuleName.list
158+ && name == "List"
143159
144−isPrimitive :: Var.Canonical -> Bool
145−isPrimitive var =
146− case var of
147− Var.Canonical Var.BuiltIn name ->
148− Set.member name primitiveSet
149160
150− _ ->
151− False
161+isMaybe :: ModuleName.Canonical -> N.Name -> Bool
162+isMaybe home name =
163+ home == ModuleName.maybe
164+ && name == "Maybe"
152165
153166
154−primitiveSet :: Set.Set Text
155−primitiveSet =
156− Set.fromList ["Int","Float","String","Bool"]
167+isArray :: ModuleName.Canonical -> N.Name -> Bool
168+isArray home name =
169+ home == ModuleName.array
170+ && name == "Array"