module Text.Shakespeare
( ShakespeareSettings (..)
, PreConvert (..)
, PreConversion (..)
, defaultShakespeareSettings
, shakespeare
, shakespeareFile
, shakespeareFileReload
, shakespeareFromString
, RenderUrl
#ifdef TEST_EXPORT
, preFilter
#endif
) where
import Text.ParserCombinators.Parsec hiding (Line)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Syntax.Internals
import Data.Text.Lazy.Builder (Builder, fromText)
import Data.Monoid
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Text as TS
import qualified Data.Text.Lazy as TL
import Text.Shakespeare.Base
import System.Process (readProcess)
readFileQ :: FilePath -> Q String
readFileQ fp = qRunIO $ readFileUtf8 fp
readFileUtf8 :: FilePath -> IO String
readFileUtf8 fp = fmap TL.unpack $ readUtf8File fp
data PreConvert = PreConvert
{ preConvert :: PreConversion
, preEscapeBegin :: String
, preEscapeEnd :: String
, preEscapeIgnoreBalanced :: [Char]
, preEscapeIgnoreLine :: [Char]
}
data PreConversion = ReadProcess String [String]
| Id
data ShakespeareSettings = ShakespeareSettings
{ varChar :: Char
, urlChar :: Char
, intChar :: Char
, toBuilder :: Exp
, wrap :: Exp
, unwrap :: Exp
, justVarInterpolation :: Bool
, preConversion :: Maybe PreConvert
}
defaultShakespeareSettings :: ShakespeareSettings
defaultShakespeareSettings = ShakespeareSettings {
varChar = '#'
, urlChar = '@'
, intChar = '^'
, justVarInterpolation = False
, preConversion = Nothing
}
instance Lift PreConvert where
lift (PreConvert convert begin end ignore comment) =
[|PreConvert $(lift convert) $(lift begin) $(lift end) $(lift ignore) $(lift comment)|]
instance Lift PreConversion where
lift (ReadProcess command args) =
[|ReadProcess $(lift command) $(lift args)|]
lift Id = [|Id|]
instance Lift ShakespeareSettings where
lift (ShakespeareSettings x1 x2 x3 x4 x5 x6 x7 x8) =
[|ShakespeareSettings
$(lift x1) $(lift x2) $(lift x3)
$(liftExp x4) $(liftExp x5) $(liftExp x6) $(lift x7) $(lift x8)|]
where
liftExp (VarE n) = [|VarE $(liftName n)|]
liftExp (ConE n) = [|ConE $(liftName n)|]
liftExp _ = error "liftExp only supports VarE and ConE"
liftName (Name (OccName a) b) = [|Name (OccName $(lift a)) $(liftFlavour b)|]
liftFlavour NameS = [|NameS|]
liftFlavour (NameQ (ModName a)) = [|NameQ (ModName $(lift a))|]
liftFlavour (NameU _) = error "liftFlavour NameU"
liftFlavour (NameL _) = error "liftFlavour NameL"
liftFlavour (NameG ns (PkgName p) (ModName m)) = [|NameG $(liftNS ns) (PkgName $(lift p)) (ModName $(lift m))|]
liftNS VarName = [|VarName|]
liftNS DataName = [|DataName|]
type QueryParameters = [(TS.Text, TS.Text)]
type RenderUrl url = (url -> QueryParameters -> TS.Text)
type Shakespeare url = RenderUrl url -> Builder
data Content = ContentRaw String
| ContentVar Deref
| ContentUrl Deref
| ContentUrlParam Deref
| ContentMix Deref
deriving (Show, Eq)
type Contents = [Content]
eShowErrors :: Either ParseError c -> c
eShowErrors = either (error . show) id
contentFromString :: ShakespeareSettings -> String -> [Content]
contentFromString rs s =
compressContents $ eShowErrors $ parse (parseContents rs) s s
where
compressContents :: Contents -> Contents
compressContents [] = []
compressContents (ContentRaw x:ContentRaw y:z) =
compressContents $ ContentRaw (x ++ y) : z
compressContents (x:y) = x : compressContents y
parseContents :: ShakespeareSettings -> Parser Contents
parseContents = many1 . parseContent
where
parseContent :: ShakespeareSettings -> Parser Content
parseContent ShakespeareSettings {..} =
parseVar' <|> parseUrl' <|> parseInt' <|> parseChar'
where
parseVar' = either ContentRaw ContentVar `fmap` parseVar varChar
parseUrl' = either ContentRaw contentUrl `fmap` parseUrl urlChar '?'
where
contentUrl (d, False) = ContentUrl d
contentUrl (d, True) = ContentUrlParam d
parseInt' = either ContentRaw ContentMix `fmap` parseInt intChar
parseChar' = ContentRaw `fmap` many1 (noneOf [varChar, urlChar, intChar])
preFilter :: ShakespeareSettings -> String -> IO String
preFilter ShakespeareSettings {..} s =
case preConversion of
Nothing -> return s
Just pre@(PreConvert convert _ _ _ _) ->
let parsed = mconcat $ eShowErrors $ parse (parseConvert pre) s s
in case convert of
Id -> return parsed
ReadProcess command args ->
readProcess command args parsed
where
parseConvert PreConvert {..} = many1 $ choice $
map (try . escapedParse) preEscapeIgnoreBalanced ++
[mainParser]
where
escapedParse ignoreC = do
_<- char ignoreC
inside <- many $ noneOf [ignoreC]
_<- char ignoreC
return $ ignoreC:inside ++ [ignoreC]
mainParser =
parseVar' <|>
parseUrl' <|>
parseInt' <|>
parseCommentLine preEscapeIgnoreLine <|>
parseChar' preEscapeIgnoreLine preEscapeIgnoreBalanced
escape str = preEscapeBegin ++ str ++ preEscapeEnd
escapeRight = either id escape
newLine = "\r\n"
parseCommentLine cs = do
begin <- oneOf cs
comment <- many $ noneOf newLine
return $ begin : comment
parseVar' = escapeRight `fmap` parseVarString varChar
parseUrl' = escapeRight `fmap` parseUrlString urlChar '?'
parseInt' = escapeRight `fmap` parseIntString intChar
parseChar' comments ignores =
many1 (noneOf ([varChar, urlChar, intChar] ++ comments ++ ignores))
pack' :: String -> TS.Text
pack' = TS.pack
#if !MIN_VERSION_text(0, 11, 2)
#endif
contentsToShakespeare :: ShakespeareSettings -> [Content] -> Q Exp
contentsToShakespeare rs a = do
r <- newName "_render"
c <- mapM (contentToBuilder r) a
compiledTemplate <- case c of
[] -> [|mempty|]
[x] -> return x
_ -> do
mc <- [|mconcat|]
return $ mc `AppE` ListE c
if justVarInterpolation rs
then return compiledTemplate
else return $ LamE [VarP r] compiledTemplate
where
contentToBuilder :: Name -> Content -> Q Exp
contentToBuilder _ (ContentRaw s') = do
ts <- [|fromText . pack'|]
return $ wrap rs `AppE` (ts `AppE` LitE (StringL s'))
contentToBuilder _ (ContentVar d) =
return $ wrap rs `AppE` (toBuilder rs `AppE` derefToExp [] d)
contentToBuilder r (ContentUrl d) = do
ts <- [|fromText|]
return $ wrap rs `AppE` (ts `AppE` (VarE r `AppE` derefToExp [] d `AppE` ListE []))
contentToBuilder r (ContentUrlParam d) = do
ts <- [|fromText|]
up <- [|\r' (u, p) -> r' u p|]
return $ wrap rs `AppE` (ts `AppE` (up `AppE` VarE r `AppE` derefToExp [] d))
contentToBuilder r (ContentMix d) =
return $ derefToExp [] d `AppE` VarE r
shakespeare :: ShakespeareSettings -> QuasiQuoter
shakespeare r = QuasiQuoter { quoteExp = shakespeareFromString r }
shakespeareFromString :: ShakespeareSettings -> String -> Q Exp
shakespeareFromString r str = do
s <- qRunIO $ preFilter r str
contentsToShakespeare r $ contentFromString r s
shakespeareFile :: ShakespeareSettings -> FilePath -> Q Exp
shakespeareFile r fp = do
#ifdef GHC_7_4
qAddDependentFile fp
#endif
readFileQ fp >>= shakespeareFromString r
data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin
getVars :: Content -> [(Deref, VarType)]
getVars ContentRaw{} = []
getVars (ContentVar d) = [(d, VTPlain)]
getVars (ContentUrl d) = [(d, VTUrl)]
getVars (ContentUrlParam d) = [(d, VTUrlParam)]
getVars (ContentMix d) = [(d, VTMixin)]
data VarExp url = EPlain Builder
| EUrl url
| EUrlParam (url, [(TS.Text, TS.Text)])
| EMixin (Shakespeare url)
shakespeareFileReload :: ShakespeareSettings -> FilePath -> Q Exp
shakespeareFileReload rs fp = do
str <- readFileQ fp
s <- qRunIO $ preFilter rs str
let b = concatMap getVars $ contentFromString rs s
c <- mapM vtToExp b
rt <- [|shakespeareRuntime|]
wrap' <- [|\x -> $(return $ wrap rs) . x|]
r' <- lift rs
return $ wrap' `AppE` (rt `AppE` r' `AppE` (LitE $ StringL fp) `AppE` ListE c)
where
vtToExp :: (Deref, VarType) -> Q Exp
vtToExp (d, vt) = do
d' <- lift d
c' <- c vt
return $ TupE [d', c' `AppE` derefToExp [] d]
where
c :: VarType -> Q Exp
c VTPlain = [|EPlain . $(return $ toBuilder rs)|]
c VTUrl = [|EUrl|]
c VTUrlParam = [|EUrlParam|]
c VTMixin = [|\x -> EMixin $ \r -> $(return $ unwrap rs) $ x r|]
shakespeareRuntime :: ShakespeareSettings -> FilePath -> [(Deref, VarExp url)] -> Shakespeare url
shakespeareRuntime rs fp cd render' = unsafePerformIO $ do
str <- readFileUtf8 fp
s <- preFilter rs str
return $ mconcat $ map go $ contentFromString rs s
where
go :: Content -> Builder
go (ContentRaw s) = fromText $ TS.pack s
go (ContentVar d) =
case lookup d cd of
Just (EPlain s) -> s
_ -> error $ show d ++ ": expected EPlain"
go (ContentUrl d) =
case lookup d cd of
Just (EUrl u) -> fromText $ render' u []
_ -> error $ show d ++ ": expected EUrl"
go (ContentUrlParam d) =
case lookup d cd of
Just (EUrlParam (u, p)) ->
fromText $ render' u p
_ -> error $ show d ++ ": expected EUrlParam"
go (ContentMix d) =
case lookup d cd of
Just (EMixin m) -> m render'
_ -> error $ show d ++ ": expected EMixin"