git.iko.soy/elk
on fcdbe58 help sign in
elk/src/AST/Variable.hs
153 lines 4.0 kB history raw
1module AST.Variable where
3import Control.Applicative ((<$>), (<*>))
4import Data.Binary
5import qualified Data.List as List
6import Text.PrettyPrint as P
7import qualified AST.Helpers as Help
8import AST.PrettyPrint
10newtype Raw = Raw String
11 deriving (Eq,Ord,Show)
13data Home
14 = BuiltIn
15 | Module [String]
16 | Local
17 deriving (Eq,Ord,Show)
19data Canonical = Canonical
20 { home :: !Home
21 , name :: !String
22 } deriving (Eq,Ord,Show)
24local :: String -> Canonical
25local x = Canonical Local x
27builtin :: String -> Canonical
28builtin x = Canonical BuiltIn x
30-- To help with pattern matching on some common canonical variables:
31is :: [String] -> String -> Canonical -> Bool
32is home name var =
33 var == Canonical (Module home) name
35isJson :: Canonical -> Bool
36isJson = is ["Json"] "Value"
38isMaybe :: Canonical -> Bool
39isMaybe = is ["Maybe"] "Maybe"
41isArray :: Canonical -> Bool
42isArray = is ["Array"] "Array"
44isSignal :: Canonical -> Bool
45isSignal = is ["Signal"] "Signal"
47isList :: Canonical -> Bool
48isList v =
49 v == Canonical BuiltIn "_List"
51isTuple :: Canonical -> Bool
52isTuple v =
53 case v of
54 Canonical BuiltIn name -> Help.isTuple name
55 _ -> False
57isPrimitive :: Canonical -> Bool
58isPrimitive v =
59 case v of
60 Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"]
61 _ -> False
63isPrim :: String -> Canonical -> Bool
64isPrim prim v =
65 case v of
66 Canonical BuiltIn name -> name == prim
67 _ -> False
69isText :: Canonical -> Bool
70isText = is ["Text"] "Text"
72class ToString a where
73 toString :: a -> String
75instance ToString Raw where
76 toString (Raw x) = x
78instance ToString Canonical where
79 toString (Canonical home name) =
80 case home of
81 BuiltIn -> name
82 Module path -> List.intercalate "." (path ++ [name])
83 Local -> name
85-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
86data Listing a = Listing
87 { _explicits :: [a]
88 , _open :: Bool
89 } deriving (Eq,Ord,Show)
91openListing :: Listing a
92openListing = Listing [] True
94-- | A value that can be imported or exported
95data Value
96 = Value !String
97 | Alias !String
98 | ADT !String !(Listing String)
99 deriving (Eq,Ord,Show)
101instance Pretty Raw where
102 pretty (Raw var) = variable var
104instance Pretty Canonical where
105 pretty var = P.text (toString var)
107instance Pretty a => Pretty (Listing a) where
108 pretty (Listing explicits open) =
109 P.parens (commaCat (map pretty explicits ++ dots))
110 where
111 dots = [if open then P.text ".." else P.empty]
113instance Pretty Value where
114 pretty portable =
115 case portable of
116 Value name -> P.text name
117 Alias name -> P.text name
118 ADT name ctors ->
119 P.text name <> pretty (ctors { _explicits = map P.text (_explicits ctors) })
121instance Binary Canonical where
122 put (Canonical home name) =
123 case home of
124 BuiltIn -> putWord8 0 >> put name
125 Module path -> putWord8 1 >> put path >> put name
126 Local -> putWord8 2 >> put name
128 get = do tag <- getWord8
129 case tag of
130 0 -> Canonical BuiltIn <$> get
131 1 -> Canonical . Module <$> get <*> get
132 2 -> Canonical Local <$> get
133 _ -> error "Unexpected tag when deserializing canonical variable"
135instance Binary Value where
136 put portable =
137 case portable of
138 Value name -> putWord8 0 >> put name
139 Alias name -> putWord8 1 >> put name
140 ADT name ctors -> putWord8 2 >> put name >> put ctors
142 get = do tag <- getWord8
143 case tag of
144 0 -> Value <$> get
145 1 -> Alias <$> get
146 2 -> ADT <$> get <*> get
147 _ -> error "Error reading valid import/export information from serialized string"
149instance (Binary a) => Binary (Listing a) where
150 put (Listing explicits open) =
151 put explicits >> put open
153 get = Listing <$> get <*> get