git.iko.soy/elk
on 472eef7 help sign in
elk/src/AST/Variable.hs
321 lines 6.2 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 TopLevelVar =
21 TopLevelVar
22 { topVarModule :: ModuleName.Canonical
23 , topVarName :: String
24 } deriving (Eq, Ord, Show)
27data Home
28 = BuiltIn
29 | Module ModuleName.Canonical
30 | TopLevel ModuleName.Canonical
31 | Local
32 deriving (Eq, Ord, Show)
35data Canonical = Canonical
36 { home :: !Home
37 , name :: !String
38 }
39 deriving (Eq, Ord, Show)
42local :: String -> Canonical
43local x =
44 Canonical Local x
47topLevel :: ModuleName.Canonical -> String -> Canonical
48topLevel home x =
49 Canonical (TopLevel home) x
52builtin :: String -> Canonical
53builtin x =
54 Canonical BuiltIn x
57fromModule :: ModuleName.Canonical -> String -> Canonical
58fromModule home name =
59 Canonical (Module home) name
62inCore :: ModuleName.Raw -> String -> Canonical
63inCore home name =
64 Canonical (Module (ModuleName.inCore home)) name
67-- VARIABLE RECOGNIZERS
69is :: ModuleName.Raw -> String -> Canonical -> Bool
70is home name var =
71 var == inCore home name
74isJson :: Canonical -> Bool
75isJson =
76 is ["Json", "Encode"] "Value"
79isMaybe :: Canonical -> Bool
80isMaybe =
81 is ["Maybe"] "Maybe"
83isArray :: Canonical -> Bool
84isArray =
85 is ["Array"] "Array"
88isTask :: Canonical -> Bool
89isTask =
90 is ["Task"] "Task"
93isSignal :: Canonical -> Bool
94isSignal =
95 is ["Signal"] "Signal"
98isList :: Canonical -> Bool
99isList v =
100 v == Canonical BuiltIn "List"
103isTuple :: Canonical -> Bool
104isTuple v =
105 case v of
106 Canonical BuiltIn name -> Help.isTuple name
107 _ -> False
110isPrimitive :: Canonical -> Bool
111isPrimitive v =
112 case v of
113 Canonical BuiltIn name ->
114 name `elem` ["Int","Float","String","Bool"]
115 _ ->
116 False
119isPrim :: String -> Canonical -> Bool
120isPrim prim v =
121 case v of
122 Canonical BuiltIn name -> name == prim
123 _ -> False
126isText :: Canonical -> Bool
127isText =
128 is ["Text"] "Text"
131-- VARIABLE TO STRING
133class ToString a where
134 toString :: a -> String
137instance ToString Raw where
138 toString (Raw name) =
139 name
142instance ToString Canonical where
143 toString (Canonical home name) =
144 case home of
145 BuiltIn ->
146 name
148 Module moduleName ->
149 ModuleName.canonicalToString moduleName ++ "." ++ name
151 TopLevel _ ->
152 name
154 Local ->
155 name
158-- LISTINGS
160-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
161data Listing a = Listing
162 { _explicits :: [a]
163 , _open :: Bool
164 }
165 deriving (Eq, Ord, Show)
168openListing :: Listing a
169openListing =
170 Listing [] True
173closedListing :: Listing a
174closedListing =
175 Listing [] False
178listing :: [a] -> Listing a
179listing xs =
180 Listing xs False
183-- | A value that can be imported or exported
184data Value
185 = Value !String
186 | Alias !String
187 | Union !String !(Listing String)
188 deriving (Eq, Ord, Show)
191-- CATEGORIZING VALUES
193getValues :: [Value] -> [String]
194getValues values =
195 Maybe.mapMaybe getValue values
198getValue :: Value -> Maybe String
199getValue value =
200 case value of
201 Value name -> Just name
202 Alias _ -> Nothing
203 Union _ _ -> Nothing
206getAliases :: [Value] -> [String]
207getAliases values =
208 Maybe.mapMaybe getAlias values
211getAlias :: Value -> Maybe String
212getAlias value =
213 case value of
214 Value _-> Nothing
215 Alias name -> Just name
216 Union _ _ -> Nothing
219getUnions :: [Value] -> [(String, Listing String)]
220getUnions values =
221 Maybe.mapMaybe getUnion values
224getUnion :: Value -> Maybe (String, Listing String)
225getUnion value =
226 case value of
227 Value _ -> Nothing
228 Alias _ -> Nothing
229 Union name ctors -> Just (name, ctors)
232-- PRETTY VARIABLES
234instance P.Pretty Raw where
235 pretty _ _ (Raw name) =
236 if Help.isOp name
237 then P.parens (P.text name)
238 else P.text name
241instance P.Pretty Canonical where
242 pretty dealiaser _ var =
243 let
244 name = toString var
245 in
246 P.text (maybe name id (Map.lookup name dealiaser))
249instance P.Pretty a => P.Pretty (Listing a) where
250 pretty dealiaser _ (Listing explicits open) =
251 let dots = [if open then P.text ".." else P.empty]
252 in
253 P.parens (P.commaCat (map (P.pretty dealiaser False) explicits ++ dots))
256instance P.Pretty Value where
257 pretty dealiaser _ portable =
258 case portable of
259 Value name ->
260 P.text name
262 Alias name ->
263 P.text name
265 Union name ctors ->
266 P.text name <> P.pretty dealiaser False ctors
269-- BINARY SERIALIZATION
271instance Binary Canonical where
272 put (Canonical home name) =
273 case home of
274 BuiltIn ->
275 putWord8 0 >> put name
277 Module path ->
278 putWord8 1 >> put path >> put name
280 TopLevel path ->
281 putWord8 2 >> put path >> put name
283 Local ->
284 putWord8 3 >> put name
286 get =
287 do tag <- getWord8
288 case tag of
289 0 -> Canonical BuiltIn <$> get
290 1 -> Canonical . Module <$> get <*> get
291 2 -> Canonical . TopLevel <$> get <*> get
292 3 -> Canonical Local <$> get
293 _ -> error "Unexpected tag when deserializing canonical variable"
296instance Binary Value where
297 put portable =
298 case portable of
299 Value name ->
300 putWord8 0 >> put name
302 Alias name ->
303 putWord8 1 >> put name
305 Union name ctors ->
306 putWord8 2 >> put name >> put ctors
308 get =
309 do tag <- getWord8
310 case tag of
311 0 -> Value <$> get
312 1 -> Alias <$> get
313 2 -> Union <$> get <*> get
314 _ -> error "Error reading valid import/export information from serialized string"
317instance (Binary a) => Binary (Listing a) where
318 put (Listing explicits open) =
319 put explicits >> put open
321 get = Listing <$> get <*> get