git.iko.soy/elk
on 9111afa help sign in
elk/src/AST/Type.hs
232 lines 4.8 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 , 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.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 R.Region (Maybe Text) Text [Raw]
37 | RRecord [(A.Located Text, Raw)] (Maybe Raw)
38 | RUnit
39 | RTuple Raw Raw [Raw]
42data Canonical
43 = Lambda Canonical Canonical
44 | Var Text
45 | Type Var.Canonical [Canonical]
46 | Record [(Text, Canonical)] (Maybe Canonical)
47 | Unit
48 | Tuple Canonical Canonical [Canonical]
49 | Aliased Var.Canonical [(Text, Canonical)] (Aliased Canonical)
50 deriving (Eq, Ord)
53data Aliased t
54 = Holey t
55 | Filled t
56 deriving (Eq, Ord)
59data Super
60 = Number
61 | Comparable
62 | Appendable
63 | CompAppend
64 deriving (Eq)
68-- CONSTRUCT USEFUL TYPES
71cmd :: ModuleName.Canonical -> Text -> Canonical
72cmd =
73 effect Var.cmd
76sub :: ModuleName.Canonical -> Text -> Canonical
77sub =
78 effect Var.sub
81effect :: Var.Canonical -> ModuleName.Canonical -> Text -> Canonical
82effect effectName moduleName tipe =
83 Lambda
84 (Type (Var.fromModule moduleName tipe) [Var "msg"])
85 (Type effectName [Var "msg"])
89-- DEALIASING
92deepDealias :: Canonical -> Canonical
93deepDealias tipe =
94 case tipe of
95 Lambda a b ->
96 Lambda (deepDealias a) (deepDealias b)
98 Var _ ->
99 tipe
101 Record fields ext ->
102 Record (map (second deepDealias) fields) (fmap deepDealias ext)
104 Aliased _name args tipe' ->
105 deepDealias (dealias args tipe')
107 Type name args ->
108 Type name (map deepDealias args)
110 Unit ->
111 Unit
113 Tuple a b cs ->
114 Tuple (deepDealias a) (deepDealias b) (map deepDealias cs)
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)
159 Unit ->
160 Unit
162 Tuple a b cs ->
163 Tuple (go a) (go b) (map go cs)
167-- COLLECT LAMBDAS
170collectLambdas :: Canonical -> [Canonical]
171collectLambdas tipe =
172 case tipe of
173 Lambda arg result ->
174 arg : collectLambdas result
176 _ ->
177 [tipe]
181-- BINARY
184instance Binary Canonical where
185 put tipe =
186 case tipe of
187 Lambda t1 t2 -> putWord8 0 >> put t1 >> put t2
188 Var x -> putWord8 1 >> put x
189 Record fs ext -> putWord8 2 >> put fs >> put ext
190 Unit -> putWord8 3
191 Tuple a b cs -> putWord8 4 >> put a >> put b >> put cs
192 Aliased var args t -> putWord8 5 >> put var >> put args >> put t
193 Type name ts ->
194 let
195 potentialWord =
196 length ts + 7
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 6 >> 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 -> return Unit
212 4 -> liftM3 Tuple get get get
213 5 -> liftM3 Aliased get get get
214 6 -> liftM2 Type get get
215 n -> liftM2 Type get (replicateM (fromIntegral (n - 7)) get)
218instance Binary t => Binary (Aliased t) where
219 put aliasType =
220 case aliasType of
221 Holey tipe ->
222 putWord8 0 >> put tipe
224 Filled tipe ->
225 putWord8 1 >> put tipe
227 get =
228 do n <- getWord8
229 case n of
230 0 -> liftM Holey get
231 1 -> liftM Filled get
232 _ -> error "Error reading a valid type from serialized string"