git.iko.soy/elk
on 306a7ee help sign in
elk/src/AST/Variable.hs
253 lines 5.1 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"
66isList :: Canonical -> Bool
67isList v =
68 v == Canonical BuiltIn "List"
71isTuple :: Canonical -> Bool
72isTuple v =
73 case v of
74 Canonical BuiltIn name -> Help.isTuple name
75 _ -> False
78isPrimitive :: Canonical -> Bool
79isPrimitive v =
80 case v of
81 Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"]
82 _ -> False
85isPrim :: String -> Canonical -> Bool
86isPrim prim v =
87 case v of
88 Canonical BuiltIn name -> name == prim
89 _ -> False
92isText :: Canonical -> Bool
93isText =
94 is ["Text"] "Text"
97-- VARIABLE TO STRING
99class ToString a where
100 toString :: a -> String
103instance ToString Raw where
104 toString (Raw name) =
105 name
108instance ToString Canonical where
109 toString (Canonical home name) =
110 case home of
111 BuiltIn -> name
112 Module path -> List.intercalate "." (path ++ [name])
113 Local -> name
116-- LISTINGS
118-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
119data Listing a = Listing
120 { _explicits :: [a]
121 , _open :: Bool
122 } deriving (Eq,Ord,Show)
125openListing :: Listing a
126openListing =
127 Listing [] True
130closedListing :: Listing a
131closedListing =
132 Listing [] False
135listing :: [a] -> Listing a
136listing xs =
137 Listing xs False
140-- | A value that can be imported or exported
141data Value
142 = Value !String
143 | Alias !String
144 | Union !String !(Listing String)
145 deriving (Eq,Ord,Show)
148-- CATEGORIZING VALUES
150getValues :: [Value] -> [String]
151getValues values =
152 Maybe.mapMaybe getValue values
155getValue :: Value -> Maybe String
156getValue value =
157 case value of
158 Value name -> Just name
159 Alias _ -> Nothing
160 Union _ _ -> Nothing
163getAliases :: [Value] -> [String]
164getAliases values =
165 Maybe.mapMaybe getAlias values
168getAlias :: Value -> Maybe String
169getAlias value =
170 case value of
171 Value _-> Nothing
172 Alias name -> Just name
173 Union _ _ -> Nothing
176getUnions :: [Value] -> [(String, Listing String)]
177getUnions values =
178 Maybe.mapMaybe getUnion values
181getUnion :: Value -> Maybe (String, Listing String)
182getUnion value =
183 case value of
184 Value _ -> Nothing
185 Alias _ -> Nothing
186 Union name ctors -> Just (name, ctors)
189-- PRETTY VARIABLES
191instance Pretty Raw where
192 pretty (Raw name) =
193 variable name
196instance Pretty Canonical where
197 pretty var =
198 P.text (toString var)
201instance Pretty a => Pretty (Listing a) where
202 pretty (Listing explicits open) =
203 P.parens (commaCat (map pretty explicits ++ dots))
204 where
205 dots = [if open then P.text ".." else P.empty]
208instance Pretty Value where
209 pretty portable =
210 case portable of
211 Value name -> P.text name
212 Alias name -> P.text name
213 Union name ctors ->
214 P.text name <> pretty (ctors { _explicits = map P.text (_explicits ctors) })
217-- BINARY SERIALIZATION
219instance Binary Canonical where
220 put (Canonical home name) =
221 case home of
222 BuiltIn -> putWord8 0 >> put name
223 Module path -> putWord8 1 >> put path >> put name
224 Local -> putWord8 2 >> put name
226 get = do tag <- getWord8
227 case tag of
228 0 -> Canonical BuiltIn <$> get
229 1 -> Canonical . Module <$> get <*> get
230 2 -> Canonical Local <$> get
231 _ -> error "Unexpected tag when deserializing canonical variable"
234instance Binary Value where
235 put portable =
236 case portable of
237 Value name -> putWord8 0 >> put name
238 Alias name -> putWord8 1 >> put name
239 Union name ctors -> putWord8 2 >> put name >> put ctors
241 get = do tag <- getWord8
242 case tag of
243 0 -> Value <$> get
244 1 -> Alias <$> get
245 2 -> Union <$> get <*> get
246 _ -> error "Error reading valid import/export information from serialized string"
249instance (Binary a) => Binary (Listing a) where
250 put (Listing explicits open) =
251 put explicits >> put open
253 get = Listing <$> get <*> get