1 {-# LANGUAGE TemplateHaskell #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
4 -- {-# LANGUAGE CPP #-}
6 -- Module : Text.Shakespeare.Base
7 -- Copyright : 2012 Michael Snoyman <michael@snoyman.com>, Jeremy Shaw
8 -- License : BSD-style (see the LICENSE file in the distribution)
10 -- NOTE: This module is embedded into Hcompta to avoid a dependency
11 -- on the aeson package which does not compile on systems
12 -- where GHCi is lacking.
14 -- | General parsers, functions and datatypes for all Shakespeare languages.
15 module Hcompta.CLI.Lib.Shakespeare.Base
34 import Language.Haskell.TH.Syntax
35 import Language.Haskell.TH (appE)
36 import Data.Char (isUpper, isSymbol, isPunctuation, isAscii)
37 import Text.ParserCombinators.Parsec
38 import Text.Parsec.Prim (Parsec)
39 import Data.List (intercalate)
40 import Data.Ratio (Ratio, numerator, denominator, (%))
41 import Data.Data (Data)
42 import Data.Typeable (Typeable)
43 import Control.Monad (when)
45 newtype Ident = Ident String
46 deriving (Show, Eq, Read, Data, Typeable, Ord)
48 type Scope = [(Ident, Exp)]
50 data Deref = DerefModulesIdent [String] Ident
52 | DerefIntegral Integer
53 | DerefRational Rational
55 | DerefBranch Deref Deref
58 deriving (Show, Eq, Read, Data, Typeable, Ord)
60 instance Lift Ident where
61 lift (Ident s) = [|Ident|] `appE` lift s
62 instance Lift Deref where
63 lift (DerefModulesIdent v s) = do
64 dl <- [|DerefModulesIdent|]
67 return $ dl `AppE` v' `AppE` s'
68 lift (DerefIdent s) = do
72 lift (DerefBranch x y) = do
76 return $ db `AppE` x' `AppE` y'
77 lift (DerefIntegral i) = [|DerefIntegral|] `appE` lift i
78 lift (DerefRational r) = do
79 n <- lift $ numerator r
80 d <- lift $ denominator r
81 per <- [|(%) :: Int -> Int -> Ratio Int|]
82 dr <- [|DerefRational|]
83 return $ dr `AppE` InfixE (Just n) per (Just d)
84 lift (DerefString s) = [|DerefString|] `appE` lift s
85 lift (DerefList x) = [|DerefList $(lift x)|]
86 lift (DerefTuple x) = [|DerefTuple $(lift x)|]
88 derefParens, derefCurlyBrackets :: UserParser a Deref
89 derefParens = between (char '(') (char ')') parseDeref
90 derefCurlyBrackets = between (char '{') (char '}') parseDeref
92 derefList, derefTuple :: UserParser a Deref
93 derefList = between (char '[') (char ']') (fmap DerefList $ sepBy parseDeref (char ','))
96 x <- sepBy1 parseDeref (char ',')
97 when (length x < 2) $ pzero
101 parseDeref :: UserParser a Deref
102 parseDeref = skipMany (oneOf " \t") >> (derefList <|>
105 (derefInfix x) <|> (do
106 res <- deref' $ (:) x
107 skipMany $ oneOf " \t"
110 delim = (many1 (char ' ') >> return())
111 <|> lookAhead (oneOf "(\"" >> return ())
114 x <- many1 $ noneOf " \t\n\r()"
116 return $ DerefIdent $ Ident x
118 -- See: http://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-160002.2
120 | isAscii c = c `elem` "!#$%&*+./<=>?@\\^|-~:"
121 | otherwise = isSymbol c || isPunctuation c
123 derefInfix x = try $ do
125 xs <- many $ try $ derefSingle >>= \x' -> delim >> return x'
126 op <- many1 (satisfy isOperatorChar) <?> "operator"
127 -- special handling for $, which we don't deal with
128 when (op == "$") $ fail "don't handle $"
129 let op' = DerefIdent $ Ident op
130 ys <- many1 $ delim >> derefSingle
131 return $ DerefBranch (DerefBranch op' $ foldl1 DerefBranch $ x : xs) (foldl1 DerefBranch ys)
132 derefSingle = derefTuple <|> derefList <|> derefOp <|> derefParens <|> numeric <|> strLit<|> ident
134 dollar <|> derefSingle'
135 <|> return (foldl1 DerefBranch $ lhs [])
138 _ <- try $ delim >> char '$'
140 let lhs' = foldl1 DerefBranch $ lhs []
141 return $ DerefBranch lhs' rhs
143 x <- try $ delim >> derefSingle
146 n <- (char '-' >> return "-") <|> return ""
148 y <- (char '.' >> fmap Just (many1 digit)) <|> return Nothing
150 Nothing -> DerefIntegral $ read' "Integral" $ n ++ x
151 Just z -> DerefRational $ toRational
152 (read' "Rational" $ n ++ x ++ '.' : z :: Double)
155 chars <- many quotedChar
157 return $ DerefString chars
158 quotedChar = (char '\\' >> escapedChar) <|> noneOf "\""
160 let cecs = [('n', '\n'), ('r', '\r'), ('b', '\b'), ('t', '\t')
161 ,('\\', '\\'), ('"', '"'), ('\'', '\'')]
162 in choice [ char c >> return ec | (c, ec) <- cecs]
165 func <- many1 (alphaNum <|> char '_' <|> char '\'')
166 let func' = Ident func
169 then DerefIdent func'
170 else DerefModulesIdent mods func'
173 cs <- many (alphaNum <|> char '_')
177 read' :: Read a => String -> String -> a
181 [] -> error $ t ++ " read failed: " ++ s
183 expType :: Ident -> Name -> Exp
184 expType (Ident (c:_)) = if isUpper c || c == ':' then ConE else VarE
185 expType (Ident "") = error "Bad Ident"
187 derefToExp :: Scope -> Deref -> Exp
188 derefToExp s (DerefBranch x y) = derefToExp s x `AppE` derefToExp s y
189 derefToExp _ (DerefModulesIdent mods i@(Ident s)) =
190 expType i $ Name (mkOccName s) (NameQ $ mkModName $ intercalate "." mods)
191 derefToExp scope (DerefIdent i@(Ident s)) =
192 case lookup i scope of
194 Nothing -> expType i $ mkName s
195 derefToExp _ (DerefIntegral i) = LitE $ IntegerL i
196 derefToExp _ (DerefRational r) = LitE $ RationalL r
197 derefToExp _ (DerefString s) = LitE $ StringL s
198 derefToExp s (DerefList ds) = ListE $ map (derefToExp s) ds
199 derefToExp s (DerefTuple ds) = TupE $ map (derefToExp s) ds
201 -- FIXME shouldn't we use something besides a list here?
202 flattenDeref :: Deref -> Maybe [String]
203 flattenDeref (DerefIdent (Ident x)) = Just [x]
204 flattenDeref (DerefBranch (DerefIdent (Ident x)) y) = do
207 flattenDeref _ = Nothing
209 parseHash :: UserParser a (Either String Deref)
210 parseHash = parseVar '#'
212 curlyBrackets :: UserParser a String
215 var <- many1 $ noneOf "}"
217 return $ ('{':var) ++ "}"
220 type UserParser a = Parsec String a
222 parseVar :: Char -> UserParser a (Either String Deref)
225 (char '\\' >> return (Left [c])) <|> (do
226 deref <- derefCurlyBrackets
227 return $ Right deref) <|> (do
228 -- Check for hash just before newline
229 _ <- lookAhead (oneOf "\r\n" >> return ()) <|> eof
231 ) <|> return (Left [c])
233 parseAt :: UserParser a (Either String (Deref, Bool))
234 parseAt = parseUrl '@' '?'
236 parseUrl :: Char -> Char -> UserParser a (Either String (Deref, Bool))
239 (char '\\' >> return (Left [c])) <|> (do
240 x <- (char d >> return True) <|> return False
242 deref <- derefCurlyBrackets
243 return $ Right (deref, x))
244 <|> return (Left $ if x then [c, d] else [c]))
246 parseInterpolatedString :: Char -> UserParser a (Either String String)
247 parseInterpolatedString c = do
249 (char '\\' >> return (Left ['\\', c])) <|> (do
250 bracketed <- curlyBrackets
251 return $ Right (c:bracketed)) <|> return (Left [c])
253 parseVarString :: Char -> UserParser a (Either String String)
254 parseVarString = parseInterpolatedString
256 parseUrlString :: Char -> Char -> UserParser a (Either String String)
257 parseUrlString c d = do
259 (char '\\' >> return (Left [c, '\\'])) <|> (do
260 ds <- (char d >> return [d]) <|> return []
261 (do bracketed <- curlyBrackets
262 return $ Right (c:ds ++ bracketed))
263 <|> return (Left (c:ds)))
265 parseIntString :: Char -> UserParser a (Either String String)
266 parseIntString = parseInterpolatedString
268 parseCaret :: UserParser a (Either String Deref)
269 parseCaret = parseInt '^'
271 parseInt :: Char -> UserParser a (Either String Deref)
274 (try $ char '\\' >> char '{' >> return (Left [c, '{'])) <|> (do
275 deref <- derefCurlyBrackets
276 return $ Right deref) <|> return (Left [c])
278 parseUnder :: UserParser a (Either String Deref)
281 (char '\\' >> return (Left "_")) <|> (do
282 deref <- derefCurlyBrackets
283 return $ Right deref) <|> return (Left "_")