git.iko.soy/elk
on e00a3f3 help sign in
elk/src/Canonicalize/Effects.hs
144 lines 3.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Canonicalize.Effects
4 ( canonicalize
5 , toExposedValues
6 , checkPortType
7 )
8 where
10import qualified Data.Foldable as F
11import Data.Text (Text)
13import qualified AST.Effects as Effects
14import qualified AST.Type as T
15import qualified AST.Variable as Var
16import qualified Reporting.Annotation as A
17import qualified Reporting.Error.Canonicalize as Error
18import qualified Reporting.Region as R
19import qualified Reporting.Result as Result
20import qualified Canonicalize.Environment as Env
21import qualified Canonicalize.Type as Canonicalize
22import Canonicalize.Variable (Result)
26-- TO EXPORT VALUES
29toExposedValues :: Effects.Raw -> [Text]
30toExposedValues effects =
31 case effects of
32 Effects.None ->
33 []
35 Effects.Manager _ _ ->
36 []
38 Effects.Port ports ->
39 map (Effects._rawName . A.drop) ports
43-- CANONICALIZE
46canonicalize :: Env.Env -> Effects.Raw -> Result Effects.Canonical
47canonicalize env effects =
48 case effects of
49 Effects.None ->
50 Result.ok Effects.None
52 Effects.Manager _ info ->
53 Result.ok (Effects.Manager (Env.getPackage env) info)
55 Effects.Port rawPorts ->
56 Effects.Port <$> traverse (canonicalizeRawPort env) rawPorts
59canonicalizeRawPort
60 :: Env.Env
61 -> A.Commented Effects.PortRaw
62 -> Result (A.Commented Effects.PortCanonical)
63canonicalizeRawPort env (A.A ann (Effects.PortRaw name rawType)) =
64 do tipe <- Canonicalize.tipe env rawType
65 kind <- figureOutKind (fst ann) name tipe
66 Result.ok (A.A ann (Effects.PortCanonical name kind tipe))
69figureOutKind :: R.Region -> Text -> T.Canonical -> Result Effects.Kind
70figureOutKind region name rootType =
71 case T.deepDealias rootType of
72 T.Lambda outgoingType (T.App (T.Type effect) [T.Var _])
73 | effect == Var.cmd ->
74 pure (Effects.Outgoing outgoingType)
75 <* checkPortType (makeError region name) outgoingType
77 T.Lambda (T.Lambda incomingType (T.Var msg1)) (T.App (T.Type effect) [T.Var msg2])
78 | effect == Var.sub && msg1 == msg2 ->
79 pure (Effects.Incoming incomingType)
80 <* checkPortType (makeError region name) incomingType
82 _ ->
83 Result.throw region (Error.BadPort name rootType)
86makeError :: R.Region -> Text -> T.Canonical -> Maybe Text -> A.Located Error.Error
87makeError region name tipe maybeMessage =
88 A.A region (Error.port name tipe maybeMessage)
92-- CHECK INCOMING AND OUTGOING TYPES
95checkPortType
96 :: (Monoid i)
97 => (T.Canonical -> Maybe Text -> A.Located e)
98 -> T.Canonical
99 -> Result.Result i w e ()
100checkPortType mkError tipe =
101 let
102 check =
103 checkPortType mkError
105 throw maybeMsg =
106 Result.throwMany [mkError tipe maybeMsg]
107 in
108 case tipe of
109 T.Aliased _ args aliasedType ->
110 check (T.dealias args aliasedType)
112 T.Type name ->
113 if Var.isJson name || Var.isPrimitive name || Var.isTuple name then
114 return ()
116 else
117 throw Nothing
119 T.App name [] ->
120 check name
122 T.App (T.Type name) [arg]
123 | Var.isMaybe name -> check arg
124 | Var.isArray name -> check arg
125 | Var.isList name -> check arg
127 T.App (T.Type name) args
128 | Var.isTuple name ->
129 F.traverse_ check args
131 T.App _ _ ->
132 throw Nothing
134 T.Var _ ->
135 throw (Just "free type variable")
137 T.Lambda _ _ ->
138 throw (Just "function")
140 T.Record _ (Just _) ->
141 throw (Just "extended record")
143 T.Record fields Nothing ->
144 F.traverse_ (\(k,v) -> (,) k <$> check v) fields