git.iko.soy/elk
on c19392f help sign in
elk/src/Canonicalize/Effects.hs
156 lines 3.8 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 qualified Data.Set as Set
12import Data.Text (Text)
14import qualified AST.Effects as Effects
15import qualified AST.Type as T
16import qualified AST.Variable as Var
17import qualified Reporting.Annotation as A
18import qualified Reporting.Error.Canonicalize as Error
19import qualified Reporting.Region as R
20import qualified Reporting.Result as Result
21import qualified Canonicalize.Environment as Env
22import qualified Canonicalize.Type as Canonicalize
23import Canonicalize.Variable (Result)
27-- TO EXPORT VALUES
30toExposedValues :: Effects.Raw -> [Text]
31toExposedValues effects =
32 case effects of
33 Effects.None ->
34 []
36 Effects.Manager _ _ ->
37 []
39 Effects.Port ports ->
40 map (Effects._rawName . A.drop) ports
44-- CANONICALIZE
47canonicalize :: Env.Env -> Effects.Raw -> Result Effects.Canonical
48canonicalize env effects =
49 case effects of
50 Effects.None ->
51 Result.ok Effects.None
53 Effects.Manager _ info ->
54 Result.ok (Effects.Manager (Env.getPackage env) info)
56 Effects.Port rawPorts ->
57 Effects.Port <$> traverse (canonicalizeRawPort env) rawPorts
60canonicalizeRawPort
61 :: Env.Env
62 -> A.Commented Effects.PortRaw
63 -> Result (A.Commented Effects.PortCanonical)
64canonicalizeRawPort 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))
70figureOutKind :: R.Region -> Text -> T.Canonical -> Result Effects.Kind
71figureOutKind 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
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
83 _ ->
84 Result.throw region (Error.BadPort name rootType)
87makeError :: R.Region -> Text -> T.Canonical -> Maybe Text -> A.Located Error.Error
88makeError region name tipe maybeMessage =
89 A.A region (Error.port name tipe maybeMessage)
93-- CHECK INCOMING AND OUTGOING TYPES
96checkPortType
97 :: (Monoid i)
98 => (T.Canonical -> Maybe Text -> A.Located e)
99 -> T.Canonical
100 -> Result.Result i w e ()
101checkPortType mkError tipe =
102 let
103 check =
104 checkPortType mkError
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)
113 T.Type name [] ->
114 if Var.isJson name || isPrimitive name || Var.isTuple name then
115 return ()
117 else
118 throw Nothing
120 T.Type name [arg]
121 | Var.isMaybe name -> check arg
122 | Var.isArray name -> check arg
123 | Var.isList name -> check arg
125 T.Type name args ->
126 if Var.isTuple name then
127 F.traverse_ check args
128 else
129 throw Nothing
131 T.Var _ ->
132 throw (Just "free type variable")
134 T.Lambda _ _ ->
135 throw (Just "function")
137 T.Record _ (Just _) ->
138 throw (Just "extended record")
140 T.Record fields Nothing ->
141 F.traverse_ (\(k,v) -> (,) k <$> check v) fields
144isPrimitive :: Var.Canonical -> Bool
145isPrimitive var =
146 case var of
147 Var.Canonical Var.BuiltIn name ->
148 Set.member name primitiveSet
150 _ ->
151 False
154primitiveSet :: Set.Set Text
155primitiveSet =
156 Set.fromList ["Int","Float","String","Bool"]