git.iko.soy/elk
on 6aa43d7 help sign in
elk/src/AST/Variable.hs
314 lines 6.1 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-- VARIABLES
16newtype Raw = Raw String
17 deriving (Eq, Ord, Show)
20data Home
21 = BuiltIn
22 | Module ModuleName.Canonical
23 | TopLevel ModuleName.Canonical
24 | Local
25 deriving (Eq, Ord, Show)
28data Canonical = Canonical
29 { home :: !Home
30 , name :: !String
31 }
32 deriving (Eq, Ord, Show)
35local :: String -> Canonical
36local x =
37 Canonical Local x
40topLevel :: ModuleName.Canonical -> String -> Canonical
41topLevel home x =
42 Canonical (TopLevel home) x
45builtin :: String -> Canonical
46builtin x =
47 Canonical BuiltIn x
50fromModule :: ModuleName.Canonical -> String -> Canonical
51fromModule home name =
52 Canonical (Module home) name
55inCore :: ModuleName.Raw -> String -> Canonical
56inCore home name =
57 Canonical (Module (ModuleName.inCore home)) name
60-- VARIABLE RECOGNIZERS
62is :: ModuleName.Raw -> String -> Canonical -> Bool
63is home name var =
64 var == inCore home name
67isJson :: Canonical -> Bool
68isJson =
69 is ["Json", "Encode"] "Value"
72isMaybe :: Canonical -> Bool
73isMaybe =
74 is ["Maybe"] "Maybe"
76isArray :: Canonical -> Bool
77isArray =
78 is ["Array"] "Array"
81isTask :: Canonical -> Bool
82isTask =
83 is ["Task"] "Task"
86isSignal :: Canonical -> Bool
87isSignal =
88 is ["Signal"] "Signal"
91isList :: Canonical -> Bool
92isList v =
93 v == Canonical BuiltIn "List"
96isTuple :: Canonical -> Bool
97isTuple v =
98 case v of
99 Canonical BuiltIn name -> Help.isTuple name
100 _ -> False
103isPrimitive :: Canonical -> Bool
104isPrimitive v =
105 case v of
106 Canonical BuiltIn name ->
107 name `elem` ["Int","Float","String","Bool"]
108 _ ->
109 False
112isPrim :: String -> Canonical -> Bool
113isPrim prim v =
114 case v of
115 Canonical BuiltIn name -> name == prim
116 _ -> False
119isText :: Canonical -> Bool
120isText =
121 is ["Text"] "Text"
124-- VARIABLE TO STRING
126class ToString a where
127 toString :: a -> String
130instance ToString Raw where
131 toString (Raw name) =
132 name
135instance ToString Canonical where
136 toString (Canonical home name) =
137 case home of
138 BuiltIn ->
139 name
141 Module moduleName ->
142 ModuleName.canonicalToString moduleName ++ "." ++ name
144 TopLevel _ ->
145 name
147 Local ->
148 name
151-- LISTINGS
153-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
154data Listing a = Listing
155 { _explicits :: [a]
156 , _open :: Bool
157 }
158 deriving (Eq, Ord, Show)
161openListing :: Listing a
162openListing =
163 Listing [] True
166closedListing :: Listing a
167closedListing =
168 Listing [] False
171listing :: [a] -> Listing a
172listing xs =
173 Listing xs False
176-- | A value that can be imported or exported
177data Value
178 = Value !String
179 | Alias !String
180 | Union !String !(Listing String)
181 deriving (Eq, Ord, Show)
184-- CATEGORIZING VALUES
186getValues :: [Value] -> [String]
187getValues values =
188 Maybe.mapMaybe getValue values
191getValue :: Value -> Maybe String
192getValue value =
193 case value of
194 Value name -> Just name
195 Alias _ -> Nothing
196 Union _ _ -> Nothing
199getAliases :: [Value] -> [String]
200getAliases values =
201 Maybe.mapMaybe getAlias values
204getAlias :: Value -> Maybe String
205getAlias value =
206 case value of
207 Value _-> Nothing
208 Alias name -> Just name
209 Union _ _ -> Nothing
212getUnions :: [Value] -> [(String, Listing String)]
213getUnions values =
214 Maybe.mapMaybe getUnion values
217getUnion :: Value -> Maybe (String, Listing String)
218getUnion value =
219 case value of
220 Value _ -> Nothing
221 Alias _ -> Nothing
222 Union name ctors -> Just (name, ctors)
225-- PRETTY VARIABLES
227instance P.Pretty Raw where
228 pretty _ _ (Raw name) =
229 if Help.isOp name
230 then P.parens (P.text name)
231 else P.text name
234instance P.Pretty Canonical where
235 pretty dealiaser _ var =
236 let
237 name = toString var
238 in
239 P.text (maybe name id (Map.lookup name dealiaser))
242instance P.Pretty a => P.Pretty (Listing a) where
243 pretty dealiaser _ (Listing explicits open) =
244 let dots = [if open then P.text ".." else P.empty]
245 in
246 P.parens (P.commaCat (map (P.pretty dealiaser False) explicits ++ dots))
249instance P.Pretty Value where
250 pretty dealiaser _ portable =
251 case portable of
252 Value name ->
253 P.text name
255 Alias name ->
256 P.text name
258 Union name ctors ->
259 P.text name <> P.pretty dealiaser False ctors
262-- BINARY SERIALIZATION
264instance Binary Canonical where
265 put (Canonical home name) =
266 case home of
267 BuiltIn ->
268 putWord8 0 >> put name
270 Module path ->
271 putWord8 1 >> put path >> put name
273 TopLevel path ->
274 putWord8 2 >> put path >> put name
276 Local ->
277 putWord8 3 >> put name
279 get =
280 do tag <- getWord8
281 case tag of
282 0 -> Canonical BuiltIn <$> get
283 1 -> Canonical . Module <$> get <*> get
284 2 -> Canonical . TopLevel <$> get <*> get
285 3 -> Canonical Local <$> get
286 _ -> error "Unexpected tag when deserializing canonical variable"
289instance Binary Value where
290 put portable =
291 case portable of
292 Value name ->
293 putWord8 0 >> put name
295 Alias name ->
296 putWord8 1 >> put name
298 Union name ctors ->
299 putWord8 2 >> put name >> put ctors
301 get =
302 do tag <- getWord8
303 case tag of
304 0 -> Value <$> get
305 1 -> Alias <$> get
306 2 -> Union <$> get <*> get
307 _ -> error "Error reading valid import/export information from serialized string"
310instance (Binary a) => Binary (Listing a) where
311 put (Listing explicits open) =
312 put explicits >> put open
314 get = Listing <$> get <*> get