cli/Hcompta/CLI/Lib/Shakespeare/Base.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4 -- {-# LANGUAGE CPP #-}
   5
   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)
   9
  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.
  13
  14 -- | General parsers, functions and datatypes for all Shakespeare languages.
  15 module Hcompta.CLI.Lib.Shakespeare.Base
  16     ( Deref (..)
  17     , Ident (..)
  18     , Scope
  19     , parseDeref
  20     , parseHash
  21     , parseVar
  22     , parseVarString
  23     , parseAt
  24     , parseUrl
  25     , parseUrlString
  26     , parseCaret
  27     , parseUnder
  28     , parseInt
  29     , parseIntString
  30     , derefToExp
  31     , flattenDeref
  32     ) where
  33
  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)
  44
  45 newtype Ident = Ident String
  46     deriving (Show, Eq, Read, Data, Typeable, Ord)
  47
  48 type Scope = [(Ident, Exp)]
  49
  50 data Deref = DerefModulesIdent [String] Ident
  51            | DerefIdent Ident
  52            | DerefIntegral Integer
  53            | DerefRational Rational
  54            | DerefString String
  55            | DerefBranch Deref Deref
  56            | DerefList [Deref]
  57            | DerefTuple [Deref]
  58     deriving (Show, Eq, Read, Data, Typeable, Ord)
  59
  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|]
  65         v' <- lift v
  66         s' <- lift s
  67         return $ dl `AppE` v' `AppE` s'
  68     lift (DerefIdent s) = do
  69         dl <- [|DerefIdent|]
  70         s' <- lift s
  71         return $ dl `AppE` s'
  72     lift (DerefBranch x y) = do
  73         x' <- lift x
  74         y' <- lift y
  75         db <- [|DerefBranch|]
  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)|]
  87
  88 derefParens, derefCurlyBrackets :: UserParser a Deref
  89 derefParens        = between (char '(') (char ')') parseDeref
  90 derefCurlyBrackets = between (char '{') (char '}') parseDeref
  91
  92 derefList, derefTuple :: UserParser a Deref
  93 derefList = between (char '[') (char ']') (fmap DerefList $ sepBy parseDeref (char ','))
  94 derefTuple = try $ do
  95   _ <- char '('
  96   x <- sepBy1 parseDeref (char ',')
  97   when (length x < 2) $ pzero
  98   _ <- char ')'
  99   return $ DerefTuple x
 100
 101 parseDeref :: UserParser a Deref
 102 parseDeref = skipMany (oneOf " \t") >> (derefList <|>
 103                                         derefTuple <|> (do
 104     x <- derefSingle
 105     (derefInfix x) <|> (do
 106         res <- deref' $ (:) x
 107         skipMany $ oneOf " \t"
 108         return res)))
 109   where
 110     delim = (many1 (char ' ') >> return())
 111             <|> lookAhead (oneOf "(\"" >> return ())
 112     derefOp = try $ do
 113             _ <- char '('
 114             x <- many1 $ noneOf " \t\n\r()"
 115             _ <- char ')'
 116             return $ DerefIdent $ Ident x
 117
 118     -- See: http://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-160002.2
 119     isOperatorChar c
 120         | isAscii c = c `elem` "!#$%&*+./<=>?@\\^|-~:"
 121         | otherwise = isSymbol c || isPunctuation c
 122
 123     derefInfix x = try $ do
 124         _ <- delim
 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
 133     deref' lhs =
 134         dollar <|> derefSingle'
 135                <|> return (foldl1 DerefBranch $ lhs [])
 136       where
 137         dollar = do
 138             _ <- try $ delim >> char '$'
 139             rhs <- parseDeref
 140             let lhs' = foldl1 DerefBranch $ lhs []
 141             return $ DerefBranch lhs' rhs
 142         derefSingle' = do
 143             x <- try $ delim >> derefSingle
 144             deref' $ lhs . (:) x
 145     numeric = do
 146         n <- (char '-' >> return "-") <|> return ""
 147         x <- many1 digit
 148         y <- (char '.' >> fmap Just (many1 digit)) <|> return Nothing
 149         return $ case y of
 150             Nothing -> DerefIntegral $ read' "Integral" $ n ++ x
 151             Just z -> DerefRational $ toRational
 152                        (read' "Rational" $ n ++ x ++ '.' : z :: Double)
 153     strLit = do
 154         _ <- char '"'
 155         chars <- many quotedChar
 156         _ <- char '"'
 157         return $ DerefString chars
 158     quotedChar = (char '\\' >> escapedChar) <|> noneOf "\""
 159     escapedChar =
 160         let cecs = [('n', '\n'),  ('r', '\r'), ('b', '\b'), ('t', '\t')
 161                    ,('\\', '\\'), ('"', '"'),  ('\'', '\'')]
 162         in choice [ char c >> return ec | (c, ec) <- cecs]
 163     ident = do
 164         mods <- many modul
 165         func <- many1 (alphaNum <|> char '_' <|> char '\'')
 166         let func' = Ident func
 167         return $
 168             if null mods
 169                 then DerefIdent func'
 170                 else DerefModulesIdent mods func'
 171     modul = try $ do
 172         c <- upper
 173         cs <- many (alphaNum <|> char '_')
 174         _ <- char '.'
 175         return $ c : cs
 176
 177 read' :: Read a => String -> String -> a
 178 read' t s =
 179     case reads s of
 180         (x, _):_ -> x
 181         [] -> error $ t ++ " read failed: " ++ s
 182
 183 expType :: Ident -> Name -> Exp
 184 expType (Ident (c:_)) = if isUpper c || c == ':' then ConE else VarE
 185 expType (Ident "") = error "Bad Ident"
 186
 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
 193         Just e -> e
 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
 200
 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
 205     y' <- flattenDeref y
 206     Just $ y' ++ [x]
 207 flattenDeref _ = Nothing
 208
 209 parseHash :: UserParser a (Either String Deref)
 210 parseHash = parseVar '#'
 211
 212 curlyBrackets :: UserParser a String
 213 curlyBrackets = do
 214   _<- char '{'
 215   var <- many1 $ noneOf "}"
 216   _<- char '}'
 217   return $ ('{':var) ++ "}"
 218
 219
 220 type UserParser a = Parsec String a
 221
 222 parseVar :: Char -> UserParser a (Either String Deref)
 223 parseVar c = do
 224     _ <- char c
 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
 230             return $ Left ""
 231             ) <|> return (Left [c])
 232
 233 parseAt :: UserParser a (Either String (Deref, Bool))
 234 parseAt = parseUrl '@' '?'
 235
 236 parseUrl :: Char -> Char -> UserParser a (Either String (Deref, Bool))
 237 parseUrl c d = do
 238     _ <- char c
 239     (char '\\' >> return (Left [c])) <|> (do
 240         x <- (char d >> return True) <|> return False
 241         (do
 242             deref <- derefCurlyBrackets
 243             return $ Right (deref, x))
 244                 <|> return (Left $ if x then [c, d] else [c]))
 245
 246 parseInterpolatedString :: Char -> UserParser a (Either String String)
 247 parseInterpolatedString c = do
 248     _ <- char c
 249     (char '\\' >> return (Left ['\\', c])) <|> (do
 250         bracketed <- curlyBrackets
 251         return $ Right (c:bracketed)) <|> return (Left [c])
 252
 253 parseVarString :: Char -> UserParser a (Either String String)
 254 parseVarString = parseInterpolatedString
 255
 256 parseUrlString :: Char -> Char -> UserParser a (Either String String)
 257 parseUrlString c d = do
 258     _ <- char c
 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)))
 264
 265 parseIntString :: Char -> UserParser a (Either String String)
 266 parseIntString = parseInterpolatedString
 267
 268 parseCaret :: UserParser a (Either String Deref)
 269 parseCaret = parseInt '^'
 270
 271 parseInt :: Char -> UserParser a (Either String Deref)
 272 parseInt c = do
 273     _ <- char c
 274     (try $ char '\\' >> char '{' >> return (Left [c, '{'])) <|> (do
 275         deref <- derefCurlyBrackets
 276         return $ Right deref) <|> return (Left [c])
 277
 278 parseUnder :: UserParser a (Either String Deref)
 279 parseUnder = do
 280     _ <- char '_'
 281     (char '\\' >> return (Left "_")) <|> (do
 282         deref <- derefCurlyBrackets
 283         return $ Right deref) <|> return (Left "_")