git.iko.soy/elk
on ce01547 help sign in
elk/src/AST/Variable.hs
289 lines 5.6 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 | Local
24 deriving (Eq, Ord, Show)
27data Canonical = Canonical
28 { home :: !Home
29 , name :: !String
30 }
31 deriving (Eq, Ord, Show)
34local :: String -> Canonical
35local x = Canonical Local x
38builtin :: String -> Canonical
39builtin x = Canonical BuiltIn x
42fromModule :: [String] -> String -> Canonical
43fromModule home name =
44 Canonical (Module home) name
47-- VARIABLE RECOGNIZERS
49is :: [String] -> String -> Canonical -> Bool
50is home name var =
51 var == Canonical (Module home) name
54isJson :: Canonical -> Bool
55isJson =
56 is ["Json", "Encode"] "Value"
59isMaybe :: Canonical -> Bool
60isMaybe =
61 is ["Maybe"] "Maybe"
63isArray :: Canonical -> Bool
64isArray =
65 is ["Array"] "Array"
68isTask :: Canonical -> Bool
69isTask =
70 is ["Task"] "Task"
73isSignal :: Canonical -> Bool
74isSignal =
75 is ["Signal"] "Signal"
78isList :: Canonical -> Bool
79isList v =
80 v == Canonical BuiltIn "List"
83isTuple :: Canonical -> Bool
84isTuple v =
85 case v of
86 Canonical BuiltIn name -> Help.isTuple name
87 _ -> False
90isPrimitive :: Canonical -> Bool
91isPrimitive v =
92 case v of
93 Canonical BuiltIn name ->
94 name `elem` ["Int","Float","String","Bool"]
95 _ ->
96 False
99isPrim :: String -> Canonical -> Bool
100isPrim prim v =
101 case v of
102 Canonical BuiltIn name -> name == prim
103 _ -> False
106isText :: Canonical -> Bool
107isText =
108 is ["Text"] "Text"
111-- VARIABLE TO STRING
113class ToString a where
114 toString :: a -> String
117instance ToString Raw where
118 toString (Raw name) =
119 name
122instance ToString Canonical where
123 toString (Canonical home name) =
124 case home of
125 BuiltIn -> name
126 Module path -> List.intercalate "." (path ++ [name])
127 Local -> name
130-- LISTINGS
132-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
133data Listing a = Listing
134 { _explicits :: [a]
135 , _open :: Bool
136 }
137 deriving (Eq, Ord, Show)
140openListing :: Listing a
141openListing =
142 Listing [] True
145closedListing :: Listing a
146closedListing =
147 Listing [] False
150listing :: [a] -> Listing a
151listing xs =
152 Listing xs False
155-- | A value that can be imported or exported
156data Value
157 = Value !String
158 | Alias !String
159 | Union !String !(Listing String)
160 deriving (Eq, Ord, Show)
163-- CATEGORIZING VALUES
165getValues :: [Value] -> [String]
166getValues values =
167 Maybe.mapMaybe getValue values
170getValue :: Value -> Maybe String
171getValue value =
172 case value of
173 Value name -> Just name
174 Alias _ -> Nothing
175 Union _ _ -> Nothing
178getAliases :: [Value] -> [String]
179getAliases values =
180 Maybe.mapMaybe getAlias values
183getAlias :: Value -> Maybe String
184getAlias value =
185 case value of
186 Value _-> Nothing
187 Alias name -> Just name
188 Union _ _ -> Nothing
191getUnions :: [Value] -> [(String, Listing String)]
192getUnions values =
193 Maybe.mapMaybe getUnion values
196getUnion :: Value -> Maybe (String, Listing String)
197getUnion value =
198 case value of
199 Value _ -> Nothing
200 Alias _ -> Nothing
201 Union name ctors -> Just (name, ctors)
204-- PRETTY VARIABLES
206instance P.Pretty Raw where
207 pretty _ _ (Raw name) =
208 if Help.isOp name
209 then P.parens (P.text name)
210 else P.text name
213instance P.Pretty Canonical where
214 pretty dealiaser _ var =
215 let
216 name = toString var
217 in
218 P.text (maybe name id (Map.lookup name dealiaser))
221instance P.Pretty a => P.Pretty (Listing a) where
222 pretty dealiaser _ (Listing explicits open) =
223 let dots = [if open then P.text ".." else P.empty]
224 in
225 P.parens (P.commaCat (map (P.pretty dealiaser False) explicits ++ dots))
228instance P.Pretty Value where
229 pretty dealiaser _ portable =
230 case portable of
231 Value name ->
232 P.text name
234 Alias name ->
235 P.text name
237 Union name ctors ->
238 P.text name <> P.pretty dealiaser False ctors
241-- BINARY SERIALIZATION
243instance Binary Canonical where
244 put (Canonical home name) =
245 case home of
246 BuiltIn ->
247 putWord8 0 >> put name
249 Module path ->
250 putWord8 1 >> put path >> put name
252 Local ->
253 putWord8 2 >> put name
255 get =
256 do tag <- getWord8
257 case tag of
258 0 -> Canonical BuiltIn <$> get
259 1 -> Canonical . Module <$> get <*> get
260 2 -> Canonical Local <$> get
261 _ -> error "Unexpected tag when deserializing canonical variable"
264instance Binary Value where
265 put portable =
266 case portable of
267 Value name ->
268 putWord8 0 >> put name
270 Alias name ->
271 putWord8 1 >> put name
273 Union name ctors ->
274 putWord8 2 >> put name >> put ctors
276 get =
277 do tag <- getWord8
278 case tag of
279 0 -> Value <$> get
280 1 -> Alias <$> get
281 2 -> Union <$> get <*> get
282 _ -> error "Error reading valid import/export information from serialized string"
285instance (Binary a) => Binary (Listing a) where
286 put (Listing explicits open) =
287 put explicits >> put open
289 get = Listing <$> get <*> get