git.iko.soy/elk
on fe7bbbd help sign in
elk/src/AST/Type.hs
223 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 Data.Binary
14import qualified Data.Map as Map
15import qualified Data.Text as Text
16import Data.Text (Text)
18import qualified AST.Module.Name as ModuleName
19import qualified AST.Variable as Var
20import qualified Reporting.Annotation as A
21import qualified Reporting.Region as R
25-- DEFINITION
28type Raw =
29 A.Located Raw'
32data Raw'
33 = RLambda Raw Raw
34 | RVar Text
35 | RType Var.Raw
36 | RApp Raw [Raw]
37 | RRecord [(A.Located Text, Raw)] (Maybe Raw)
40data Canonical
41 = Lambda Canonical Canonical
42 | Var Text
43 | Type Var.Canonical
44 | App 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)
57-- CONSTRUCT USEFUL TYPES
60tuple :: R.Region -> [Raw] -> Raw
61tuple region types =
62 let
63 name =
64 Var.Raw (Text.append "_Tuple" (Text.pack (show (length types))))
65 in
66 A.A region (RApp (A.A region (RType name)) types)
69cmd :: ModuleName.Canonical -> Text -> Canonical
70cmd =
71 effect Var.cmd
74sub :: ModuleName.Canonical -> Text -> Canonical
75sub =
76 effect Var.sub
79effect :: Var.Canonical -> ModuleName.Canonical -> Text -> Canonical
80effect effectName moduleName tipe =
81 Lambda
82 (App (Type (Var.fromModule moduleName tipe)) [Var "msg"])
83 (App (Type effectName) [Var "msg"])
87-- DEALIASING
90deepDealias :: Canonical -> Canonical
91deepDealias tipe =
92 case tipe of
93 Lambda a b ->
94 Lambda (deepDealias a) (deepDealias b)
96 Var _ ->
97 tipe
99 Record fields ext ->
100 Record (map (second deepDealias) fields) (fmap deepDealias ext)
102 Aliased _name args tipe' ->
103 deepDealias (dealias args tipe')
105 Type _ ->
106 tipe
108 App f args ->
109 App (deepDealias f) (map deepDealias args)
112iteratedDealias :: Canonical -> Canonical
113iteratedDealias tipe =
114 case tipe of
115 Aliased _ args realType ->
116 iteratedDealias (dealias args realType)
118 _ ->
119 tipe
122dealias :: [(Text, Canonical)] -> Aliased Canonical -> Canonical
123dealias args aliasType =
124 case aliasType of
125 Holey tipe ->
126 dealiasHelp (Map.fromList args) tipe
128 Filled tipe ->
129 tipe
132dealiasHelp :: Map.Map Text Canonical -> Canonical -> Canonical
133dealiasHelp typeTable tipe =
134 let
135 go =
136 dealiasHelp typeTable
137 in
138 case tipe of
139 Lambda a b ->
140 Lambda (go a) (go b)
142 Var x ->
143 Map.findWithDefault tipe x typeTable
145 Record fields ext ->
146 Record (map (second go) fields) (fmap go ext)
148 Aliased original args t' ->
149 Aliased original (map (second go) args) t'
151 Type _ ->
152 tipe
154 App f args ->
155 App (go f) (map go args)
159-- COLLECT LAMBDAS
162collectLambdas :: Canonical -> [Canonical]
163collectLambdas tipe =
164 case tipe of
165 Lambda arg result ->
166 arg : collectLambdas result
168 _ ->
169 [tipe]
173-- BINARY
176instance Binary Canonical where
177 put tipe =
178 case tipe of
179 Lambda t1 t2 ->
180 putWord8 0 >> put t1 >> put t2
182 Var x ->
183 putWord8 1 >> put x
185 Type name ->
186 putWord8 2 >> put name
188 App t1 t2 ->
189 putWord8 3 >> put t1 >> put t2
191 Record fs ext ->
192 putWord8 4 >> put fs >> put ext
194 Aliased var args t ->
195 putWord8 5 >> put var >> put args >> put t
197 get =
198 do n <- getWord8
199 case n of
200 0 -> Lambda <$> get <*> get
201 1 -> Var <$> get
202 2 -> Type <$> get
203 3 -> App <$> get <*> get
204 4 -> Record <$> get <*> get
205 5 -> Aliased <$> get <*> get <*> get
206 _ -> error "Error reading a valid type from serialized string"
209instance Binary t => Binary (Aliased t) where
210 put aliasType =
211 case aliasType of
212 Holey tipe ->
213 putWord8 0 >> put tipe
215 Filled tipe ->
216 putWord8 1 >> put tipe
218 get =
219 do n <- getWord8
220 case n of
221 0 -> Holey <$> get
222 1 -> Filled <$> get
223 _ -> error "Error reading a valid type from serialized string"