git.iko.soy/elk
on 73b288a help sign in
elk/src/AST/Variable.hs
309 lines 5.9 kB history raw
1module AST.Variable where
3import Control.Applicative ((<$>), (<*>))
4import Data.Binary
5import qualified Data.List as List
6import qualified Data.Map as Map
7import qualified Data.Maybe as Maybe
8import Text.PrettyPrint as P
10import qualified AST.Helpers as Help
11import qualified Reporting.PrettyPrint as P
14-- VARIABLES
16newtype Raw = Raw String
17 deriving (Eq, Ord, Show)
20data Home
21 = BuiltIn
22 | Module [String]
23 | TopLevel [String]
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 :: [String] -> String -> Canonical
41topLevel names x =
42 Canonical (TopLevel names) x
45builtin :: String -> Canonical
46builtin x =
47 Canonical BuiltIn x
50fromModule :: [String] -> String -> Canonical
51fromModule home name =
52 Canonical (Module home) name
55-- VARIABLE RECOGNIZERS
57is :: [String] -> String -> Canonical -> Bool
58is home name var =
59 var == Canonical (Module home) name
62isJson :: Canonical -> Bool
63isJson =
64 is ["Json", "Encode"] "Value"
67isMaybe :: Canonical -> Bool
68isMaybe =
69 is ["Maybe"] "Maybe"
71isArray :: Canonical -> Bool
72isArray =
73 is ["Array"] "Array"
76isTask :: Canonical -> Bool
77isTask =
78 is ["Task"] "Task"
81isSignal :: Canonical -> Bool
82isSignal =
83 is ["Signal"] "Signal"
86isList :: Canonical -> Bool
87isList v =
88 v == Canonical BuiltIn "List"
91isTuple :: Canonical -> Bool
92isTuple v =
93 case v of
94 Canonical BuiltIn name -> Help.isTuple name
95 _ -> False
98isPrimitive :: Canonical -> Bool
99isPrimitive v =
100 case v of
101 Canonical BuiltIn name ->
102 name `elem` ["Int","Float","String","Bool"]
103 _ ->
104 False
107isPrim :: String -> Canonical -> Bool
108isPrim prim v =
109 case v of
110 Canonical BuiltIn name -> name == prim
111 _ -> False
114isText :: Canonical -> Bool
115isText =
116 is ["Text"] "Text"
119-- VARIABLE TO STRING
121class ToString a where
122 toString :: a -> String
125instance ToString Raw where
126 toString (Raw name) =
127 name
130instance ToString Canonical where
131 toString (Canonical home name) =
132 case home of
133 BuiltIn ->
134 name
136 Module path ->
137 List.intercalate "." (path ++ [name])
139 TopLevel _ ->
140 name
142 Local ->
143 name
146-- LISTINGS
148-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
149data Listing a = Listing
150 { _explicits :: [a]
151 , _open :: Bool
152 }
153 deriving (Eq, Ord, Show)
156openListing :: Listing a
157openListing =
158 Listing [] True
161closedListing :: Listing a
162closedListing =
163 Listing [] False
166listing :: [a] -> Listing a
167listing xs =
168 Listing xs False
171-- | A value that can be imported or exported
172data Value
173 = Value !String
174 | Alias !String
175 | Union !String !(Listing String)
176 deriving (Eq, Ord, Show)
179-- CATEGORIZING VALUES
181getValues :: [Value] -> [String]
182getValues values =
183 Maybe.mapMaybe getValue values
186getValue :: Value -> Maybe String
187getValue value =
188 case value of
189 Value name -> Just name
190 Alias _ -> Nothing
191 Union _ _ -> Nothing
194getAliases :: [Value] -> [String]
195getAliases values =
196 Maybe.mapMaybe getAlias values
199getAlias :: Value -> Maybe String
200getAlias value =
201 case value of
202 Value _-> Nothing
203 Alias name -> Just name
204 Union _ _ -> Nothing
207getUnions :: [Value] -> [(String, Listing String)]
208getUnions values =
209 Maybe.mapMaybe getUnion values
212getUnion :: Value -> Maybe (String, Listing String)
213getUnion value =
214 case value of
215 Value _ -> Nothing
216 Alias _ -> Nothing
217 Union name ctors -> Just (name, ctors)
220-- PRETTY VARIABLES
222instance P.Pretty Raw where
223 pretty _ _ (Raw name) =
224 if Help.isOp name
225 then P.parens (P.text name)
226 else P.text name
229instance P.Pretty Canonical where
230 pretty dealiaser _ var =
231 let
232 name = toString var
233 in
234 P.text (maybe name id (Map.lookup name dealiaser))
237instance P.Pretty a => P.Pretty (Listing a) where
238 pretty dealiaser _ (Listing explicits open) =
239 let dots = [if open then P.text ".." else P.empty]
240 in
241 P.parens (P.commaCat (map (P.pretty dealiaser False) explicits ++ dots))
244instance P.Pretty Value where
245 pretty dealiaser _ portable =
246 case portable of
247 Value name ->
248 P.text name
250 Alias name ->
251 P.text name
253 Union name ctors ->
254 P.text name <> P.pretty dealiaser False ctors
257-- BINARY SERIALIZATION
259instance Binary Canonical where
260 put (Canonical home name) =
261 case home of
262 BuiltIn ->
263 putWord8 0 >> put name
265 Module path ->
266 putWord8 1 >> put path >> put name
268 TopLevel path ->
269 putWord8 2 >> put path >> put name
271 Local ->
272 putWord8 3 >> put name
274 get =
275 do tag <- getWord8
276 case tag of
277 0 -> Canonical BuiltIn <$> get
278 1 -> Canonical . Module <$> get <*> get
279 2 -> Canonical . TopLevel <$> get <*> get
280 3 -> Canonical Local <$> get
281 _ -> error "Unexpected tag when deserializing canonical variable"
284instance Binary Value where
285 put portable =
286 case portable of
287 Value name ->
288 putWord8 0 >> put name
290 Alias name ->
291 putWord8 1 >> put name
293 Union name ctors ->
294 putWord8 2 >> put name >> put ctors
296 get =
297 do tag <- getWord8
298 case tag of
299 0 -> Value <$> get
300 1 -> Alias <$> get
301 2 -> Union <$> get <*> get
302 _ -> error "Error reading valid import/export information from serialized string"
305instance (Binary a) => Binary (Listing a) where
306 put (Listing explicits open) =
307 put explicits >> put open
309 get = Listing <$> get <*> get