git.iko.soy/elk
on a672aa7 help sign in
elk/src/AST/Variable.hs
374 lines 6.4 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
83inWebGL :: ModuleName.Raw -> Text -> Canonical
84inWebGL home name =
85 Canonical (Module (ModuleName.inWebGL home)) name
88inLinearAlgebra :: ModuleName.Raw -> Text -> Canonical
89inLinearAlgebra home name =
90 Canonical (Module (ModuleName.inLinearAlgebra home)) name
93cmd :: Canonical
94cmd =
95 inCore "Platform.Cmd" "Cmd"
98sub :: Canonical
99sub =
100 inCore "Platform.Sub" "Sub"
104-- VARIABLE RECOGNIZERS
107isLocalHome :: Home -> Bool
108isLocalHome home =
109 case home of
110 BuiltIn ->
111 False
113 Module _ ->
114 False
116 TopLevel _ ->
117 True
119 Local ->
120 True
123is :: ModuleName.Raw -> Text -> Canonical -> Bool
124is home name var =
125 var == inCore home name
128isJson :: Canonical -> Bool
129isJson =
130 is "Json.Encode" "Value"
133isMaybe :: Canonical -> Bool
134isMaybe =
135 is "Maybe" "Maybe"
137isArray :: Canonical -> Bool
138isArray =
139 is "Array" "Array"
142isTask :: Canonical -> Bool
143isTask =
144 is "Task" "Task"
147isList :: Canonical -> Bool
148isList v =
149 v == Canonical BuiltIn "List"
152isNative :: Canonical -> Bool
153isNative v =
154 case v of
155 Canonical (Module name) _ ->
156 ModuleName.canonicalIsNative name
158 _ ->
159 False
162isTuple :: Canonical -> Bool
163isTuple v =
164 case v of
165 Canonical BuiltIn name ->
166 Help.isTuple name
168 _ ->
169 False
172isPrimitive :: Canonical -> Bool
173isPrimitive v =
174 case v of
175 Canonical BuiltIn name ->
176 Set.member name primitiveSet
178 _ ->
179 False
182primitiveSet :: Set.Set Text
183primitiveSet =
184 Set.fromList ["Int","Float","String","Bool"]
187isPrim :: Text -> Canonical -> Bool
188isPrim prim (Canonical home name) =
189 case home of
190 BuiltIn ->
191 name == prim
193 _ ->
194 False
197isLocal :: (Text -> Bool) -> Canonical -> Bool
198isLocal check (Canonical home name) =
199 case home of
200 Local ->
201 check name
203 _ ->
204 False
208-- VARIABLE TO STRING
211toString :: (ToText a) => a -> String
212toString var =
213 Text.unpack (toText var)
216class ToText a where
217 toText :: a -> Text
220instance ToText Raw where
221 toText (Raw name) =
222 name
225instance ToText Canonical where
226 toText (Canonical home name) =
227 case home of
228 BuiltIn ->
229 name
231 Module moduleName ->
232 ModuleName.canonicalToText moduleName <> "." <> name
234 TopLevel _ ->
235 name
237 Local ->
238 name
242-- LISTINGS
245-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
246data Listing a =
247 Listing
248 { _explicits :: [a]
249 , _open :: Bool
250 }
251 deriving (Eq, Ord)
254openListing :: Listing a
255openListing =
256 Listing [] True
259closedListing :: Listing a
260closedListing =
261 Listing [] False
264listing :: [a] -> Listing a
265listing xs =
266 Listing xs False
269-- | A value that can be imported or exported
270data Value
271 = Value !Text
272 | Alias !Text
273 | Union !Text !(Listing Text)
274 deriving (Eq, Ord)
278-- CATEGORIZING VALUES
281getValues :: [Value] -> [Text]
282getValues values =
283 Maybe.mapMaybe getValue values
286getValue :: Value -> Maybe Text
287getValue value =
288 case value of
289 Value name -> Just name
290 Alias _ -> Nothing
291 Union _ _ -> Nothing
294getAliases :: [Value] -> [Text]
295getAliases values =
296 Maybe.mapMaybe getAlias values
299getAlias :: Value -> Maybe Text
300getAlias value =
301 case value of
302 Value _-> Nothing
303 Alias name -> Just name
304 Union _ _ -> Nothing
307getUnions :: [Value] -> [(Text, Listing Text)]
308getUnions values =
309 Maybe.mapMaybe getUnion values
312getUnion :: Value -> Maybe (Text, Listing Text)
313getUnion value =
314 case value of
315 Value _ -> Nothing
316 Alias _ -> Nothing
317 Union name ctors -> Just (name, ctors)
321-- BINARY SERIALIZATION
324instance Binary Canonical where
325 put (Canonical home name) =
326 case home of
327 BuiltIn ->
328 putWord8 0 >> put name
330 Module path ->
331 putWord8 1 >> put path >> put name
333 TopLevel path ->
334 putWord8 2 >> put path >> put name
336 Local ->
337 putWord8 3 >> put name
339 get =
340 do tag <- getWord8
341 case tag of
342 0 -> Canonical BuiltIn <$> get
343 1 -> Canonical . Module <$> get <*> get
344 2 -> Canonical . TopLevel <$> get <*> get
345 3 -> Canonical Local <$> get
346 _ -> error "Unexpected tag when deserializing canonical variable"
349instance Binary Value where
350 put portable =
351 case portable of
352 Value name ->
353 putWord8 0 >> put name
355 Alias name ->
356 putWord8 1 >> put name
358 Union name ctors ->
359 putWord8 2 >> put name >> put ctors
361 get =
362 do tag <- getWord8
363 case tag of
364 0 -> Value <$> get
365 1 -> Alias <$> get
366 2 -> Union <$> get <*> get
367 _ -> error "Error reading valid import/export information from serialized string"
370instance (Binary a) => Binary (Listing a) where
371 put (Listing explicits open) =
372 put explicits >> put open
374 get = Listing <$> get <*> get