git.iko.soy/elk
on e00a3f3 help sign in
elk/src/AST/Type.hs
224 lines 4.3 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)
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 Var.Raw
37 | RApp Raw [Raw]
38 | RRecord [(A.Located Text, Raw)] (Maybe Raw)
41data Canonical
42 = Lambda Canonical Canonical
43 | Var Text
44 | Type Var.Canonical
45 | App Canonical [Canonical]
46 | Record [(Text, Canonical)] (Maybe Canonical)
47 | Aliased Var.Canonical [(Text, Canonical)] (Aliased Canonical)
48 deriving (Eq, Ord)
51data Aliased t
52 = Holey t
53 | Filled t
54 deriving (Eq, Ord)
58-- CONSTRUCT USEFUL TYPES
61tuple :: R.Region -> [Raw] -> Raw
62tuple region types =
63 let
64 name =
65 Var.Raw (Help.makeTuple (length types))
66 in
67 A.A region (RApp (A.A region (RType name)) types)
70cmd :: ModuleName.Canonical -> Text -> Canonical
71cmd =
72 effect Var.cmd
75sub :: ModuleName.Canonical -> Text -> Canonical
76sub =
77 effect Var.sub
80effect :: Var.Canonical -> ModuleName.Canonical -> Text -> Canonical
81effect effectName moduleName tipe =
82 Lambda
83 (App (Type (Var.fromModule moduleName tipe)) [Var "msg"])
84 (App (Type effectName) [Var "msg"])
88-- DEALIASING
91deepDealias :: Canonical -> Canonical
92deepDealias tipe =
93 case tipe of
94 Lambda a b ->
95 Lambda (deepDealias a) (deepDealias b)
97 Var _ ->
98 tipe
100 Record fields ext ->
101 Record (map (second deepDealias) fields) (fmap deepDealias ext)
103 Aliased _name args tipe' ->
104 deepDealias (dealias args tipe')
106 Type _ ->
107 tipe
109 App f args ->
110 App (deepDealias f) (map deepDealias args)
113iteratedDealias :: Canonical -> Canonical
114iteratedDealias tipe =
115 case tipe of
116 Aliased _ args realType ->
117 iteratedDealias (dealias args realType)
119 _ ->
120 tipe
123dealias :: [(Text, Canonical)] -> Aliased Canonical -> Canonical
124dealias args aliasType =
125 case aliasType of
126 Holey tipe ->
127 dealiasHelp (Map.fromList args) tipe
129 Filled tipe ->
130 tipe
133dealiasHelp :: Map.Map Text Canonical -> Canonical -> Canonical
134dealiasHelp typeTable tipe =
135 let
136 go =
137 dealiasHelp typeTable
138 in
139 case tipe of
140 Lambda a b ->
141 Lambda (go a) (go b)
143 Var x ->
144 Map.findWithDefault tipe x typeTable
146 Record fields ext ->
147 Record (map (second go) fields) (fmap go ext)
149 Aliased original args t' ->
150 Aliased original (map (second go) args) t'
152 Type _ ->
153 tipe
155 App f args ->
156 App (go f) (map go args)
160-- COLLECT LAMBDAS
163collectLambdas :: Canonical -> [Canonical]
164collectLambdas tipe =
165 case tipe of
166 Lambda arg result ->
167 arg : collectLambdas result
169 _ ->
170 [tipe]
174-- BINARY
177instance Binary Canonical where
178 put tipe =
179 case tipe of
180 Lambda t1 t2 ->
181 putWord8 0 >> put t1 >> put t2
183 Var x ->
184 putWord8 1 >> put x
186 Type name ->
187 putWord8 2 >> put name
189 App t1 t2 ->
190 putWord8 3 >> put t1 >> put t2
192 Record fs ext ->
193 putWord8 4 >> put fs >> put ext
195 Aliased var args t ->
196 putWord8 5 >> put var >> put args >> put t
198 get =
199 do n <- getWord8
200 case n of
201 0 -> liftM2 Lambda get get
202 1 -> liftM Var get
203 2 -> liftM Type get
204 3 -> liftM2 App get get
205 4 -> liftM2 Record get get
206 5 -> liftM3 Aliased get get get
207 _ -> error "Error reading a valid type from serialized string"
210instance Binary t => Binary (Aliased t) where
211 put aliasType =
212 case aliasType of
213 Holey tipe ->
214 putWord8 0 >> put tipe
216 Filled tipe ->
217 putWord8 1 >> put tipe
219 get =
220 do n <- getWord8
221 case n of
222 0 -> liftM Holey get
223 1 -> liftM Filled get
224 _ -> error "Error reading a valid type from serialized string"