git.iko.soy/elk
on bb7eb96 help sign in
elk/src/AST/Variable.hs
326 lines 6.3 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
74is :: ModuleName.Raw -> String -> Canonical -> Bool
75is home name var =
76 var == inCore home name
79isJson :: Canonical -> Bool
80isJson =
81 is ["Json", "Encode"] "Value"
84isMaybe :: Canonical -> Bool
85isMaybe =
86 is ["Maybe"] "Maybe"
88isArray :: Canonical -> Bool
89isArray =
90 is ["Array"] "Array"
93isTask :: Canonical -> Bool
94isTask =
95 is ["Task"] "Task"
98isSignal :: Canonical -> Bool
99isSignal =
100 is ["Signal"] "Signal"
103isList :: Canonical -> Bool
104isList v =
105 v == Canonical BuiltIn "List"
108isTuple :: Canonical -> Bool
109isTuple v =
110 case v of
111 Canonical BuiltIn name -> Help.isTuple name
112 _ -> False
115isPrimitive :: Canonical -> Bool
116isPrimitive v =
117 case v of
118 Canonical BuiltIn name ->
119 name `elem` ["Int","Float","String","Bool"]
120 _ ->
121 False
124isPrim :: String -> Canonical -> Bool
125isPrim prim v =
126 case v of
127 Canonical BuiltIn name -> name == prim
128 _ -> False
131isText :: Canonical -> Bool
132isText =
133 is ["Text"] "Text"
136-- VARIABLE TO STRING
138class ToString a where
139 toString :: a -> String
142instance ToString Raw where
143 toString (Raw name) =
144 name
147instance ToString Canonical where
148 toString (Canonical home name) =
149 case home of
150 BuiltIn ->
151 name
153 Module moduleName ->
154 ModuleName.canonicalToString moduleName ++ "." ++ name
156 TopLevel _ ->
157 name
159 Local ->
160 name
163-- LISTINGS
165-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
166data Listing a = Listing
167 { _explicits :: [a]
168 , _open :: Bool
169 }
170 deriving (Eq, Ord, Show)
173openListing :: Listing a
174openListing =
175 Listing [] True
178closedListing :: Listing a
179closedListing =
180 Listing [] False
183listing :: [a] -> Listing a
184listing xs =
185 Listing xs False
188-- | A value that can be imported or exported
189data Value
190 = Value !String
191 | Alias !String
192 | Union !String !(Listing String)
193 deriving (Eq, Ord, Show)
196-- CATEGORIZING VALUES
198getValues :: [Value] -> [String]
199getValues values =
200 Maybe.mapMaybe getValue values
203getValue :: Value -> Maybe String
204getValue value =
205 case value of
206 Value name -> Just name
207 Alias _ -> Nothing
208 Union _ _ -> Nothing
211getAliases :: [Value] -> [String]
212getAliases values =
213 Maybe.mapMaybe getAlias values
216getAlias :: Value -> Maybe String
217getAlias value =
218 case value of
219 Value _-> Nothing
220 Alias name -> Just name
221 Union _ _ -> Nothing
224getUnions :: [Value] -> [(String, Listing String)]
225getUnions values =
226 Maybe.mapMaybe getUnion values
229getUnion :: Value -> Maybe (String, Listing String)
230getUnion value =
231 case value of
232 Value _ -> Nothing
233 Alias _ -> Nothing
234 Union name ctors -> Just (name, ctors)
237-- PRETTY VARIABLES
239instance P.Pretty Raw where
240 pretty _ _ (Raw name) =
241 if Help.isOp name
242 then P.parens (P.text name)
243 else P.text name
246instance P.Pretty Canonical where
247 pretty dealiaser _ var =
248 let
249 name = toString var
250 in
251 P.text (maybe name id (Map.lookup name dealiaser))
254instance P.Pretty a => P.Pretty (Listing a) where
255 pretty dealiaser _ (Listing explicits open) =
256 let dots = [if open then P.text ".." else P.empty]
257 in
258 P.parens (P.commaCat (map (P.pretty dealiaser False) explicits ++ dots))
261instance P.Pretty Value where
262 pretty dealiaser _ portable =
263 case portable of
264 Value name ->
265 P.text name
267 Alias name ->
268 P.text name
270 Union name ctors ->
271 P.text name <> P.pretty dealiaser False ctors
274-- BINARY SERIALIZATION
276instance Binary Canonical where
277 put (Canonical home name) =
278 case home of
279 BuiltIn ->
280 putWord8 0 >> put name
282 Module path ->
283 putWord8 1 >> put path >> put name
285 TopLevel path ->
286 putWord8 2 >> put path >> put name
288 Local ->
289 putWord8 3 >> put name
291 get =
292 do tag <- getWord8
293 case tag of
294 0 -> Canonical BuiltIn <$> get
295 1 -> Canonical . Module <$> get <*> get
296 2 -> Canonical . TopLevel <$> get <*> get
297 3 -> Canonical Local <$> get
298 _ -> error "Unexpected tag when deserializing canonical variable"
301instance Binary Value where
302 put portable =
303 case portable of
304 Value name ->
305 putWord8 0 >> put name
307 Alias name ->
308 putWord8 1 >> put name
310 Union name ctors ->
311 putWord8 2 >> put name >> put ctors
313 get =
314 do tag <- getWord8
315 case tag of
316 0 -> Value <$> get
317 1 -> Alias <$> get
318 2 -> Union <$> get <*> get
319 _ -> error "Error reading valid import/export information from serialized string"
322instance (Binary a) => Binary (Listing a) where
323 put (Listing explicits open) =
324 put explicits >> put open
326 get = Listing <$> get <*> get