git.iko.soy/elk
on bede6f3 help sign in
elk/src/AST/Variable.hs
362 lines 6.3 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module AST.Variable where
5import Data.Binary
6import qualified Data.Maybe as Maybe
7import qualified Data.Text as Text
8import Data.Text (Text)
10import qualified AST.Helpers as Help
11import qualified AST.Module.Name as ModuleName
15-- RAW NAMES
18newtype Raw = Raw Text
19 deriving (Eq, Ord)
23-- CANONICAL NAMES
26data Home
27 = BuiltIn
28 | Module ModuleName.Canonical
29 | TopLevel ModuleName.Canonical
30 | Local
31 deriving (Eq, Ord)
34data Canonical = Canonical
35 { _home :: !Home
36 , _name :: !Text
37 }
38 deriving (Eq, Ord)
41local :: Text -> Canonical
42local x =
43 Canonical Local x
46topLevel :: ModuleName.Canonical -> Text -> Canonical
47topLevel home x =
48 Canonical (TopLevel home) x
51builtin :: Text -> Canonical
52builtin x =
53 Canonical BuiltIn x
56fromModule :: ModuleName.Canonical -> Text -> Canonical
57fromModule home name =
58 Canonical (Module home) name
61localize :: Canonical -> Canonical
62localize var@(Canonical home name) =
63 case home of
64 TopLevel _ ->
65 Canonical Local name
67 _ ->
68 var
71inCore :: ModuleName.Raw -> Text -> Canonical
72inCore home name =
73 Canonical (Module (ModuleName.inCore home)) name
76inHtml :: ModuleName.Raw -> Text -> Canonical
77inHtml home name =
78 Canonical (Module (ModuleName.inHtml home)) name
81inWebGL :: ModuleName.Raw -> Text -> Canonical
82inWebGL home name =
83 Canonical (Module (ModuleName.inWebGL home)) name
86inLinearAlgebra :: ModuleName.Raw -> Text -> Canonical
87inLinearAlgebra home name =
88 Canonical (Module (ModuleName.inLinearAlgebra home)) name
91cmd :: Canonical
92cmd =
93 inCore "Platform.Cmd" "Cmd"
96sub :: Canonical
97sub =
98 inCore "Platform.Sub" "Sub"
102-- VARIABLE RECOGNIZERS
105isLocalHome :: Home -> Bool
106isLocalHome home =
107 case home of
108 BuiltIn ->
109 False
111 Module _ ->
112 False
114 TopLevel _ ->
115 True
117 Local ->
118 True
121is :: ModuleName.Raw -> Text -> Canonical -> Bool
122is home name var =
123 var == inCore home name
126isJson :: Canonical -> Bool
127isJson =
128 is "Json.Encode" "Value"
131isMaybe :: Canonical -> Bool
132isMaybe =
133 is "Maybe" "Maybe"
135isArray :: Canonical -> Bool
136isArray =
137 is "Array" "Array"
140isTask :: Canonical -> Bool
141isTask =
142 is "Task" "Task"
145isList :: Canonical -> Bool
146isList v =
147 v == Canonical BuiltIn "List"
150isNative :: Canonical -> Bool
151isNative v =
152 case v of
153 Canonical (Module name) _ ->
154 ModuleName.canonicalIsNative name
156 _ ->
157 False
160isTuple :: Canonical -> Bool
161isTuple v =
162 case v of
163 Canonical BuiltIn name ->
164 Help.isTuple name
166 _ ->
167 False
170isPrimitive :: Canonical -> Bool
171isPrimitive v =
172 case v of
173 Canonical BuiltIn name ->
174 elem name ["Int","Float","String","Bool"]
176 _ ->
177 False
180isPrim :: Text -> Canonical -> Bool
181isPrim prim (Canonical home name) =
182 case home of
183 BuiltIn ->
184 name == prim
186 _ ->
187 False
190isLocal :: (Text -> Bool) -> Canonical -> Bool
191isLocal check (Canonical home name) =
192 case home of
193 Local ->
194 check name
196 _ ->
197 False
201-- VARIABLE TO STRING
204class ToString a where
205 toString :: a -> String
208instance ToString Raw where
209 toString (Raw name) =
210 Text.unpack name
213instance ToString Canonical where
214 toString (Canonical home name) =
215 case home of
216 BuiltIn ->
217 Text.unpack name
219 Module moduleName ->
220 ModuleName.canonicalToString moduleName ++ "." ++ Text.unpack name
222 TopLevel _ ->
223 Text.unpack name
225 Local ->
226 Text.unpack name
230-- LISTINGS
233-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
234data Listing a =
235 Listing
236 { _explicits :: [a]
237 , _open :: Bool
238 }
239 deriving (Eq, Ord)
242openListing :: Listing a
243openListing =
244 Listing [] True
247closedListing :: Listing a
248closedListing =
249 Listing [] False
252listing :: [a] -> Listing a
253listing xs =
254 Listing xs False
257-- | A value that can be imported or exported
258data Value
259 = Value !Text
260 | Alias !Text
261 | Union !Text !(Listing Text)
262 deriving (Eq, Ord)
266-- CATEGORIZING VALUES
269getValues :: [Value] -> [Text]
270getValues values =
271 Maybe.mapMaybe getValue values
274getValue :: Value -> Maybe Text
275getValue value =
276 case value of
277 Value name -> Just name
278 Alias _ -> Nothing
279 Union _ _ -> Nothing
282getAliases :: [Value] -> [Text]
283getAliases values =
284 Maybe.mapMaybe getAlias values
287getAlias :: Value -> Maybe Text
288getAlias value =
289 case value of
290 Value _-> Nothing
291 Alias name -> Just name
292 Union _ _ -> Nothing
295getUnions :: [Value] -> [(Text, Listing Text)]
296getUnions values =
297 Maybe.mapMaybe getUnion values
300getUnion :: Value -> Maybe (Text, Listing Text)
301getUnion value =
302 case value of
303 Value _ -> Nothing
304 Alias _ -> Nothing
305 Union name ctors -> Just (name, ctors)
309-- BINARY SERIALIZATION
312instance Binary Canonical where
313 put (Canonical home name) =
314 case home of
315 BuiltIn ->
316 putWord8 0 >> put name
318 Module path ->
319 putWord8 1 >> put path >> put name
321 TopLevel path ->
322 putWord8 2 >> put path >> put name
324 Local ->
325 putWord8 3 >> put name
327 get =
328 do tag <- getWord8
329 case tag of
330 0 -> Canonical BuiltIn <$> get
331 1 -> Canonical . Module <$> get <*> get
332 2 -> Canonical . TopLevel <$> get <*> get
333 3 -> Canonical Local <$> get
334 _ -> error "Unexpected tag when deserializing canonical variable"
337instance Binary Value where
338 put portable =
339 case portable of
340 Value name ->
341 putWord8 0 >> put name
343 Alias name ->
344 putWord8 1 >> put name
346 Union name ctors ->
347 putWord8 2 >> put name >> put ctors
349 get =
350 do tag <- getWord8
351 case tag of
352 0 -> Value <$> get
353 1 -> Alias <$> get
354 2 -> Union <$> get <*> get
355 _ -> error "Error reading valid import/export information from serialized string"
358instance (Binary a) => Binary (Listing a) where
359 put (Listing explicits open) =
360 put explicits >> put open
362 get = Listing <$> get <*> get