git.iko.soy/elk
on 6775458 help sign in
elk/src/AST/Variable.hs
248 lines 5.0 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
40-- VARIABLE RECOGNIZERS
42is :: [String] -> String -> Canonical -> Bool
43is home name var =
44 var == Canonical (Module home) name
47isJson :: Canonical -> Bool
48isJson =
49 is ["Json", "Encode"] "Value"
52isMaybe :: Canonical -> Bool
53isMaybe =
54 is ["Maybe"] "Maybe"
56isArray :: Canonical -> Bool
57isArray =
58 is ["Array"] "Array"
61isSignal :: Canonical -> Bool
62isSignal =
63 is ["Signal"] "Signal"
66isPromise :: Canonical -> Bool
67isPromise =
68 is ["Promise"] "Promise"
71isList :: Canonical -> Bool
72isList v =
73 v == Canonical BuiltIn "List"
76isTuple :: Canonical -> Bool
77isTuple v =
78 case v of
79 Canonical BuiltIn name -> Help.isTuple name
80 _ -> False
83isPrimitive :: Canonical -> Bool
84isPrimitive v =
85 case v of
86 Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"]
87 _ -> False
90isPrim :: String -> Canonical -> Bool
91isPrim prim v =
92 case v of
93 Canonical BuiltIn name -> name == prim
94 _ -> False
97isText :: Canonical -> Bool
98isText =
99 is ["Text"] "Text"
102-- VARIABLE TO STRING
104class ToString a where
105 toString :: a -> String
108instance ToString Raw where
109 toString (Raw name) =
110 name
113instance ToString Canonical where
114 toString (Canonical home name) =
115 case home of
116 BuiltIn -> name
117 Module path -> List.intercalate "." (path ++ [name])
118 Local -> name
121-- LISTINGS
123-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
124data Listing a = Listing
125 { _explicits :: [a]
126 , _open :: Bool
127 } deriving (Eq,Ord,Show)
130openListing :: Listing a
131openListing =
132 Listing [] True
135-- | A value that can be imported or exported
136data Value
137 = Value !String
138 | Alias !String
139 | Union !String !(Listing String)
140 deriving (Eq,Ord,Show)
143-- CATEGORIZING VALUES
145getValues :: [Value] -> [String]
146getValues values =
147 Maybe.mapMaybe getValue values
150getValue :: Value -> Maybe String
151getValue value =
152 case value of
153 Value name -> Just name
154 Alias _ -> Nothing
155 Union _ _ -> Nothing
158getAliases :: [Value] -> [String]
159getAliases values =
160 Maybe.mapMaybe getAlias values
163getAlias :: Value -> Maybe String
164getAlias value =
165 case value of
166 Value _-> Nothing
167 Alias name -> Just name
168 Union _ _ -> Nothing
171getUnions :: [Value] -> [(String, Listing String)]
172getUnions values =
173 Maybe.mapMaybe getUnion values
176getUnion :: Value -> Maybe (String, Listing String)
177getUnion value =
178 case value of
179 Value _ -> Nothing
180 Alias _ -> Nothing
181 Union name ctors -> Just (name, ctors)
184-- PRETTY VARIABLES
186instance Pretty Raw where
187 pretty (Raw name) =
188 variable name
191instance Pretty Canonical where
192 pretty var =
193 P.text (toString var)
196instance Pretty a => Pretty (Listing a) where
197 pretty (Listing explicits open) =
198 P.parens (commaCat (map pretty explicits ++ dots))
199 where
200 dots = [if open then P.text ".." else P.empty]
203instance Pretty Value where
204 pretty portable =
205 case portable of
206 Value name -> P.text name
207 Alias name -> P.text name
208 Union name ctors ->
209 P.text name <> pretty (ctors { _explicits = map P.text (_explicits ctors) })
212-- BINARY SERIALIZATION
214instance Binary Canonical where
215 put (Canonical home name) =
216 case home of
217 BuiltIn -> putWord8 0 >> put name
218 Module path -> putWord8 1 >> put path >> put name
219 Local -> putWord8 2 >> put name
221 get = do tag <- getWord8
222 case tag of
223 0 -> Canonical BuiltIn <$> get
224 1 -> Canonical . Module <$> get <*> get
225 2 -> Canonical Local <$> get
226 _ -> error "Unexpected tag when deserializing canonical variable"
229instance Binary Value where
230 put portable =
231 case portable of
232 Value name -> putWord8 0 >> put name
233 Alias name -> putWord8 1 >> put name
234 Union name ctors -> putWord8 2 >> put name >> put ctors
236 get = do tag <- getWord8
237 case tag of
238 0 -> Value <$> get
239 1 -> Alias <$> get
240 2 -> Union <$> get <*> get
241 _ -> error "Error reading valid import/export information from serialized string"
244instance (Binary a) => Binary (Listing a) where
245 put (Listing explicits open) =
246 put explicits >> put open
248 get = Listing <$> get <*> get