git.iko.soy/elk
on 2ec798e help sign in
elk/src/AST/Variable.hs
263 lines 5.2 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
8import qualified AST.Helpers as Help
9import AST.PrettyPrint
12-- VARIABLES
14newtype Raw = Raw String
15 deriving (Eq,Ord,Show)
18data Home
19 = BuiltIn
20 | Module [String]
21 | Local
22 deriving (Eq,Ord,Show)
25data Canonical = Canonical
26 { home :: !Home
27 , name :: !String
28 }
29 deriving (Eq,Ord,Show)
32local :: String -> Canonical
33local x = Canonical Local x
36builtin :: String -> Canonical
37builtin x = Canonical BuiltIn x
40fromModule :: [String] -> String -> Canonical
41fromModule home name =
42 Canonical (Module home) name
45-- VARIABLE RECOGNIZERS
47is :: [String] -> String -> Canonical -> Bool
48is home name var =
49 var == Canonical (Module home) name
52isJson :: Canonical -> Bool
53isJson =
54 is ["Json", "Encode"] "Value"
57isMaybe :: Canonical -> Bool
58isMaybe =
59 is ["Maybe"] "Maybe"
61isArray :: Canonical -> Bool
62isArray =
63 is ["Array"] "Array"
66isSignal :: Canonical -> Bool
67isSignal =
68 is ["Signal"] "Signal"
71isPromise :: Canonical -> Bool
72isPromise =
73 is ["Promise"] "Promise"
76isList :: Canonical -> Bool
77isList v =
78 v == Canonical BuiltIn "List"
81isTuple :: Canonical -> Bool
82isTuple v =
83 case v of
84 Canonical BuiltIn name -> Help.isTuple name
85 _ -> False
88isPrimitive :: Canonical -> Bool
89isPrimitive v =
90 case v of
91 Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"]
92 _ -> False
95isPrim :: String -> Canonical -> Bool
96isPrim prim v =
97 case v of
98 Canonical BuiltIn name -> name == prim
99 _ -> False
102isText :: Canonical -> Bool
103isText =
104 is ["Text"] "Text"
107-- VARIABLE TO STRING
109class ToString a where
110 toString :: a -> String
113instance ToString Raw where
114 toString (Raw name) =
115 name
118instance ToString Canonical where
119 toString (Canonical home name) =
120 case home of
121 BuiltIn -> name
122 Module path -> List.intercalate "." (path ++ [name])
123 Local -> name
126-- LISTINGS
128-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
129data Listing a = Listing
130 { _explicits :: [a]
131 , _open :: Bool
132 } deriving (Eq,Ord,Show)
135openListing :: Listing a
136openListing =
137 Listing [] True
140closedListing :: Listing a
141closedListing =
142 Listing [] False
145listing :: [a] -> Listing a
146listing xs =
147 Listing xs False
150-- | A value that can be imported or exported
151data Value
152 = Value !String
153 | Alias !String
154 | Union !String !(Listing String)
155 deriving (Eq,Ord,Show)
158-- CATEGORIZING VALUES
160getValues :: [Value] -> [String]
161getValues values =
162 Maybe.mapMaybe getValue values
165getValue :: Value -> Maybe String
166getValue value =
167 case value of
168 Value name -> Just name
169 Alias _ -> Nothing
170 Union _ _ -> Nothing
173getAliases :: [Value] -> [String]
174getAliases values =
175 Maybe.mapMaybe getAlias values
178getAlias :: Value -> Maybe String
179getAlias value =
180 case value of
181 Value _-> Nothing
182 Alias name -> Just name
183 Union _ _ -> Nothing
186getUnions :: [Value] -> [(String, Listing String)]
187getUnions values =
188 Maybe.mapMaybe getUnion values
191getUnion :: Value -> Maybe (String, Listing String)
192getUnion value =
193 case value of
194 Value _ -> Nothing
195 Alias _ -> Nothing
196 Union name ctors -> Just (name, ctors)
199-- PRETTY VARIABLES
201instance Pretty Raw where
202 pretty (Raw name) =
203 variable name
206instance Pretty Canonical where
207 pretty var =
208 P.text (toString var)
211instance Pretty a => Pretty (Listing a) where
212 pretty (Listing explicits open) =
213 P.parens (commaCat (map pretty explicits ++ dots))
214 where
215 dots = [if open then P.text ".." else P.empty]
218instance Pretty Value where
219 pretty portable =
220 case portable of
221 Value name -> P.text name
222 Alias name -> P.text name
223 Union name ctors ->
224 P.text name <> pretty (ctors { _explicits = map P.text (_explicits ctors) })
227-- BINARY SERIALIZATION
229instance Binary Canonical where
230 put (Canonical home name) =
231 case home of
232 BuiltIn -> putWord8 0 >> put name
233 Module path -> putWord8 1 >> put path >> put name
234 Local -> putWord8 2 >> put name
236 get = do tag <- getWord8
237 case tag of
238 0 -> Canonical BuiltIn <$> get
239 1 -> Canonical . Module <$> get <*> get
240 2 -> Canonical Local <$> get
241 _ -> error "Unexpected tag when deserializing canonical variable"
244instance Binary Value where
245 put portable =
246 case portable of
247 Value name -> putWord8 0 >> put name
248 Alias name -> putWord8 1 >> put name
249 Union name ctors -> putWord8 2 >> put name >> put ctors
251 get = do tag <- getWord8
252 case tag of
253 0 -> Value <$> get
254 1 -> Alias <$> get
255 2 -> Union <$> get <*> get
256 _ -> error "Error reading valid import/export information from serialized string"
259instance (Binary a) => Binary (Listing a) where
260 put (Listing explicits open) =
261 put explicits >> put open
263 get = Listing <$> get <*> get