Text/Hamlet/Quasi.hs

{-# LANGUAGE TemplateHaskell #-}
module Text.Hamlet.Quasi
    ( hamlet
    , xhamlet
    , hamletWithSettings
    ) where

import Text.Hamlet.Parse
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Quote
import Data.Char (isUpper)
import qualified Data.ByteString.UTF8 as BSU
import qualified Data.ByteString.Char8 as S8
import Data.Monoid (mconcat, mappend, mempty)
import Text.Blaze (unsafeByteString, Html, string)
import Data.List (intercalate)

type Scope = [(Ident, Exp)]

docsToExp :: Exp -> Scope -> [Doc] -> Q Exp
docsToExp render scope docs = do
    exps <- mapM (docToExp render scope) docs
    me <- [|mempty|]
    return $
        case exps of
            [] -> me
            [x] -> x
            _ ->
                let x = init exps
                    y = last exps
                    x' = map (BindS WildP) x
                    y' = NoBindS y
                 in DoE $ x' ++ [y']

docToExp :: Exp -> Scope -> Doc -> Q Exp
docToExp render scope (DocForall list ident@(Ident name) inside) = do
    let list' = deref scope list
    name' <- newName name
    let scope' = (ident, VarE name') : scope
    mh <- [|\a -> mconcat . map a|]
    inside' <- docsToExp render scope' inside
    let lam = LamE [VarP name'] inside'
    return $ mh `AppE` lam `AppE` list'
docToExp render scope (DocMaybe val ident@(Ident name) inside mno) = do
    let val' = deref scope val
    name' <- newName name
    let scope' = (ident, VarE name') : scope
    inside' <- docsToExp render scope' inside
    let inside'' = LamE [VarP name'] inside'
    ninside' <- case mno of
                    Nothing -> [|Nothing|]
                    Just no -> do
                        no' <- docsToExp render scope no
                        j <- [|Just|]
                        return $ j `AppE` no'
    mh <- [|maybeH|]
    return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'
docToExp render scope (DocCond conds final) = do
    conds' <- mapM go conds
    final' <- case final of
                Nothing -> [|Nothing|]
                Just f -> do
                    f' <- docsToExp render scope f
                    j <- [|Just|]
                    return $ j `AppE` f'
    ch <- [|condH|]
    return $ ch `AppE` ListE conds' `AppE` final'
  where
    go :: (Deref, [Doc]) -> Q Exp
    go (d, docs) = do
        let d' = deref scope d
        docs' <- docsToExp render scope docs
        return $ TupE [d', docs']
docToExp render v (DocContent c) = contentToExp render v c

contentToExp :: Exp -> Scope -> Content -> Q Exp
contentToExp _ _ (ContentRaw s) = do
    os <- [|unsafeByteString . S8.pack|]
    let s' = LitE $ StringL $ S8.unpack $ BSU.fromString s
    return $ os `AppE` s'
contentToExp _ scope (ContentVar d) = return $ deref scope d
contentToExp render scope (ContentUrl hasParams d) = do
    ou <- if hasParams then [|outputUrlParams|] else [|outputUrl|]
    let d' = deref scope d
    return $ ou `AppE` render `AppE` d'
contentToExp render scope (ContentEmbed d) = do
    let d' = deref scope d
    return (d' `AppE` render)

-- | Calls 'hamletWithSettings' with 'defaultHamletSettings'.
hamlet :: QuasiQuoter
hamlet = hamletWithSettings defaultHamletSettings

-- | Calls 'hamletWithSettings' using XHTML 1.0 Strict settings.
xhamlet :: QuasiQuoter
xhamlet = hamletWithSettings $ HamletSettings doctype True where
    doctype =
      "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " ++
      "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"

-- | A quasi-quoter that converts Hamlet syntax into a function of form:
--
-- > (url -> String) -> Html
--
-- Please see accompanying documentation for a description of Hamlet syntax.
hamletWithSettings :: HamletSettings -> QuasiQuoter
hamletWithSettings set =
    QuasiQuoter go $ error "Cannot quasi-quote Hamlet to patterns"
  where
    go s = do
      case parseDoc set s of
        Error s' -> error s'
        Ok d -> do
            render <- newName "_render"
            func <- docsToExp (VarE render) [] d
            return $ LamE [VarP render] func

deref :: Scope -> Deref -> Exp
deref _ (Deref []) = error "Invalid empty deref"
deref scope (Deref (z@(Ident zName):y)) =
    let z' = case lookup z scope of
                Nothing -> varName zName
                Just zExp -> zExp
     in foldr go z' $ reverse y
  where
    varName "" = error "Illegal empty varName"
    varName v@(s:_) =
        case lookup (Ident v) scope of
            Just e -> e
            Nothing ->
                if isUpper s
                    then ConE $ mkName v
                    else VarE $ mkName v
    go (Ident func) z' = varName func `AppE` z'

-- | Checks for truth in the left value in each pair in the first argument. If
-- a true exists, then the corresponding right action is performed. Only the
-- first is performed. In there are no true values, then the second argument is
-- performed, if supplied.
condH :: [(Bool, Html ())] -> Maybe (Html ()) -> Html ()
condH [] Nothing = mempty
condH [] (Just x) = x
condH ((True, y):_) _ = y
condH ((False, _):rest) z = condH rest z

-- | Runs the second argument with the value in the first, if available.
-- Otherwise, runs the third argument, if available.
maybeH :: Maybe v -> (v -> Html ()) -> Maybe (Html ()) -> Html ()
maybeH Nothing _ Nothing = mempty
maybeH Nothing _ (Just x) = x
maybeH (Just v) f _ = f v

-- | Uses the URL rendering function to convert the given URL to a 'String' and
-- then calls 'outputString'.
outputUrl :: (url -> String) -> url -> Html ()
outputUrl render u = string $ render u

-- | Same as 'outputUrl', but appends a query-string with given keys and
-- values.
outputUrlParams :: (url -> String) -> (url, [(String, String)]) -> Html ()
outputUrlParams render (u, []) = outputUrl render u
outputUrlParams render (u, params) = mappend
    (outputUrl render u)
    (string $ showParams params)
  where
    showParams x = '?' : intercalate "&" (map go x)
    go (x, y) = go' x ++ '=' : go' y
    go' = concatMap encodeUrlChar

-- | Taken straight from web-encodings; reimplemented here to avoid extra
-- dependencies.
encodeUrlChar :: Char -> String
encodeUrlChar c
    -- List of unreserved characters per RFC 3986
    -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding
    | 'A' <= c && c <= 'Z' = [c]
    | 'a' <= c && c <= 'z' = [c]
    | '0' <= c && c <= '9' = [c]
encodeUrlChar c@'-' = [c]
encodeUrlChar c@'_' = [c]
encodeUrlChar c@'.' = [c]
encodeUrlChar c@'~' = [c]
encodeUrlChar ' ' = "+"
encodeUrlChar y =
    let (a, c) = fromEnum y `divMod` 16
        b = a `mod` 16
        showHex' x
            | x < 10 = toEnum $ x + (fromEnum '0')
            | x < 16 = toEnum $ x - 10 + (fromEnum 'A')
            | otherwise = error $ "Invalid argument to showHex: " ++ show x
     in ['%', showHex' b, showHex' c]