git.iko.soy/elk
on master help sign in
Make `checkForeignType` more generic and export it
1b28a32Evan Czaplicki
src/Canonicalize/Effects.hs+28−23
compare with master
unifiedsplit
@@ -1,4 +1,4 @@
1−module Canonicalize.Effects (canonicalize, toValues) where
1+module Canonicalize.Effects (canonicalize, toValues, checkForeignType) where
2
2
3import qualified Data.Foldable as F
3import qualified Data.Foldable as F
4import qualified Data.Traversable as T
4import qualified Data.Traversable as T
@@ -64,45 +64,50 @@ figureOutKind region name rootType =
64 case T.deepDealias rootType of
64 case T.deepDealias rootType of
65 T.Lambda outgoingType (T.App (T.Type effect) [T.Var _])
65 T.Lambda outgoingType (T.App (T.Type effect) [T.Var _])
66 | effect == Var.cmd ->
66 | effect == Var.cmd ->
67− const (Effects.Cmd outgoingType)
67+ pure (Effects.Cmd outgoingType)
68− <$> checkForeignType region name "command" outgoingType
68+ <* checkForeignType (makeError region name "command") outgoingType
69
69
70 T.Lambda (T.Lambda incomingType (T.Var msg1)) (T.App (T.Type effect) [T.Var msg2])
70 T.Lambda (T.Lambda incomingType (T.Var msg1)) (T.App (T.Type effect) [T.Var msg2])
71 | effect == Var.sub && msg1 == msg2 ->
71 | effect == Var.sub && msg1 == msg2 ->
72− const (Effects.Sub incomingType)
72+ pure (Effects.Sub incomingType)
73− <$> checkForeignType region name "subscription" incomingType
73+ <* checkForeignType (makeError region name "subscription") incomingType
74
74
75 _ ->
75 _ ->
76 Result.throw region (error "TODO - bad overall type")
76 Result.throw region (error "TODO - bad overall type")
77
77
78
78
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+
79
84
80-- CHECK INCOMING AND OUTGOING TYPES
85-- CHECK INCOMING AND OUTGOING TYPES
81
86
82
87
83−--
88+checkForeignType
84−-- Note: assumes that deepDealias has been called on the incoming type.
89+ :: (Monoid i)
85−--
90+ => (T.Canonical -> Maybe String -> A.Located e)
86−checkForeignType :: R.Region -> String -> String -> T.Canonical -> Result ()
91+ -> T.Canonical
92+ -> Result.Result i w e ()
87−checkForeignType region name kind tipe =
93+checkForeignType makeError tipe =
88 let
94 let
89− throwError maybeMessage =
95+ check =
90− Result.throw region $
96+ checkForeignType makeError
91− Error.foreign name kind tipe maybeMessage
92
97
93− check subType =
98+ throw maybeMsg =
94− checkForeignType region name kind subType
99+ Result.throwMany [makeError tipe maybeMsg]
95 in
100 in
96 case tipe of
101 case tipe of
97− T.Aliased _ _ _ ->
102+ T.Aliased _ args aliasedType ->
98− error "there should be no aliases, they are stripped by `figureOutKind`"
103+ check (T.dealias args aliasedType)
99
104
100 T.Type name ->
105 T.Type name ->
101 if Var.isJson name || Var.isPrimitive name || Var.isTuple name then
106 if Var.isJson name || Var.isPrimitive name || Var.isTuple name then
102− Result.ok ()
107+ return ()
103
108
104 else
109 else
105− throwError Nothing
110+ throw Nothing
106
111
107 T.App name [] ->
112 T.App name [] ->
108 check name
113 check name
@@ -117,16 +122,16 @@ checkForeignType region name kind tipe =
117 F.traverse_ check args
122 F.traverse_ check args
118
123
119 T.App _ _ ->
124 T.App _ _ ->
120− throwError Nothing
125+ throw Nothing
121
126
122 T.Var _ ->
127 T.Var _ ->
123− throwError (Just "free type variable")
128+ throw (Just "free type variable")
124
129
125 T.Lambda _ _ ->
130 T.Lambda _ _ ->
126− throwError (Just "function")
131+ throw (Just "function")
127
132
128 T.Record _ (Just _) ->
133 T.Record _ (Just _) ->
129− throwError (Just "extended record")
134+ throw (Just "extended record")
130
135
131 T.Record fields Nothing ->
136 T.Record fields Nothing ->
132 F.traverse_ (\(k,v) -> (,) k <$> check v) fields
137 F.traverse_ (\(k,v) -> (,) k <$> check v) fields