git.iko.soy/elk
on bfb8eca help sign in
elk/src/AST/Type.hs
229 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
14import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)
15import Data.Binary
16import qualified Data.Map as Map
18import qualified AST.Module.Name as ModuleName
19import Elm.Name (Name)
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 Name
35 | RType R.Region (Maybe Name) Name [Raw]
36 | RRecord [(A.Located Name, Raw)] (Maybe Raw)
37 | RUnit
38 | RTuple Raw Raw [Raw]
41data Canonical
42 = Lambda Canonical Canonical
43 | Var Name
44 | Type ModuleName.Canonical Name [Canonical]
45 | Record (Map.Map Name Canonical) (Maybe Canonical)
46 | Unit
47 | Tuple Canonical Canonical [Canonical]
48 | Aliased ModuleName.Canonical Name [(Name, Canonical)] (Aliased Canonical)
49 deriving (Eq, Ord)
52data Aliased t
53 = Holey t
54 | Filled t
55 deriving (Eq, Ord)
58data Super
59 = Number
60 | Comparable
61 | Appendable
62 | CompAppend
63 deriving (Eq)
67-- CONSTRUCT USEFUL TYPES
70cmd :: ModuleName.Canonical -> Name -> Canonical
71cmd moduleName tipe =
72 Lambda
73 (Type moduleName tipe [Var "msg"])
74 (Type (ModuleName.inCore "Platform.Cmd") "Cmd" [Var "msg"])
77sub :: ModuleName.Canonical -> Name -> Canonical
78sub moduleName tipe =
79 Lambda
80 (Type moduleName tipe [Var "msg"])
81 (Type (ModuleName.inCore "Platform.Sub") "Sub" [Var "msg"])
85-- DEALIASING
88deepDealias :: Canonical -> Canonical
89deepDealias tipe =
90 case tipe of
91 Lambda a b ->
92 Lambda (deepDealias a) (deepDealias b)
94 Var _ ->
95 tipe
97 Record fields ext ->
98 Record (Map.map deepDealias fields) (fmap deepDealias ext)
100 Aliased _ _ args tipe' ->
101 deepDealias (dealias args tipe')
103 Type home name args ->
104 Type home name (map deepDealias args)
106 Unit ->
107 Unit
109 Tuple a b cs ->
110 Tuple (deepDealias a) (deepDealias b) (map deepDealias cs)
113iteratedDealias :: Canonical -> Canonical
114iteratedDealias tipe =
115 case tipe of
116 Aliased _ _ args realType ->
117 iteratedDealias (dealias args realType)
119 _ ->
120 tipe
123dealias :: [(Name, 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 Name 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.map go fields) (fmap go ext)
149 Aliased home name args t' ->
150 Aliased home name (map (fmap go) args) t'
152 Type home name args ->
153 Type home name (map go args)
155 Unit ->
156 Unit
158 Tuple a b cs ->
159 Tuple (go a) (go b) (map go cs)
163-- COLLECT LAMBDAS
166collectLambdas :: Canonical -> [Canonical]
167collectLambdas tipe =
168 case tipe of
169 Lambda arg result ->
170 arg : collectLambdas result
172 _ ->
173 [tipe]
177-- BINARY
180instance Binary Canonical where
181 put tipe =
182 case tipe of
183 Lambda a b -> putWord8 0 >> put a >> put b
184 Var a -> putWord8 1 >> put a
185 Record a b -> putWord8 2 >> put a >> put b
186 Unit -> putWord8 3
187 Tuple a b c -> putWord8 4 >> put a >> put b >> put c
188 Aliased a b c d -> putWord8 5 >> put a >> put b >> put c >> put d
189 Type home name ts ->
190 let
191 potentialWord =
192 length ts + 7
193 in
194 if potentialWord <= fromIntegral (maxBound :: Word8) then
195 do putWord8 (fromIntegral potentialWord)
196 put home
197 put name
198 mapM_ put ts
199 else
200 putWord8 6 >> put home >> put name >> put ts
202 get =
203 do word <- getWord8
204 case word of
205 0 -> liftM2 Lambda get get
206 1 -> liftM Var get
207 2 -> liftM2 Record get get
208 3 -> return Unit
209 4 -> liftM3 Tuple get get get
210 5 -> liftM4 Aliased get get get get
211 6 -> liftM3 Type get get get
212 n -> liftM3 Type get get (replicateM (fromIntegral (n - 7)) get)
215instance Binary t => Binary (Aliased t) where
216 put aliasType =
217 case aliasType of
218 Holey tipe ->
219 putWord8 0 >> put tipe
221 Filled tipe ->
222 putWord8 1 >> put tipe
224 get =
225 do n <- getWord8
226 case n of
227 0 -> liftM Holey get
228 1 -> liftM Filled get
229 _ -> error "Error reading a valid type from serialized string"