git.iko.soy/elk
on 267f708 help sign in
elk/src/Canonicalize/Effects.hs
137 lines 3.6 kB history raw
1module Canonicalize.Effects (canonicalize, toValues, checkPortType) where
3import qualified Data.Foldable as F
4import qualified Data.Traversable as T
6import qualified AST.Effects as Effects
7import qualified AST.Type as T
8import qualified AST.Variable as Var
9import qualified Reporting.Annotation as A
10import qualified Reporting.Error.Canonicalize as Error
11import qualified Reporting.Region as R
12import qualified Reporting.Result as Result
13import qualified Canonicalize.Environment as Env
14import qualified Canonicalize.Type as Canonicalize
15import Canonicalize.Variable (Result)
19-- TO EXPORT VALUES
22toValues :: Effects.Raw -> [Var.Value]
23toValues effects =
24 case effects of
25 Effects.None ->
26 []
28 Effects.Manager _ _ ->
29 []
31 Effects.Port ports ->
32 map (Var.Value . Effects._rawName . A.drop) ports
36-- CANONICALIZE
39canonicalize :: Env.Environment -> Effects.Raw -> Result Effects.Canonical
40canonicalize env effects =
41 case effects of
42 Effects.None ->
43 Result.ok Effects.None
45 Effects.Manager _ info ->
46 Result.ok (Effects.Manager (Env.getPackage env) info)
48 Effects.Port rawPorts ->
49 Effects.Port <$> T.traverse (canonicalizeRawPort env) rawPorts
52canonicalizeRawPort
53 :: Env.Environment
54 -> A.Commented Effects.PortRaw
55 -> Result (A.Commented Effects.PortCanonical)
56canonicalizeRawPort env (A.A ann (Effects.PortRaw name rawType)) =
57 do tipe <- Canonicalize.tipe env rawType
58 kind <- figureOutKind (fst ann) name tipe
59 Result.ok (A.A ann (Effects.PortCanonical name kind tipe))
62figureOutKind :: R.Region -> String -> T.Canonical -> Result Effects.Kind
63figureOutKind region name rootType =
64 case T.deepDealias rootType of
65 T.Lambda outgoingType (T.App (T.Type effect) [T.Var _])
66 | effect == Var.cmd ->
67 pure (Effects.Outgoing outgoingType)
68 <* checkPortType (makeError region name) outgoingType
70 T.Lambda (T.Lambda incomingType (T.Var msg1)) (T.App (T.Type effect) [T.Var msg2])
71 | effect == Var.sub && msg1 == msg2 ->
72 pure (Effects.Incoming incomingType)
73 <* checkPortType (makeError region name) incomingType
75 _ ->
76 Result.throw region (Error.BadPort name rootType)
79makeError :: R.Region -> String -> T.Canonical -> Maybe String -> A.Located Error.Error
80makeError region name tipe maybeMessage =
81 A.A region (Error.port name tipe maybeMessage)
85-- CHECK INCOMING AND OUTGOING TYPES
88checkPortType
89 :: (Monoid i)
90 => (T.Canonical -> Maybe String -> A.Located e)
91 -> T.Canonical
92 -> Result.Result i w e ()
93checkPortType makeError tipe =
94 let
95 check =
96 checkPortType makeError
98 throw maybeMsg =
99 Result.throwMany [makeError tipe maybeMsg]
100 in
101 case tipe of
102 T.Aliased _ args aliasedType ->
103 check (T.dealias args aliasedType)
105 T.Type name ->
106 if Var.isJson name || Var.isPrimitive name || Var.isTuple name then
107 return ()
109 else
110 throw Nothing
112 T.App name [] ->
113 check name
115 T.App (T.Type name) [arg]
116 | Var.isMaybe name -> check arg
117 | Var.isArray name -> check arg
118 | Var.isList name -> check arg
120 T.App (T.Type name) args
121 | Var.isTuple name ->
122 F.traverse_ check args
124 T.App _ _ ->
125 throw Nothing
127 T.Var _ ->
128 throw (Just "free type variable")
130 T.Lambda _ _ ->
131 throw (Just "function")
133 T.Record _ (Just _) ->
134 throw (Just "extended record")
136 T.Record fields Nothing ->
137 F.traverse_ (\(k,v) -> (,) k <$> check v) fields