git.iko.soy/elk
on 2a930fd help sign in
elk/src/AST/Variable.hs
154 lines 4.0 kB history raw
1{-# OPTIONS_GHC -W #-}
2module AST.Variable where
4import Control.Applicative ((<$>), (<*>))
5import Data.Binary
6import qualified Data.List as List
7import Text.PrettyPrint as P
8import qualified AST.Helpers as Help
9import AST.PrettyPrint
11newtype Raw = Raw String
12 deriving (Eq,Ord,Show)
14data Home
15 = BuiltIn
16 | Module [String]
17 | Local
18 deriving (Eq,Ord,Show)
20data Canonical = Canonical
21 { home :: !Home
22 , name :: !String
23 } deriving (Eq,Ord,Show)
25local :: String -> Canonical
26local x = Canonical Local x
28builtin :: String -> Canonical
29builtin x = Canonical BuiltIn x
31-- To help with pattern matching on some common canonical variables:
32is :: [String] -> String -> Canonical -> Bool
33is home name var =
34 var == Canonical (Module home) name
36isJson :: Canonical -> Bool
37isJson = is ["Json"] "Value"
39isMaybe :: Canonical -> Bool
40isMaybe = is ["Maybe"] "Maybe"
42isArray :: Canonical -> Bool
43isArray = is ["Array"] "Array"
45isSignal :: Canonical -> Bool
46isSignal = is ["Signal"] "Signal"
48isList :: Canonical -> Bool
49isList v =
50 v == Canonical BuiltIn "_List"
52isTuple :: Canonical -> Bool
53isTuple v =
54 case v of
55 Canonical BuiltIn name -> Help.isTuple name
56 _ -> False
58isPrimitive :: Canonical -> Bool
59isPrimitive v =
60 case v of
61 Canonical BuiltIn name -> name `elem` ["Int","Float","String","Bool"]
62 _ -> False
64isPrim :: String -> Canonical -> Bool
65isPrim prim v =
66 case v of
67 Canonical BuiltIn name -> name == prim
68 _ -> False
70isText :: Canonical -> Bool
71isText = is ["Text"] "Text"
73class ToString a where
74 toString :: a -> String
76instance ToString Raw where
77 toString (Raw x) = x
79instance ToString Canonical where
80 toString (Canonical home name) =
81 case home of
82 BuiltIn -> name
83 Module path -> List.intercalate "." (path ++ [name])
84 Local -> name
86-- | A listing of values. Something like (a,b,c) or (..) or (a,b,..)
87data Listing a = Listing
88 { _explicits :: [a]
89 , _open :: Bool
90 } deriving (Eq,Ord,Show)
92openListing :: Listing a
93openListing = Listing [] True
95-- | A value that can be imported or exported
96data Value
97 = Value !String
98 | Alias !String
99 | ADT !String !(Listing String)
100 deriving (Eq,Ord,Show)
102instance Pretty Raw where
103 pretty (Raw var) = variable var
105instance Pretty Canonical where
106 pretty var = P.text (toString var)
108instance Pretty a => Pretty (Listing a) where
109 pretty (Listing explicits open) =
110 P.parens (commaCat (map pretty explicits ++ dots))
111 where
112 dots = [if open then P.text ".." else P.empty]
114instance Pretty Value where
115 pretty portable =
116 case portable of
117 Value name -> P.text name
118 Alias name -> P.text name
119 ADT name ctors ->
120 P.text name <> pretty (ctors { _explicits = map P.text (_explicits ctors) })
122instance Binary Canonical where
123 put (Canonical home name) =
124 case home of
125 BuiltIn -> putWord8 0 >> put name
126 Module path -> putWord8 1 >> put path >> put name
127 Local -> putWord8 2 >> put name
129 get = do tag <- getWord8
130 case tag of
131 0 -> Canonical BuiltIn <$> get
132 1 -> Canonical . Module <$> get <*> get
133 2 -> Canonical Local <$> get
134 _ -> error "Unexpected tag when deserializing canonical variable"
136instance Binary Value where
137 put portable =
138 case portable of
139 Value name -> putWord8 0 >> put name
140 Alias name -> putWord8 1 >> put name
141 ADT name ctors -> putWord8 2 >> put name >> put ctors
143 get = do tag <- getWord8
144 case tag of
145 0 -> Value <$> get
146 1 -> Alias <$> get
147 2 -> ADT <$> get <*> get
148 _ -> error "Error reading valid import/export information from serialized string"
150instance (Binary a) => Binary (Listing a) where
151 put (Listing explicits open) =
152 put explicits >> put open
154 get = Listing <$> get <*> get