git.iko.soy/elk
on 2fbfb20 help sign in
elk/src/AST/Variable.hs
285 lines 5.4 kB history raw
1module AST.Variable where
3import Control.Applicative ((<$>), (<*>))
4import Data.Binary
5import qualified Data.List as List
6import qualified Data.Maybe as Maybe
7import Text.PrettyPrint as P
9import qualified AST.Helpers as Help
10import qualified Reporting.PrettyPrint as P
13-- VARIABLES
15newtype Raw = Raw String
16 deriving (Eq, Ord, Show)
19data Home
20 = BuiltIn
21 | Module [String]
22 | Local
23 deriving (Eq, Ord, Show)
26data Canonical = Canonical
27 { home :: !Home
28 , name :: !String
29 }
30 deriving (Eq, Ord, Show)
33local :: String -> Canonical
34local x = Canonical Local x
37builtin :: String -> Canonical
38builtin x = Canonical BuiltIn x
41fromModule :: [String] -> String -> Canonical
42fromModule home name =
43 Canonical (Module home) name
46-- VARIABLE RECOGNIZERS
48is :: [String] -> String -> Canonical -> Bool
49is home name var =
50 var == Canonical (Module home) name
53isJson :: Canonical -> Bool
54isJson =
55 is ["Json", "Encode"] "Value"
58isMaybe :: Canonical -> Bool
59isMaybe =
60 is ["Maybe"] "Maybe"
62isArray :: Canonical -> Bool
63isArray =
64 is ["Array"] "Array"
67isTask :: Canonical -> Bool
68isTask =
69 is ["Task"] "Task"
72isSignal :: Canonical -> Bool
73isSignal =
74 is ["Signal"] "Signal"
77isList :: Canonical -> Bool
78isList v =
79 v == Canonical BuiltIn "List"
82isTuple :: Canonical -> Bool
83isTuple v =
84 case v of
85 Canonical BuiltIn name -> Help.isTuple name
86 _ -> False
89isPrimitive :: Canonical -> Bool
90isPrimitive v =
91 case v of
92 Canonical BuiltIn name ->
93 name `elem` ["Int","Float","String","Bool"]
94 _ ->
95 False
98isPrim :: String -> Canonical -> Bool
99isPrim prim v =
100 case v of
101 Canonical BuiltIn name -> name == prim
102 _ -> False
105isText :: Canonical -> Bool
106isText =
107 is ["Text"] "Text"
110-- VARIABLE TO STRING
112class ToString a where
113 toString :: a -> String
116instance ToString Raw where
117 toString (Raw name) =
118 name
121instance ToString Canonical where
122 toString (Canonical home name) =
123 case home of
124 BuiltIn -> name
125 Module path -> List.intercalate "." (path ++ [name])
126 Local -> name
129-- LISTINGS
131-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
132data Listing a = Listing
133 { _explicits :: [a]
134 , _open :: Bool
135 }
136 deriving (Eq, Ord, Show)
139openListing :: Listing a
140openListing =
141 Listing [] True
144closedListing :: Listing a
145closedListing =
146 Listing [] False
149listing :: [a] -> Listing a
150listing xs =
151 Listing xs False
154-- | A value that can be imported or exported
155data Value
156 = Value !String
157 | Alias !String
158 | Union !String !(Listing String)
159 deriving (Eq, Ord, Show)
162-- CATEGORIZING VALUES
164getValues :: [Value] -> [String]
165getValues values =
166 Maybe.mapMaybe getValue values
169getValue :: Value -> Maybe String
170getValue value =
171 case value of
172 Value name -> Just name
173 Alias _ -> Nothing
174 Union _ _ -> Nothing
177getAliases :: [Value] -> [String]
178getAliases values =
179 Maybe.mapMaybe getAlias values
182getAlias :: Value -> Maybe String
183getAlias value =
184 case value of
185 Value _-> Nothing
186 Alias name -> Just name
187 Union _ _ -> Nothing
190getUnions :: [Value] -> [(String, Listing String)]
191getUnions values =
192 Maybe.mapMaybe getUnion values
195getUnion :: Value -> Maybe (String, Listing String)
196getUnion value =
197 case value of
198 Value _ -> Nothing
199 Alias _ -> Nothing
200 Union name ctors -> Just (name, ctors)
203-- PRETTY VARIABLES
205instance P.Pretty Raw where
206 pretty _ (Raw name) =
207 if Help.isOp name
208 then P.parens (P.text name)
209 else P.text name
212instance P.Pretty Canonical where
213 pretty _ var =
214 P.text (toString var)
217instance P.Pretty a => P.Pretty (Listing a) where
218 pretty _ (Listing explicits open) =
219 let dots = [if open then P.text ".." else P.empty]
220 in
221 P.parens (P.commaCat (map (P.pretty False) explicits ++ dots))
224instance P.Pretty Value where
225 pretty _ portable =
226 case portable of
227 Value name ->
228 P.text name
230 Alias name ->
231 P.text name
233 Union name ctors ->
234 P.text name <> P.pretty False ctors
237-- BINARY SERIALIZATION
239instance Binary Canonical where
240 put (Canonical home name) =
241 case home of
242 BuiltIn ->
243 putWord8 0 >> put name
245 Module path ->
246 putWord8 1 >> put path >> put name
248 Local ->
249 putWord8 2 >> put name
251 get =
252 do tag <- getWord8
253 case tag of
254 0 -> Canonical BuiltIn <$> get
255 1 -> Canonical . Module <$> get <*> get
256 2 -> Canonical Local <$> get
257 _ -> error "Unexpected tag when deserializing canonical variable"
260instance Binary Value where
261 put portable =
262 case portable of
263 Value name ->
264 putWord8 0 >> put name
266 Alias name ->
267 putWord8 1 >> put name
269 Union name ctors ->
270 putWord8 2 >> put name >> put ctors
272 get =
273 do tag <- getWord8
274 case tag of
275 0 -> Value <$> get
276 1 -> Alias <$> get
277 2 -> Union <$> get <*> get
278 _ -> error "Error reading valid import/export information from serialized string"
281instance (Binary a) => Binary (Listing a) where
282 put (Listing explicits open) =
283 put explicits >> put open
285 get = Listing <$> get <*> get