git.iko.soy/elk
on 2297bbf help sign in
elk/src/AST/Variable.hs
342 lines 6.5 kB history raw
1module AST.Variable where
3import Control.Applicative ((<$>), (<*>))
4import Data.Binary
5import qualified Data.Map as Map
6import qualified Data.Maybe as Maybe
7import Text.PrettyPrint as P
9import qualified AST.Helpers as Help
10import qualified AST.Module.Name as ModuleName
11import qualified Reporting.PrettyPrint as P
14-- RAW NAMES
16newtype Raw = Raw String
17 deriving (Eq, Ord, Show)
20-- TOP LEVEL NAMES
22data TopLevel = TopLevelVar
23 { topHome :: ModuleName.Canonical
24 , topName :: String
25 }
26 deriving (Eq, Ord, Show)
30-- CANONICAL NAMES
32data Home
33 = BuiltIn
34 | Module ModuleName.Canonical
35 | TopLevel ModuleName.Canonical
36 | Local
37 deriving (Eq, Ord, Show)
40data Canonical = Canonical
41 { home :: !Home
42 , name :: !String
43 }
44 deriving (Eq, Ord, Show)
47local :: String -> Canonical
48local x =
49 Canonical Local x
52topLevel :: ModuleName.Canonical -> String -> Canonical
53topLevel home x =
54 Canonical (TopLevel home) x
57builtin :: String -> Canonical
58builtin x =
59 Canonical BuiltIn x
62fromModule :: ModuleName.Canonical -> String -> Canonical
63fromModule home name =
64 Canonical (Module home) name
67inCore :: ModuleName.Raw -> String -> Canonical
68inCore home name =
69 Canonical (Module (ModuleName.inCore home)) name
72-- VARIABLE RECOGNIZERS
74isLocalHome :: Home -> Bool
75isLocalHome home =
76 case home of
77 BuiltIn ->
78 False
80 Module _ ->
81 False
83 TopLevel _ ->
84 True
86 Local ->
87 True
90is :: ModuleName.Raw -> String -> Canonical -> Bool
91is home name var =
92 var == inCore home name
95isJson :: Canonical -> Bool
96isJson =
97 is ["Json", "Encode"] "Value"
100isMaybe :: Canonical -> Bool
101isMaybe =
102 is ["Maybe"] "Maybe"
104isArray :: Canonical -> Bool
105isArray =
106 is ["Array"] "Array"
109isTask :: Canonical -> Bool
110isTask =
111 is ["Task"] "Task"
114isSignal :: Canonical -> Bool
115isSignal =
116 is ["Signal"] "Signal"
119isList :: Canonical -> Bool
120isList v =
121 v == Canonical BuiltIn "List"
124isTuple :: Canonical -> Bool
125isTuple v =
126 case v of
127 Canonical BuiltIn name -> Help.isTuple name
128 _ -> False
131isPrimitive :: Canonical -> Bool
132isPrimitive v =
133 case v of
134 Canonical BuiltIn name ->
135 name `elem` ["Int","Float","String","Bool"]
136 _ ->
137 False
140isPrim :: String -> Canonical -> Bool
141isPrim prim v =
142 case v of
143 Canonical BuiltIn name -> name == prim
144 _ -> False
147isText :: Canonical -> Bool
148isText =
149 is ["Text"] "Text"
152-- VARIABLE TO STRING
154class ToString a where
155 toString :: a -> String
158instance ToString Raw where
159 toString (Raw name) =
160 name
163instance ToString Canonical where
164 toString (Canonical home name) =
165 case home of
166 BuiltIn ->
167 name
169 Module moduleName ->
170 ModuleName.canonicalToString moduleName ++ "." ++ name
172 TopLevel _ ->
173 name
175 Local ->
176 name
179-- LISTINGS
181-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
182data Listing a = Listing
183 { _explicits :: [a]
184 , _open :: Bool
185 }
186 deriving (Eq, Ord, Show)
189openListing :: Listing a
190openListing =
191 Listing [] True
194closedListing :: Listing a
195closedListing =
196 Listing [] False
199listing :: [a] -> Listing a
200listing xs =
201 Listing xs False
204-- | A value that can be imported or exported
205data Value
206 = Value !String
207 | Alias !String
208 | Union !String !(Listing String)
209 deriving (Eq, Ord, Show)
212-- CATEGORIZING VALUES
214getValues :: [Value] -> [String]
215getValues values =
216 Maybe.mapMaybe getValue values
219getValue :: Value -> Maybe String
220getValue value =
221 case value of
222 Value name -> Just name
223 Alias _ -> Nothing
224 Union _ _ -> Nothing
227getAliases :: [Value] -> [String]
228getAliases values =
229 Maybe.mapMaybe getAlias values
232getAlias :: Value -> Maybe String
233getAlias value =
234 case value of
235 Value _-> Nothing
236 Alias name -> Just name
237 Union _ _ -> Nothing
240getUnions :: [Value] -> [(String, Listing String)]
241getUnions values =
242 Maybe.mapMaybe getUnion values
245getUnion :: Value -> Maybe (String, Listing String)
246getUnion value =
247 case value of
248 Value _ -> Nothing
249 Alias _ -> Nothing
250 Union name ctors -> Just (name, ctors)
253-- PRETTY VARIABLES
255instance P.Pretty Raw where
256 pretty _ _ (Raw name) =
257 if Help.isOp name
258 then P.parens (P.text name)
259 else P.text name
262instance P.Pretty Canonical where
263 pretty dealiaser _ var =
264 let
265 name = toString var
266 in
267 P.text (maybe name id (Map.lookup name dealiaser))
270instance P.Pretty a => P.Pretty (Listing a) where
271 pretty dealiaser _ (Listing explicits open) =
272 let dots = [if open then P.text ".." else P.empty]
273 in
274 P.parens (P.commaCat (map (P.pretty dealiaser False) explicits ++ dots))
277instance P.Pretty Value where
278 pretty dealiaser _ portable =
279 case portable of
280 Value name ->
281 P.text name
283 Alias name ->
284 P.text name
286 Union name ctors ->
287 P.text name <> P.pretty dealiaser False ctors
290-- BINARY SERIALIZATION
292instance Binary Canonical where
293 put (Canonical home name) =
294 case home of
295 BuiltIn ->
296 putWord8 0 >> put name
298 Module path ->
299 putWord8 1 >> put path >> put name
301 TopLevel path ->
302 putWord8 2 >> put path >> put name
304 Local ->
305 putWord8 3 >> put name
307 get =
308 do tag <- getWord8
309 case tag of
310 0 -> Canonical BuiltIn <$> get
311 1 -> Canonical . Module <$> get <*> get
312 2 -> Canonical . TopLevel <$> get <*> get
313 3 -> Canonical Local <$> get
314 _ -> error "Unexpected tag when deserializing canonical variable"
317instance Binary Value where
318 put portable =
319 case portable of
320 Value name ->
321 putWord8 0 >> put name
323 Alias name ->
324 putWord8 1 >> put name
326 Union name ctors ->
327 putWord8 2 >> put name >> put ctors
329 get =
330 do tag <- getWord8
331 case tag of
332 0 -> Value <$> get
333 1 -> Alias <$> get
334 2 -> Union <$> get <*> get
335 _ -> error "Error reading valid import/export information from serialized string"
338instance (Binary a) => Binary (Listing a) where
339 put (Listing explicits open) =
340 put explicits >> put open
342 get = Listing <$> get <*> get