git.iko.soy/elk
on 2feb357 help sign in
elk/src/AST/Variable.hs
364 lines 6.2 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module AST.Variable where
5import Data.Binary
6import qualified Data.Maybe as Maybe
7import Data.Monoid ((<>))
8import qualified Data.Set as Set
9import qualified Data.Text as Text
10import Data.Text (Text)
12import qualified AST.Helpers as Help
13import qualified AST.Module.Name as ModuleName
17-- RAW NAMES
20newtype Raw = Raw Text
21 deriving (Eq, Ord)
25-- CANONICAL NAMES
28data Home
29 = BuiltIn
30 | Module ModuleName.Canonical
31 | TopLevel ModuleName.Canonical
32 | Local
33 deriving (Eq, Ord)
36data Canonical = Canonical
37 { _home :: !Home
38 , _name :: !Text
39 }
40 deriving (Eq, Ord)
43local :: Text -> Canonical
44local x =
45 Canonical Local x
48topLevel :: ModuleName.Canonical -> Text -> Canonical
49topLevel home x =
50 Canonical (TopLevel home) x
53builtin :: Text -> Canonical
54builtin x =
55 Canonical BuiltIn x
58fromModule :: ModuleName.Canonical -> Text -> Canonical
59fromModule home name =
60 Canonical (Module home) name
63localize :: Canonical -> Canonical
64localize var@(Canonical home name) =
65 case home of
66 TopLevel _ ->
67 Canonical Local name
69 _ ->
70 var
73inCore :: ModuleName.Raw -> Text -> Canonical
74inCore home name =
75 Canonical (Module (ModuleName.inCore home)) name
78inHtml :: ModuleName.Raw -> Text -> Canonical
79inHtml home name =
80 Canonical (Module (ModuleName.inHtml home)) name
83cmd :: Canonical
84cmd =
85 inCore "Platform.Cmd" "Cmd"
88sub :: Canonical
89sub =
90 inCore "Platform.Sub" "Sub"
94-- VARIABLE RECOGNIZERS
97isLocalHome :: Home -> Bool
98isLocalHome home =
99 case home of
100 BuiltIn ->
101 False
103 Module _ ->
104 False
106 TopLevel _ ->
107 True
109 Local ->
110 True
113is :: ModuleName.Raw -> Text -> Canonical -> Bool
114is home name var =
115 var == inCore home name
118isJson :: Canonical -> Bool
119isJson =
120 is "Json.Encode" "Value"
123isMaybe :: Canonical -> Bool
124isMaybe =
125 is "Maybe" "Maybe"
127isArray :: Canonical -> Bool
128isArray =
129 is "Array" "Array"
132isTask :: Canonical -> Bool
133isTask =
134 is "Task" "Task"
137isList :: Canonical -> Bool
138isList v =
139 v == Canonical BuiltIn "List"
142isNative :: Canonical -> Bool
143isNative v =
144 case v of
145 Canonical (Module name) _ ->
146 ModuleName.canonicalIsNative name
148 _ ->
149 False
152isTuple :: Canonical -> Bool
153isTuple v =
154 case v of
155 Canonical BuiltIn name ->
156 Help.isTuple name
158 _ ->
159 False
162isPrimitive :: Canonical -> Bool
163isPrimitive v =
164 case v of
165 Canonical BuiltIn name ->
166 Set.member name primitiveSet
168 _ ->
169 False
172primitiveSet :: Set.Set Text
173primitiveSet =
174 Set.fromList ["Int","Float","String","Bool"]
177isPrim :: Text -> Canonical -> Bool
178isPrim prim (Canonical home name) =
179 case home of
180 BuiltIn ->
181 name == prim
183 _ ->
184 False
187isLocal :: (Text -> Bool) -> Canonical -> Bool
188isLocal check (Canonical home name) =
189 case home of
190 Local ->
191 check name
193 _ ->
194 False
198-- VARIABLE TO STRING
201toString :: (ToText a) => a -> String
202toString var =
203 Text.unpack (toText var)
206class ToText a where
207 toText :: a -> Text
210instance ToText Raw where
211 toText (Raw name) =
212 name
215instance ToText Canonical where
216 toText (Canonical home name) =
217 case home of
218 BuiltIn ->
219 name
221 Module moduleName ->
222 ModuleName.canonicalToText moduleName <> "." <> name
224 TopLevel _ ->
225 name
227 Local ->
228 name
232-- LISTINGS
235-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
236data Listing a =
237 Listing
238 { _explicits :: [a]
239 , _open :: Bool
240 }
241 deriving (Eq, Ord)
244openListing :: Listing a
245openListing =
246 Listing [] True
249closedListing :: Listing a
250closedListing =
251 Listing [] False
254listing :: [a] -> Listing a
255listing xs =
256 Listing xs False
259-- | A value that can be imported or exported
260data Value
261 = Value !Text
262 | Alias !Text
263 | Union !Text !(Listing Text)
264 deriving (Eq, Ord)
268-- CATEGORIZING VALUES
271getValues :: [Value] -> [Text]
272getValues values =
273 Maybe.mapMaybe getValue values
276getValue :: Value -> Maybe Text
277getValue value =
278 case value of
279 Value name -> Just name
280 Alias _ -> Nothing
281 Union _ _ -> Nothing
284getAliases :: [Value] -> [Text]
285getAliases values =
286 Maybe.mapMaybe getAlias values
289getAlias :: Value -> Maybe Text
290getAlias value =
291 case value of
292 Value _-> Nothing
293 Alias name -> Just name
294 Union _ _ -> Nothing
297getUnions :: [Value] -> [(Text, Listing Text)]
298getUnions values =
299 Maybe.mapMaybe getUnion values
302getUnion :: Value -> Maybe (Text, Listing Text)
303getUnion value =
304 case value of
305 Value _ -> Nothing
306 Alias _ -> Nothing
307 Union name ctors -> Just (name, ctors)
311-- BINARY SERIALIZATION
314instance Binary Canonical where
315 put (Canonical home name) =
316 case home of
317 BuiltIn ->
318 putWord8 0 >> put name
320 Module path ->
321 putWord8 1 >> put path >> put name
323 TopLevel path ->
324 putWord8 2 >> put path >> put name
326 Local ->
327 putWord8 3 >> put name
329 get =
330 do tag <- getWord8
331 case tag of
332 0 -> Canonical BuiltIn <$> get
333 1 -> Canonical . Module <$> get <*> get
334 2 -> Canonical . TopLevel <$> get <*> get
335 3 -> Canonical Local <$> get
336 _ -> error "Unexpected tag when deserializing canonical variable"
339instance Binary Value where
340 put portable =
341 case portable of
342 Value name ->
343 putWord8 0 >> put name
345 Alias name ->
346 putWord8 1 >> put name
348 Union name ctors ->
349 putWord8 2 >> put name >> put ctors
351 get =
352 do tag <- getWord8
353 case tag of
354 0 -> Value <$> get
355 1 -> Alias <$> get
356 2 -> Union <$> get <*> get
357 _ -> error "Error reading valid import/export information from serialized string"
360instance (Binary a) => Binary (Listing a) where
361 put (Listing explicits open) =
362 put explicits >> put open
364 get = Listing <$> get <*> get