git.iko.soy/elk
on 445ea07 help sign in
elk/src/AST/Type.hs
221 lines 4.5 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module AST.Type
4 ( Raw, Raw'(..)
5 , Canonical(..), Aliased(..)
6 , deepDealias, iteratedDealias, dealias
7 , collectLambdas
8 , tuple, cmd, sub
9 )
10 where
12import Control.Arrow (second)
13import Control.Monad (liftM, liftM2, liftM3, replicateM)
14import Data.Binary
15import qualified Data.Map as Map
16import Data.Text (Text)
18import qualified AST.Helpers as Help
19import qualified AST.Module.Name as ModuleName
20import qualified AST.Variable as Var
21import qualified Reporting.Annotation as A
22import qualified Reporting.Region as R
26-- DEFINITION
29type Raw =
30 A.Located Raw'
33data Raw'
34 = RLambda Raw Raw
35 | RVar Text
36 | RType (A.Located Var.Raw) [Raw]
37 | RRecord [(A.Located Text, Raw)] (Maybe Raw)
40data Canonical
41 = Lambda Canonical Canonical
42 | Var Text
43 | Type Var.Canonical [Canonical]
44 | Record [(Text, Canonical)] (Maybe Canonical)
45 | Aliased Var.Canonical [(Text, Canonical)] (Aliased Canonical)
46 deriving (Eq, Ord)
49data Aliased t
50 = Holey t
51 | Filled t
52 deriving (Eq, Ord)
56-- CONSTRUCT USEFUL TYPES
59tuple :: R.Region -> [Raw] -> Raw
60tuple region types =
61 let
62 name =
63 Var.Raw (Help.makeTuple (length types))
64 in
65 A.A region (RType (A.A region name) types)
68cmd :: ModuleName.Canonical -> Text -> Canonical
69cmd =
70 effect Var.cmd
73sub :: ModuleName.Canonical -> Text -> Canonical
74sub =
75 effect Var.sub
78effect :: Var.Canonical -> ModuleName.Canonical -> Text -> Canonical
79effect effectName moduleName tipe =
80 Lambda
81 (Type (Var.fromModule moduleName tipe) [Var "msg"])
82 (Type effectName [Var "msg"])
86-- DEALIASING
89deepDealias :: Canonical -> Canonical
90deepDealias tipe =
91 case tipe of
92 Lambda a b ->
93 Lambda (deepDealias a) (deepDealias b)
95 Var _ ->
96 tipe
98 Record fields ext ->
99 Record (map (second deepDealias) fields) (fmap deepDealias ext)
101 Aliased _name args tipe' ->
102 deepDealias (dealias args tipe')
104 Type name args ->
105 Type name (map deepDealias args)
108iteratedDealias :: Canonical -> Canonical
109iteratedDealias tipe =
110 case tipe of
111 Aliased _ args realType ->
112 iteratedDealias (dealias args realType)
114 _ ->
115 tipe
118dealias :: [(Text, Canonical)] -> Aliased Canonical -> Canonical
119dealias args aliasType =
120 case aliasType of
121 Holey tipe ->
122 dealiasHelp (Map.fromList args) tipe
124 Filled tipe ->
125 tipe
128dealiasHelp :: Map.Map Text Canonical -> Canonical -> Canonical
129dealiasHelp typeTable tipe =
130 let
131 go =
132 dealiasHelp typeTable
133 in
134 case tipe of
135 Lambda a b ->
136 Lambda (go a) (go b)
138 Var x ->
139 Map.findWithDefault tipe x typeTable
141 Record fields ext ->
142 Record (map (second go) fields) (fmap go ext)
144 Aliased original args t' ->
145 Aliased original (map (second go) args) t'
147 Type name args ->
148 Type name (map go args)
152-- COLLECT LAMBDAS
155collectLambdas :: Canonical -> [Canonical]
156collectLambdas tipe =
157 case tipe of
158 Lambda arg result ->
159 arg : collectLambdas result
161 _ ->
162 [tipe]
166-- BINARY
169instance Binary Canonical where
170 put tipe =
171 case tipe of
172 Lambda t1 t2 ->
173 putWord8 0 >> put t1 >> put t2
175 Var x ->
176 putWord8 1 >> put x
178 Record fs ext ->
179 putWord8 2 >> put fs >> put ext
181 Aliased var args t ->
182 putWord8 3 >> put var >> put args >> put t
184 Type name ts ->
185 let
186 potentialWord =
187 length ts + 5
188 in
189 if potentialWord <= fromIntegral (maxBound :: Word8) then
190 do putWord8 (fromIntegral potentialWord)
191 put name
192 mapM_ put ts
193 else
194 putWord8 4 >> put name >> put ts
196 get =
197 do word <- getWord8
198 case word of
199 0 -> liftM2 Lambda get get
200 1 -> liftM Var get
201 2 -> liftM2 Record get get
202 3 -> liftM3 Aliased get get get
203 4 -> liftM2 Type get get
204 n -> liftM2 Type get (replicateM (fromIntegral (n - 5)) get)
207instance Binary t => Binary (Aliased t) where
208 put aliasType =
209 case aliasType of
210 Holey tipe ->
211 putWord8 0 >> put tipe
213 Filled tipe ->
214 putWord8 1 >> put tipe
216 get =
217 do n <- getWord8
218 case n of
219 0 -> liftM Holey get
220 1 -> liftM Filled get
221 _ -> error "Error reading a valid type from serialized string"