git.iko.soy/elk
on 2cd0692 help sign in
elk/src/AST/Variable.hs
299 lines 5.9 kB history raw
1module AST.Variable where
3import Control.Applicative ((<$>), (<*>))
4import Data.Binary
5import qualified Data.List as List
6import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import Text.PrettyPrint as P
10import qualified AST.Helpers as Help
11import qualified Reporting.PrettyPrint as P
14-- VARIABLES
16newtype Raw = Raw String
17 deriving (Eq, Ord, Show)
20data Home
21 = BuiltIn
22 | Module [String]
23 | TopLevel [String]
24 | Local
25 deriving (Eq, Ord, Show)
28data Canonical = Canonical
29 { home :: !Home
30 , name :: !String
31 }
32 deriving (Eq, Ord, Show)
35local :: String -> Canonical
36local x = Canonical Local x
39topLevel :: [String] -> String -> Canonical
40topLevel names x = Canonical (TopLevel names) x
43builtin :: String -> Canonical
44builtin x = Canonical BuiltIn x
47fromModule :: [String] -> String -> Canonical
48fromModule home name =
49 Canonical (Module home) name
52-- VARIABLE RECOGNIZERS
54is :: [String] -> String -> Canonical -> Bool
55is home name var =
56 var == Canonical (Module home) name
59isJson :: Canonical -> Bool
60isJson =
61 is ["Json", "Encode"] "Value"
64isMaybe :: Canonical -> Bool
65isMaybe =
66 is ["Maybe"] "Maybe"
68isArray :: Canonical -> Bool
69isArray =
70 is ["Array"] "Array"
73isTask :: Canonical -> Bool
74isTask =
75 is ["Task"] "Task"
78isSignal :: Canonical -> Bool
79isSignal =
80 is ["Signal"] "Signal"
83isList :: Canonical -> Bool
84isList v =
85 v == Canonical BuiltIn "List"
88isTuple :: Canonical -> Bool
89isTuple v =
90 case v of
91 Canonical BuiltIn name -> Help.isTuple name
92 _ -> False
95isPrimitive :: Canonical -> Bool
96isPrimitive v =
97 case v of
98 Canonical BuiltIn name ->
99 name `elem` ["Int","Float","String","Bool"]
100 _ ->
101 False
104isPrim :: String -> Canonical -> Bool
105isPrim prim v =
106 case v of
107 Canonical BuiltIn name -> name == prim
108 _ -> False
111isText :: Canonical -> Bool
112isText =
113 is ["Text"] "Text"
116-- VARIABLE TO STRING
118class ToString a where
119 toString :: a -> String
122instance ToString Raw where
123 toString (Raw name) =
124 name
127instance ToString Canonical where
128 toString (Canonical home name) =
129 case home of
130 BuiltIn -> name
131 Module path -> List.intercalate "." (path ++ [name])
132 Local -> name
133 TopLevel _ -> name
136-- LISTINGS
138-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
139data Listing a = Listing
140 { _explicits :: [a]
141 , _open :: Bool
142 }
143 deriving (Eq, Ord, Show)
146openListing :: Listing a
147openListing =
148 Listing [] True
151closedListing :: Listing a
152closedListing =
153 Listing [] False
156listing :: [a] -> Listing a
157listing xs =
158 Listing xs False
161-- | A value that can be imported or exported
162data Value
163 = Value !String
164 | Alias !String
165 | Union !String !(Listing String)
166 deriving (Eq, Ord, Show)
169-- CATEGORIZING VALUES
171getValues :: [Value] -> [String]
172getValues values =
173 Maybe.mapMaybe getValue values
176getValue :: Value -> Maybe String
177getValue value =
178 case value of
179 Value name -> Just name
180 Alias _ -> Nothing
181 Union _ _ -> Nothing
184getAliases :: [Value] -> [String]
185getAliases values =
186 Maybe.mapMaybe getAlias values
189getAlias :: Value -> Maybe String
190getAlias value =
191 case value of
192 Value _-> Nothing
193 Alias name -> Just name
194 Union _ _ -> Nothing
197getUnions :: [Value] -> [(String, Listing String)]
198getUnions values =
199 Maybe.mapMaybe getUnion values
202getUnion :: Value -> Maybe (String, Listing String)
203getUnion value =
204 case value of
205 Value _ -> Nothing
206 Alias _ -> Nothing
207 Union name ctors -> Just (name, ctors)
210-- PRETTY VARIABLES
212instance P.Pretty Raw where
213 pretty _ _ (Raw name) =
214 if Help.isOp name
215 then P.parens (P.text name)
216 else P.text name
219instance P.Pretty Canonical where
220 pretty dealiaser _ var =
221 let
222 name = toString var
223 in
224 P.text (maybe name id (Map.lookup name dealiaser))
227instance P.Pretty a => P.Pretty (Listing a) where
228 pretty dealiaser _ (Listing explicits open) =
229 let dots = [if open then P.text ".." else P.empty]
230 in
231 P.parens (P.commaCat (map (P.pretty dealiaser False) explicits ++ dots))
234instance P.Pretty Value where
235 pretty dealiaser _ portable =
236 case portable of
237 Value name ->
238 P.text name
240 Alias name ->
241 P.text name
243 Union name ctors ->
244 P.text name <> P.pretty dealiaser False ctors
247-- BINARY SERIALIZATION
249instance Binary Canonical where
250 put (Canonical home name) =
251 case home of
252 BuiltIn ->
253 putWord8 0 >> put name
255 Module path ->
256 putWord8 1 >> put path >> put name
258 Local ->
259 putWord8 2 >> put name
261 TopLevel path ->
262 putWord8 3 >> put path >> put name
264 get =
265 do tag <- getWord8
266 case tag of
267 0 -> Canonical BuiltIn <$> get
268 1 -> Canonical . Module <$> get <*> get
269 2 -> Canonical Local <$> get
270 3 -> Canonical . TopLevel <$> get <*> get
271 _ -> error "Unexpected tag when deserializing canonical variable"
274instance Binary Value where
275 put portable =
276 case portable of
277 Value name ->
278 putWord8 0 >> put name
280 Alias name ->
281 putWord8 1 >> put name
283 Union name ctors ->
284 putWord8 2 >> put name >> put ctors
286 get =
287 do tag <- getWord8
288 case tag of
289 0 -> Value <$> get
290 1 -> Alias <$> get
291 2 -> Union <$> get <*> get
292 _ -> error "Error reading valid import/export information from serialized string"
295instance (Binary a) => Binary (Listing a) where
296 put (Listing explicits open) =
297 put explicits >> put open
299 get = Listing <$> get <*> get