git.iko.soy/elk
on fbff9ce help sign in
elk/src/AST/Type.hs
230 lines 4.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module AST.Type
4 ( Raw, Raw'(..)
5 , Canonical(..), Aliased(..)
6 , Super(..)
7 , deepDealias, iteratedDealias, dealias
8 , collectLambdas
9 , tuple, cmd, sub
10 )
11 where
13import Control.Arrow (second)
14import Control.Monad (liftM, liftM2, liftM3, replicateM)
15import Data.Binary
16import qualified Data.Map as Map
17import Data.Text (Text)
19import qualified AST.Helpers as Help
20import qualified AST.Module.Name as ModuleName
21import qualified AST.Variable as Var
22import qualified Reporting.Annotation as A
23import qualified Reporting.Region as R
27-- DEFINITION
30type Raw =
31 A.Located Raw'
34data Raw'
35 = RLambda Raw Raw
36 | RVar Text
37 | RType (A.Located Var.Raw) [Raw]
38 | RRecord [(A.Located Text, Raw)] (Maybe Raw)
41data Canonical
42 = Lambda Canonical Canonical
43 | Var Text
44 | Type Var.Canonical [Canonical]
45 | Record [(Text, Canonical)] (Maybe Canonical)
46 | Aliased Var.Canonical [(Text, Canonical)] (Aliased Canonical)
47 deriving (Eq, Ord)
50data Aliased t
51 = Holey t
52 | Filled t
53 deriving (Eq, Ord)
56data Super
57 = Number
58 | Comparable
59 | Appendable
60 | CompAppend
61 deriving (Eq)
65-- CONSTRUCT USEFUL TYPES
68tuple :: R.Region -> [Raw] -> Raw
69tuple region types =
70 let
71 name =
72 Var.Raw (Help.makeTuple (length types))
73 in
74 A.A region (RType (A.A region name) types)
77cmd :: ModuleName.Canonical -> Text -> Canonical
78cmd =
79 effect Var.cmd
82sub :: ModuleName.Canonical -> Text -> Canonical
83sub =
84 effect Var.sub
87effect :: Var.Canonical -> ModuleName.Canonical -> Text -> Canonical
88effect effectName moduleName tipe =
89 Lambda
90 (Type (Var.fromModule moduleName tipe) [Var "msg"])
91 (Type effectName [Var "msg"])
95-- DEALIASING
98deepDealias :: Canonical -> Canonical
99deepDealias tipe =
100 case tipe of
101 Lambda a b ->
102 Lambda (deepDealias a) (deepDealias b)
104 Var _ ->
105 tipe
107 Record fields ext ->
108 Record (map (second deepDealias) fields) (fmap deepDealias ext)
110 Aliased _name args tipe' ->
111 deepDealias (dealias args tipe')
113 Type name args ->
114 Type name (map deepDealias args)
117iteratedDealias :: Canonical -> Canonical
118iteratedDealias tipe =
119 case tipe of
120 Aliased _ args realType ->
121 iteratedDealias (dealias args realType)
123 _ ->
124 tipe
127dealias :: [(Text, Canonical)] -> Aliased Canonical -> Canonical
128dealias args aliasType =
129 case aliasType of
130 Holey tipe ->
131 dealiasHelp (Map.fromList args) tipe
133 Filled tipe ->
134 tipe
137dealiasHelp :: Map.Map Text Canonical -> Canonical -> Canonical
138dealiasHelp typeTable tipe =
139 let
140 go =
141 dealiasHelp typeTable
142 in
143 case tipe of
144 Lambda a b ->
145 Lambda (go a) (go b)
147 Var x ->
148 Map.findWithDefault tipe x typeTable
150 Record fields ext ->
151 Record (map (second go) fields) (fmap go ext)
153 Aliased original args t' ->
154 Aliased original (map (second go) args) t'
156 Type name args ->
157 Type name (map go args)
161-- COLLECT LAMBDAS
164collectLambdas :: Canonical -> [Canonical]
165collectLambdas tipe =
166 case tipe of
167 Lambda arg result ->
168 arg : collectLambdas result
170 _ ->
171 [tipe]
175-- BINARY
178instance Binary Canonical where
179 put tipe =
180 case tipe of
181 Lambda t1 t2 ->
182 putWord8 0 >> put t1 >> put t2
184 Var x ->
185 putWord8 1 >> put x
187 Record fs ext ->
188 putWord8 2 >> put fs >> put ext
190 Aliased var args t ->
191 putWord8 3 >> put var >> put args >> put t
193 Type name ts ->
194 let
195 potentialWord =
196 length ts + 5
197 in
198 if potentialWord <= fromIntegral (maxBound :: Word8) then
199 do putWord8 (fromIntegral potentialWord)
200 put name
201 mapM_ put ts
202 else
203 putWord8 4 >> put name >> put ts
205 get =
206 do word <- getWord8
207 case word of
208 0 -> liftM2 Lambda get get
209 1 -> liftM Var get
210 2 -> liftM2 Record get get
211 3 -> liftM3 Aliased get get get
212 4 -> liftM2 Type get get
213 n -> liftM2 Type get (replicateM (fromIntegral (n - 5)) get)
216instance Binary t => Binary (Aliased t) where
217 put aliasType =
218 case aliasType of
219 Holey tipe ->
220 putWord8 0 >> put tipe
222 Filled tipe ->
223 putWord8 1 >> put tipe
225 get =
226 do n <- getWord8
227 case n of
228 0 -> liftM Holey get
229 1 -> liftM Filled get
230 _ -> error "Error reading a valid type from serialized string"