git.iko.soy/elk
on bc71d83 help sign in
elk/src/AST/Variable.hs
341 lines 6.4 kB history raw
1module AST.Variable where
3import Data.Binary
4import qualified Data.Map as Map
5import qualified Data.Maybe as Maybe
6import Text.PrettyPrint as P
8import qualified AST.Helpers as Help
9import qualified AST.Module.Name as ModuleName
10import qualified Reporting.PrettyPrint as P
13-- RAW NAMES
15newtype Raw = Raw String
16 deriving (Eq, Ord, Show)
19-- TOP LEVEL NAMES
21data TopLevel = TopLevelVar
22 { topHome :: ModuleName.Canonical
23 , topName :: String
24 }
25 deriving (Eq, Ord, Show)
29-- CANONICAL NAMES
31data Home
32 = BuiltIn
33 | Module ModuleName.Canonical
34 | TopLevel ModuleName.Canonical
35 | Local
36 deriving (Eq, Ord, Show)
39data Canonical = Canonical
40 { home :: !Home
41 , name :: !String
42 }
43 deriving (Eq, Ord, Show)
46local :: String -> Canonical
47local x =
48 Canonical Local x
51topLevel :: ModuleName.Canonical -> String -> Canonical
52topLevel home x =
53 Canonical (TopLevel home) x
56builtin :: String -> Canonical
57builtin x =
58 Canonical BuiltIn x
61fromModule :: ModuleName.Canonical -> String -> Canonical
62fromModule home name =
63 Canonical (Module home) name
66inCore :: ModuleName.Raw -> String -> Canonical
67inCore home name =
68 Canonical (Module (ModuleName.inCore home)) name
71-- VARIABLE RECOGNIZERS
73isLocalHome :: Home -> Bool
74isLocalHome home =
75 case home of
76 BuiltIn ->
77 False
79 Module _ ->
80 False
82 TopLevel _ ->
83 True
85 Local ->
86 True
89is :: ModuleName.Raw -> String -> Canonical -> Bool
90is home name var =
91 var == inCore home name
94isJson :: Canonical -> Bool
95isJson =
96 is ["Json", "Encode"] "Value"
99isMaybe :: Canonical -> Bool
100isMaybe =
101 is ["Maybe"] "Maybe"
103isArray :: Canonical -> Bool
104isArray =
105 is ["Array"] "Array"
108isTask :: Canonical -> Bool
109isTask =
110 is ["Task"] "Task"
113isSignal :: Canonical -> Bool
114isSignal =
115 is ["Signal"] "Signal"
118isList :: Canonical -> Bool
119isList v =
120 v == Canonical BuiltIn "List"
123isTuple :: Canonical -> Bool
124isTuple v =
125 case v of
126 Canonical BuiltIn name -> Help.isTuple name
127 _ -> False
130isPrimitive :: Canonical -> Bool
131isPrimitive v =
132 case v of
133 Canonical BuiltIn name ->
134 name `elem` ["Int","Float","String","Bool"]
135 _ ->
136 False
139isPrim :: String -> Canonical -> Bool
140isPrim prim v =
141 case v of
142 Canonical BuiltIn name -> name == prim
143 _ -> False
146isText :: Canonical -> Bool
147isText =
148 is ["Text"] "Text"
151-- VARIABLE TO STRING
153class ToString a where
154 toString :: a -> String
157instance ToString Raw where
158 toString (Raw name) =
159 name
162instance ToString Canonical where
163 toString (Canonical home name) =
164 case home of
165 BuiltIn ->
166 name
168 Module moduleName ->
169 ModuleName.canonicalToString moduleName ++ "." ++ name
171 TopLevel _ ->
172 name
174 Local ->
175 name
178-- LISTINGS
180-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
181data Listing a = Listing
182 { _explicits :: [a]
183 , _open :: Bool
184 }
185 deriving (Eq, Ord, Show)
188openListing :: Listing a
189openListing =
190 Listing [] True
193closedListing :: Listing a
194closedListing =
195 Listing [] False
198listing :: [a] -> Listing a
199listing xs =
200 Listing xs False
203-- | A value that can be imported or exported
204data Value
205 = Value !String
206 | Alias !String
207 | Union !String !(Listing String)
208 deriving (Eq, Ord, Show)
211-- CATEGORIZING VALUES
213getValues :: [Value] -> [String]
214getValues values =
215 Maybe.mapMaybe getValue values
218getValue :: Value -> Maybe String
219getValue value =
220 case value of
221 Value name -> Just name
222 Alias _ -> Nothing
223 Union _ _ -> Nothing
226getAliases :: [Value] -> [String]
227getAliases values =
228 Maybe.mapMaybe getAlias values
231getAlias :: Value -> Maybe String
232getAlias value =
233 case value of
234 Value _-> Nothing
235 Alias name -> Just name
236 Union _ _ -> Nothing
239getUnions :: [Value] -> [(String, Listing String)]
240getUnions values =
241 Maybe.mapMaybe getUnion values
244getUnion :: Value -> Maybe (String, Listing String)
245getUnion value =
246 case value of
247 Value _ -> Nothing
248 Alias _ -> Nothing
249 Union name ctors -> Just (name, ctors)
252-- PRETTY VARIABLES
254instance P.Pretty Raw where
255 pretty _ _ (Raw name) =
256 if Help.isOp name
257 then P.parens (P.text name)
258 else P.text name
261instance P.Pretty Canonical where
262 pretty dealiaser _ var =
263 let
264 name = toString var
265 in
266 P.text (maybe name id (Map.lookup name dealiaser))
269instance P.Pretty a => P.Pretty (Listing a) where
270 pretty dealiaser _ (Listing explicits open) =
271 let dots = [if open then P.text ".." else P.empty]
272 in
273 P.parens (P.commaCat (map (P.pretty dealiaser False) explicits ++ dots))
276instance P.Pretty Value where
277 pretty dealiaser _ portable =
278 case portable of
279 Value name ->
280 P.text name
282 Alias name ->
283 P.text name
285 Union name ctors ->
286 P.text name <> P.pretty dealiaser False ctors
289-- BINARY SERIALIZATION
291instance Binary Canonical where
292 put (Canonical home name) =
293 case home of
294 BuiltIn ->
295 putWord8 0 >> put name
297 Module path ->
298 putWord8 1 >> put path >> put name
300 TopLevel path ->
301 putWord8 2 >> put path >> put name
303 Local ->
304 putWord8 3 >> put name
306 get =
307 do tag <- getWord8
308 case tag of
309 0 -> Canonical BuiltIn <$> get
310 1 -> Canonical . Module <$> get <*> get
311 2 -> Canonical . TopLevel <$> get <*> get
312 3 -> Canonical Local <$> get
313 _ -> error "Unexpected tag when deserializing canonical variable"
316instance Binary Value where
317 put portable =
318 case portable of
319 Value name ->
320 putWord8 0 >> put name
322 Alias name ->
323 putWord8 1 >> put name
325 Union name ctors ->
326 putWord8 2 >> put name >> put ctors
328 get =
329 do tag <- getWord8
330 case tag of
331 0 -> Value <$> get
332 1 -> Alias <$> get
333 2 -> Union <$> get <*> get
334 _ -> error "Error reading valid import/export information from serialized string"
337instance (Binary a) => Binary (Listing a) where
338 put (Listing explicits open) =
339 put explicits >> put open
341 get = Listing <$> get <*> get