@@ -1,4 +1,4 @@
1−module Canonicalize.Effects (canonicalize, toValues) where
1+module Canonicalize.Effects (canonicalize, toValues, checkForeignType) where
22
33import qualified Data.Foldable as F
44import qualified Data.Traversable as T
@@ -64,45 +64,50 @@ figureOutKind region name rootType =
6464 case T.deepDealias rootType of
6565 T.Lambda outgoingType (T.App (T.Type effect) [T.Var _])
6666 | effect == Var.cmd ->
67− const (Effects.Cmd outgoingType)
68− <$> checkForeignType region name "command" outgoingType
67+ pure (Effects.Cmd outgoingType)
68+ <* checkForeignType (makeError region name "command") outgoingType
6969
7070 T.Lambda (T.Lambda incomingType (T.Var msg1)) (T.App (T.Type effect) [T.Var msg2])
7171 | effect == Var.sub && msg1 == msg2 ->
72− const (Effects.Sub incomingType)
73− <$> checkForeignType region name "subscription" incomingType
72+ pure (Effects.Sub incomingType)
73+ <* checkForeignType (makeError region name "subscription") incomingType
7474
7575 _ ->
7676 Result.throw region (error "TODO - bad overall type")
7777
7878
79+makeError :: R.Region -> String -> String -> T.Canonical -> Maybe String -> A.Located Error.Error
80+makeError region name kind tipe maybeMessage =
81+ A.A region (Error.foreign name kind tipe maybeMessage)
82+
83+
7984
8085-- CHECK INCOMING AND OUTGOING TYPES
8186
8287
83−--
84−-- Note: assumes that deepDealias has been called on the incoming type.
85−--
86−checkForeignType :: R.Region -> String -> String -> T.Canonical -> Result ()
87−checkForeignType region name kind tipe =
88+checkForeignType
89+ :: (Monoid i)
90+ => (T.Canonical -> Maybe String -> A.Located e)
91+ -> T.Canonical
92+ -> Result.Result i w e ()
93+checkForeignType makeError tipe =
8894 let
89− throwError maybeMessage =
90− Result.throw region $
91− Error.foreign name kind tipe maybeMessage
95+ check =
96+ checkForeignType makeError
9297
93− check subType =
94− checkForeignType region name kind subType
98+ throw maybeMsg =
99+ Result.throwMany [makeError tipe maybeMsg]
95100 in
96101 case tipe of
97− T.Aliased _ _ _ ->
98− error "there should be no aliases, they are stripped by `figureOutKind`"
102+ T.Aliased _ args aliasedType ->
103+ check (T.dealias args aliasedType)
99104
100105 T.Type name ->
101106 if Var.isJson name || Var.isPrimitive name || Var.isTuple name then
102− Result.ok ()
107+ return ()
103108
104109 else
105− throwError Nothing
110+ throw Nothing
106111
107112 T.App name [] ->
108113 check name
@@ -117,16 +122,16 @@ checkForeignType region name kind tipe =
117122 F.traverse_ check args
118123
119124 T.App _ _ ->
120− throwError Nothing
125+ throw Nothing
121126
122127 T.Var _ ->
123− throwError (Just "free type variable")
128+ throw (Just "free type variable")
124129
125130 T.Lambda _ _ ->
126− throwError (Just "function")
131+ throw (Just "function")
127132
128133 T.Record _ (Just _) ->
129− throwError (Just "extended record")
134+ throw (Just "extended record")
130135
131136 T.Record fields Nothing ->
132137 F.traverse_ (\(k,v) -> (,) k <$> check v) fields