packages feed

shakespeare 1.2.1.1 → 2.0.0

raw patch · 52 files changed

+6194/−97 lines, 52 filesdep +HUnitdep +aesondep +blaze-builderdep ~basenew-component:exe:servius

Dependencies added: HUnit, aeson, blaze-builder, blaze-html, blaze-markup, bytestring, directory, exceptions, http-types, shakespeare, transformers, wai, wai-app-static

Dependency ranges changed: base

Files

+ Text/Cassius.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+module Text.Cassius+    ( -- * Datatypes+      Css+    , CssUrl+      -- * Type class+    , ToCss (..)+      -- * Rendering+    , renderCss+    , renderCssUrl+      -- * Parsing+    , cassius+    , cassiusFile+    , cassiusFileDebug+    , cassiusFileReload+      -- * ToCss instances+      -- ** Color+    , Color (..)+    , colorRed+    , colorBlack+      -- ** Size+    , mkSize+    , AbsoluteUnit (..)+    , AbsoluteSize (..)+    , absoluteSize+    , EmSize (..)+    , ExSize (..)+    , PercentageSize (..)+    , percentageSize+    , PixelSize (..)+      -- * Internal+    , cassiusUsedIdentifiers+    ) where++import Text.Css+import Text.Shakespeare.Base+import Text.Shakespeare (VarType)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import qualified Data.Text.Lazy as TL+import Text.CssCommon+import Text.Lucius (lucius)+import qualified Text.Lucius+import Text.IndentToBrace (i2b)++cassius :: QuasiQuoter+cassius = QuasiQuoter { quoteExp = quoteExp lucius . i2b }++cassiusFile :: FilePath -> Q Exp+cassiusFile fp = do+#ifdef GHC_7_4+    qAddDependentFile fp+#endif+    contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp+    quoteExp cassius contents++cassiusFileDebug, cassiusFileReload :: FilePath -> Q Exp+cassiusFileDebug = cssFileDebug True [|Text.Lucius.parseTopLevels|] Text.Lucius.parseTopLevels+cassiusFileReload = cassiusFileDebug++-- | Determine which identifiers are used by the given template, useful for+-- creating systems like yesod devel.+cassiusUsedIdentifiers :: String -> [(Deref, VarType)]+cassiusUsedIdentifiers = cssUsedIdentifiers True Text.Lucius.parseTopLevels
+ Text/Coffee.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+-- | A Shakespearean module for CoffeeScript, introducing type-safe,+-- compile-time variable and url interpolation. It is exactly the same as+-- "Text.Julius", except that the template is first compiled to Javascript with+-- the system tool @coffee@.+--+-- To use this module, @coffee@ must be installed on your system.+--+-- @#{...}@ is the Shakespearean standard for variable interpolation, but+-- CoffeeScript already uses that sequence for string interpolation. Therefore,+-- Shakespearean interpolation is introduced with @%{...}@.+--+-- If you interpolate variables,+-- the template is first wrapped with a function containing javascript variables representing shakespeare variables,+-- then compiled with @coffee@,+-- and then the value of the variables are applied to the function.+-- This means that in production the template can be compiled+-- once at compile time and there will be no dependency in your production+-- system on @coffee@. +--+-- Your code:+--+-- >   b = 1+-- >   console.log(#{a} + b)+--+-- Function wrapper added to your coffeescript code:+--+-- > ((shakespeare_var_a) =>+-- >   b = 1+-- >   console.log(shakespeare_var_a + b)+-- > )+--+-- This is then compiled down to javascript, and the variables are applied:+--+-- > ;(function(shakespeare_var_a){+-- >   var b = 1;+-- >   console.log(shakespeare_var_a + b);+-- > })(#{a});+--+--+-- Further reading:+--+-- 1. Shakespearean templates: <http://www.yesodweb.com/book/templates>+--+-- 2. CoffeeScript: <http://coffeescript.org/>+module Text.Coffee+    ( -- * Functions+      -- ** Template-Reading Functions+      -- | These QuasiQuoter and Template Haskell methods return values of+      -- type @'JavascriptUrl' url@. See the Yesod book for details.+      coffee+    , coffeeFile+    , coffeeFileReload+    , coffeeFileDebug++#ifdef TEST_EXPORT+    , coffeeSettings+#endif+    ) where++import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Text.Shakespeare+import Text.Julius++coffeeSettings :: Q ShakespeareSettings+coffeeSettings = do+  jsettings <- javascriptSettings+  return $ jsettings { varChar = '%'+  , preConversion = Just PreConvert {+      preConvert = ReadProcess "coffee" ["-spb"]+    , preEscapeIgnoreBalanced = "'\"`"     -- don't insert backtacks for variable already inside strings or backticks.+    , preEscapeIgnoreLine = "#"            -- ignore commented lines+    , wrapInsertion = Just WrapInsertion { +        wrapInsertionIndent = Just "  "+      , wrapInsertionStartBegin = "("+      , wrapInsertionSeparator = ", "+      , wrapInsertionStartClose = ") =>"+      , wrapInsertionEnd = ""+      , wrapInsertionAddParens = False+      }+    }+  }++-- | Read inline, quasiquoted CoffeeScript.+coffee :: QuasiQuoter+coffee = QuasiQuoter { quoteExp = \s -> do+    rs <- coffeeSettings+    quoteExp (shakespeare rs) s+    }++-- | Read in a CoffeeScript template file. This function reads the file once, at+-- compile time.+coffeeFile :: FilePath -> Q Exp+coffeeFile fp = do+    rs <- coffeeSettings+    shakespeareFile rs fp++-- | Read in a CoffeeScript template file. This impure function uses+-- unsafePerformIO to re-read the file on every call, allowing for rapid+-- iteration.+coffeeFileReload :: FilePath -> Q Exp+coffeeFileReload fp = do+    rs <- coffeeSettings+    shakespeareFileReload rs fp++-- | Deprecated synonym for 'coffeeFileReload'+coffeeFileDebug :: FilePath -> Q Exp+coffeeFileDebug = coffeeFileReload+{-# DEPRECATED coffeeFileDebug "Please use coffeeFileReload instead." #-}
+ Text/Css.hs view
@@ -0,0 +1,537 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls #-}+module Text.Css where++import Data.List (intersperse, intercalate)+import Data.Text.Lazy.Builder (Builder, singleton, toLazyText, fromLazyText, fromString)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import Data.Monoid (Monoid, mconcat, mappend, mempty)+import Data.Text (Text)+import qualified Data.Text as T+import Language.Haskell.TH.Syntax+import System.IO.Unsafe (unsafePerformIO)+import Text.ParserCombinators.Parsec (Parser, parse)+import Text.Shakespeare.Base hiding (Scope)+import Language.Haskell.TH+import Control.Applicative ((<$>), (<*>))+import Control.Arrow ((***), second)+import Text.IndentToBrace (i2b)+import Data.Functor.Identity (runIdentity)+import Text.Shakespeare (VarType (..))++#if MIN_VERSION_base(4,5,0)+import Data.Monoid ((<>))+#else+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+{-# INLINE (<>) #-}+#endif++type CssUrl url = (url -> [(T.Text, T.Text)] -> T.Text) -> Css++type DList a = [a] -> [a]++-- FIXME great use case for data kinds+data Resolved+data Unresolved++type family Selector a+type instance Selector Resolved = Builder+type instance Selector Unresolved = [Contents]++type family ChildBlocks a+type instance ChildBlocks Resolved = ()+type instance ChildBlocks Unresolved = [(HasLeadingSpace, Block Unresolved)]++type HasLeadingSpace = Bool++type family Str a+type instance Str Resolved = Builder+type instance Str Unresolved = Contents++type family Mixins a+type instance Mixins Resolved = ()+type instance Mixins Unresolved = [Deref]++data Block a = Block+    { blockSelector :: !(Selector a)+    , blockAttrs :: ![Attr a]+    , blockBlocks :: !(ChildBlocks a)+    , blockMixins :: !(Mixins a)+    }++data Mixin = Mixin+    { mixinAttrs :: ![Attr Resolved]+    , mixinBlocks :: ![Block Resolved]+    }+instance Monoid Mixin where+    mempty = Mixin mempty mempty+    mappend (Mixin a x) (Mixin b y) = Mixin (a ++ b) (x ++ y)++data TopLevel a where+    TopBlock   :: !(Block a) -> TopLevel a+    TopAtBlock :: !String -- name e.g., media+               -> !(Str a) -- selector+               -> ![Block a]+               -> TopLevel a+    TopAtDecl  :: !String -> !(Str a) -> TopLevel a+    TopVar     :: !String -> !String -> TopLevel Unresolved++data Attr a = Attr+    { attrKey :: !(Str a)+    , attrVal :: !(Str a)+    }++data Css = CssWhitespace ![TopLevel Resolved]+         | CssNoWhitespace ![TopLevel Resolved]++data Content = ContentRaw String+             | ContentVar Deref+             | ContentUrl Deref+             | ContentUrlParam Deref+             | ContentMixin Deref+    deriving (Show, Eq)++type Contents = [Content]++data CDData url = CDPlain Builder+                | CDUrl url+                | CDUrlParam (url, [(Text, Text)])+                | CDMixin Mixin++pack :: String -> Text+pack = T.pack+#if !MIN_VERSION_text(0, 11, 2)+{-# NOINLINE pack #-}+#endif++fromText :: Text -> Builder+fromText = TLB.fromText+{-# NOINLINE fromText #-}++class ToCss a where+    toCss :: a -> Builder++instance ToCss [Char] where toCss = fromLazyText . TL.pack+instance ToCss Text where toCss = fromText+instance ToCss TL.Text where toCss = fromLazyText++-- | Determine which identifiers are used by the given template, useful for+-- creating systems like yesod devel.+cssUsedIdentifiers :: Bool -- ^ perform the indent-to-brace conversion+                   -> Parser [TopLevel Unresolved]+                   -> String+                   -> [(Deref, VarType)]+cssUsedIdentifiers toi2b parseBlocks s' =+    concat $ runIdentity $ mapM (getVars scope0) contents+  where+    s = if toi2b then i2b s' else s'+    a = either (error . show) id $ parse parseBlocks s s+    (scope0, contents) = go a++    go :: [TopLevel Unresolved]+       -> (Scope, [Content])+    go [] = ([], [])+    go (TopAtDecl dec cs:rest) =+        (scope, rest'')+      where+        (scope, rest') = go rest+        rest'' =+            ContentRaw ('@' : dec ++ " ")+          : cs+         ++ ContentRaw ";"+          : rest'+    go (TopAtBlock _ _ blocks:rest) =+        (scope1 ++ scope2, rest1 ++ rest2)+      where+        (scope1, rest1) = go (map TopBlock blocks)+        (scope2, rest2) = go rest+    go (TopBlock (Block x y z mixins):rest) =+        (scope1 ++ scope2, rest0 ++ rest1 ++ rest2 ++ restm)+      where+        rest0 = intercalate [ContentRaw ","] x ++ concatMap go' y+        (scope1, rest1) = go (map (TopBlock . snd) z)+        (scope2, rest2) = go rest+        restm = map ContentMixin mixins+    go (TopVar k v:rest) =+        ((k, v):scope, rest')+      where+        (scope, rest') = go rest+    go' (Attr k v) = k ++ v++cssFileDebug :: Bool -- ^ perform the indent-to-brace conversion+             -> Q Exp+             -> Parser [TopLevel Unresolved]+             -> FilePath+             -> Q Exp+cssFileDebug toi2b parseBlocks' parseBlocks fp = do+    s <- fmap TL.unpack $ qRunIO $ readUtf8File fp+#ifdef GHC_7_4+    qAddDependentFile fp+#endif+    let vs = cssUsedIdentifiers toi2b parseBlocks s+    c <- mapM vtToExp vs+    cr <- [|cssRuntime toi2b|]+    parseBlocks'' <- parseBlocks'+    return $ cr `AppE` parseBlocks'' `AppE` (LitE $ StringL fp) `AppE` ListE c++combineSelectors :: HasLeadingSpace+                 -> [Contents]+                 -> [Contents]+                 -> [Contents]+combineSelectors hsl a b = do+    a' <- a+    b' <- b+    return $ a' ++ addSpace b'+  where+    addSpace+        | hsl = (ContentRaw " " :)+        | otherwise = id++blockRuntime :: [(Deref, CDData url)]+             -> (url -> [(Text, Text)] -> Text)+             -> Block Unresolved+             -> Either String (DList (Block Resolved))+-- FIXME share code with blockToCss+blockRuntime cd render' (Block x attrs z mixinsDerefs) = do+    mixins <- mapM getMixin mixinsDerefs+    x' <- mapM go' $ intercalate [ContentRaw ","] x+    attrs' <- mapM resolveAttr attrs+    z' <- mapM (subGo x) z -- FIXME use difflists again+    Right $ \rest -> Block+        { blockSelector = mconcat x'+        , blockAttrs    = concat $ attrs' : map mixinAttrs mixins+        , blockBlocks   = ()+        , blockMixins   = ()+        } : foldr ($) rest z'+    {-+    (:) (Css' (mconcat $ map go' $ intercalate [ContentRaw "," ] x) (map go'' y))+    . foldr (.) id (map (subGo x) z)+    -}+  where+    go' = contentToBuilderRT cd render'++    getMixin d =+        case lookup d cd of+            Nothing -> Left $ "Mixin not found: " ++ show d+            Just (CDMixin m) -> Right m+            Just _ -> Left $ "For " ++ show d ++ ", expected Mixin"++    resolveAttr :: Attr Unresolved -> Either String (Attr Resolved)+    resolveAttr (Attr k v) = Attr <$> (mconcat <$> mapM go' k) <*> (mconcat <$> mapM go' v)++    subGo :: [Contents] -- ^ parent selectors+          -> (HasLeadingSpace, Block Unresolved)+          -> Either String (DList (Block Resolved))+    subGo x' (hls, Block a b c d) =+        blockRuntime cd render' (Block a' b c d)+      where+        a' = combineSelectors hls x' a++contentToBuilderRT :: [(Deref, CDData url)]+                   -> (url -> [(Text, Text)] -> Text)+                   -> Content+                   -> Either String Builder+contentToBuilderRT _ _ (ContentRaw s) = Right $ fromText $ pack s+contentToBuilderRT cd _ (ContentVar d) =+    case lookup d cd of+        Just (CDPlain s) -> Right s+        _ -> Left $ show d ++ ": expected CDPlain"+contentToBuilderRT cd render' (ContentUrl d) =+    case lookup d cd of+        Just (CDUrl u) -> Right $ fromText $ render' u []+        _ -> Left $ show d ++ ": expected CDUrl"+contentToBuilderRT cd render' (ContentUrlParam d) =+    case lookup d cd of+        Just (CDUrlParam (u, p)) ->+            Right $ fromText $ render' u p+        _ -> Left $ show d ++ ": expected CDUrlParam"+contentToBuilderRT _ _ ContentMixin{} = Left "contentToBuilderRT ContentMixin"++cssRuntime :: Bool -- ^ i2b?+           -> Parser [TopLevel Unresolved]+           -> FilePath+           -> [(Deref, CDData url)]+           -> (url -> [(Text, Text)] -> Text)+           -> Css+cssRuntime toi2b parseBlocks fp cd render' = unsafePerformIO $ do+    s' <- fmap TL.unpack $ qRunIO $ readUtf8File fp+    let s = if toi2b then i2b s' else s'+    let a = either (error . show) id $ parse parseBlocks s s+    return $ CssWhitespace $ goTop [] a+  where+    goTop :: [(String, String)] -- ^ scope+          -> [TopLevel Unresolved]+          -> [TopLevel Resolved]+    goTop _ [] = []+    goTop scope (TopAtDecl dec cs':rest) =+        TopAtDecl dec cs : goTop scope rest+      where+        cs = either error mconcat $ mapM (contentToBuilderRT cd render') cs'+    goTop scope (TopBlock b:rest) =+        map TopBlock (either error ($[]) $ blockRuntime (addScope scope) render' b) +++        goTop scope rest+    goTop scope (TopAtBlock name s' b:rest) =+        TopAtBlock name s (foldr (either error id . blockRuntime (addScope scope) render') [] b) :+        goTop scope rest+      where+        s = either error mconcat $ mapM (contentToBuilderRT cd render') s'+    goTop scope (TopVar k v:rest) = goTop ((k, v):scope) rest++    addScope scope = map (DerefIdent . Ident *** CDPlain . fromString) scope ++ cd++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 = [|CDPlain . toCss|]+    c VTUrl = [|CDUrl|]+    c VTUrlParam = [|CDUrlParam|]+    c VTMixin = [|CDMixin|]++getVars :: Monad m => [(String, String)] -> Content -> m [(Deref, VarType)]+getVars _ ContentRaw{} = return []+getVars scope (ContentVar d) =+    case lookupD d scope of+        Just _ -> return []+        Nothing -> return [(d, VTPlain)]+getVars scope (ContentUrl d) =+    case lookupD d scope of+        Nothing -> return [(d, VTUrl)]+        Just s -> fail $ "Expected URL for " ++ s+getVars scope (ContentUrlParam d) =+    case lookupD d scope of+        Nothing -> return [(d, VTUrlParam)]+        Just s -> fail $ "Expected URLParam for " ++ s+getVars scope (ContentMixin d) =+    case lookupD d scope of+        Nothing -> return [(d, VTMixin)]+        Just s -> fail $ "Expected Mixin for " ++ s++lookupD :: Deref -> [(String, b)] -> Maybe String+lookupD (DerefIdent (Ident s)) scope =+    case lookup s scope of+        Nothing -> Nothing+        Just _ -> Just s+lookupD _ _ = Nothing++compressTopLevel :: TopLevel Unresolved+                 -> TopLevel Unresolved+compressTopLevel (TopBlock b) = TopBlock $ compressBlock b+compressTopLevel (TopAtBlock name s b) = TopAtBlock name s $ map compressBlock b+compressTopLevel x@TopAtDecl{} = x+compressTopLevel x@TopVar{} = x++compressBlock :: Block Unresolved+              -> Block Unresolved+compressBlock (Block x y blocks mixins) =+    Block (map cc x) (map go y) (map (second compressBlock) blocks) mixins+  where+    go (Attr k v) = Attr (cc k) (cc v)+    cc [] = []+    cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c+    cc (a:b) = a : cc b++blockToMixin :: Name+             -> Scope+             -> Block Unresolved+             -> Q Exp+blockToMixin r scope (Block _sel props subblocks mixins) =+    [|Mixin+        { mixinAttrs    = concat+                        $ $(listE $ map go props)+                        : map mixinAttrs $mixinsE+        -- FIXME too many complications to implement sublocks for now...+        , mixinBlocks   = [] -- foldr (.) id $(listE $ map subGo subblocks) []+        }|]+      {-+      . foldr (.) id $(listE $ map subGo subblocks)+      . (concatMap mixinBlocks $mixinsE ++)+    |]+    -}+  where+    mixinsE = return $ ListE $ map (derefToExp []) mixins+    go (Attr x y) = conE 'Attr+        `appE` (contentsToBuilder r scope x)+        `appE` (contentsToBuilder r scope y)+    subGo (Block sel' b c d) = blockToCss r scope $ Block sel' b c d++blockToCss :: Name+           -> Scope+           -> Block Unresolved+           -> Q Exp+blockToCss r scope (Block sel props subblocks mixins) =+    [|((Block+        { blockSelector = $(selectorToBuilder r scope sel)+        , blockAttrs    = concat+                        $ $(listE $ map go props)+                        : map mixinAttrs $mixinsE+        , blockBlocks   = ()+        , blockMixins   = ()+        } :: Block Resolved):)+      . foldr (.) id $(listE $ map subGo subblocks)+      . (concatMap mixinBlocks $mixinsE ++)+    |]+  where+    mixinsE = return $ ListE $ map (derefToExp []) mixins+    go (Attr x y) = conE 'Attr+        `appE` (contentsToBuilder r scope x)+        `appE` (contentsToBuilder r scope y)+    subGo (hls, Block sel' b c d) =+        blockToCss r scope $ Block sel'' b c d+      where+        sel'' = combineSelectors hls sel sel'++selectorToBuilder :: Name -> Scope -> [Contents] -> Q Exp+selectorToBuilder r scope sels =+    contentsToBuilder r scope $ intercalate [ContentRaw ","] sels++contentsToBuilder :: Name -> Scope -> [Content] -> Q Exp+contentsToBuilder r scope contents =+    appE [|mconcat|] $ listE $ map (contentToBuilder r scope) contents++contentToBuilder :: Name -> Scope -> Content -> Q Exp+contentToBuilder _ _ (ContentRaw x) =+    [|fromText . pack|] `appE` litE (StringL x)+contentToBuilder _ scope (ContentVar d) =+    case d of+        DerefIdent (Ident s)+            | Just val <- lookup s scope -> [|fromText . pack|] `appE` litE (StringL val)+        _ -> [|toCss|] `appE` return (derefToExp [] d)+contentToBuilder r _ (ContentUrl u) =+    [|fromText|] `appE`+        (varE r `appE` return (derefToExp [] u) `appE` listE [])+contentToBuilder r _ (ContentUrlParam u) =+    [|fromText|] `appE`+        ([|uncurry|] `appE` varE r `appE` return (derefToExp [] u))+contentToBuilder _ _ ContentMixin{} = error "contentToBuilder on ContentMixin"++type Scope = [(String, String)]++topLevelsToCassius :: [TopLevel Unresolved]+                   -> Q Exp+topLevelsToCassius a = do+    r <- newName "_render"+    lamE [varP r] $ appE [|CssNoWhitespace . foldr ($) []|] $ fmap ListE $ go r [] a+  where+    go _ _ [] = return []+    go r scope (TopBlock b:rest) = do+        e <- [|(++) $ map TopBlock ($(blockToCss r scope b) [])|]+        es <- go r scope rest+        return $ e : es+    go r scope (TopAtBlock name s b:rest) = do+        let s' = contentsToBuilder r scope s+        e <- [|(:) $ TopAtBlock $(lift name) $(s') $(blocksToCassius r scope b)|]+        es <- go r scope rest+        return $ e : es+    go r scope (TopAtDecl dec cs:rest) = do+        e <- [|(:) $ TopAtDecl $(lift dec) $(contentsToBuilder r scope cs)|]+        es <- go r scope rest+        return $ e : es+    go r scope (TopVar k v:rest) = go r ((k, v) : scope) rest++blocksToCassius :: Name+                -> Scope+                -> [Block Unresolved]+                -> Q Exp+blocksToCassius r scope a = do+    appE [|foldr ($) []|] $ listE $ map (blockToCss r scope) a++renderCss :: Css -> TL.Text+renderCss css =+    toLazyText $ mconcat $ map go tops+  where+    (haveWhiteSpace, tops) =+        case css of+            CssWhitespace x -> (True, x)+            CssNoWhitespace x -> (False, x)+    go (TopBlock x) = renderBlock haveWhiteSpace mempty x+    go (TopAtBlock name s x) =+        fromText (pack $ concat ["@", name, " "]) `mappend`+        s `mappend`+        startBlock `mappend`+        foldr mappend endBlock (map (renderBlock haveWhiteSpace (fromString "    ")) x)+    go (TopAtDecl dec cs) = fromText (pack $ concat ["@", dec, " "]) `mappend`+                      cs `mappend`+                      endDecl++    startBlock+        | haveWhiteSpace = fromString " {\n"+        | otherwise = singleton '{'++    endBlock+        | haveWhiteSpace = fromString "}\n"+        | otherwise = singleton '}'++    endDecl+        | haveWhiteSpace = fromString ";\n"+        | otherwise = singleton ';'++renderBlock :: Bool -- ^ have whitespace?+            -> Builder -- ^ indentation+            -> Block Resolved+            -> Builder+renderBlock haveWhiteSpace indent (Block sel attrs () ())+    | null attrs = mempty+    | otherwise = startSelect+               <> sel+               <> startBlock+               <> mconcat (intersperse endDecl $ map renderAttr attrs)+               <> endBlock+  where+    renderAttr (Attr k v) = startDecl <> k <> colon <> v++    colon+        | haveWhiteSpace = fromString ": "+        | otherwise = singleton ':'++    startSelect+        | haveWhiteSpace = indent+        | otherwise = mempty++    startBlock+        | haveWhiteSpace = fromString " {\n"+        | otherwise = singleton '{'++    endBlock+        | haveWhiteSpace = fromString ";\n" `mappend` indent `mappend` fromString "}\n"+        | otherwise = singleton '}'++    startDecl+        | haveWhiteSpace = indent `mappend` fromString "    "+        | otherwise = mempty++    endDecl+        | haveWhiteSpace = fromString ";\n"+        | otherwise = singleton ';'++instance Lift Mixin where+    lift (Mixin a b) = [|Mixin a b|]+instance Lift (Attr Unresolved) where+    lift (Attr k v) = [|Attr k v :: Attr Unresolved |]+instance Lift (Attr Resolved) where+    lift (Attr k v) = [|Attr $(liftBuilder k) $(liftBuilder v) :: Attr Resolved |]++liftBuilder :: Builder -> Q Exp+liftBuilder b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|]++instance Lift Content where+    lift (ContentRaw s) = [|ContentRaw s|]+    lift (ContentVar d) = [|ContentVar d|]+    lift (ContentUrl d) = [|ContentUrl d|]+    lift (ContentUrlParam d) = [|ContentUrlParam d|]+    lift (ContentMixin m) = [|ContentMixin m|]+instance Lift (Block Unresolved) where+    lift (Block a b c d) = [|Block a b c d|]+instance Lift (Block Resolved) where+    lift (Block a b () ()) = [|Block $(liftBuilder a) b () ()|]
+ Text/CssCommon.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+module Text.CssCommon where++import Text.Css+import Text.MkSizeType+import qualified Data.Text as TS+import Text.Printf (printf)+import Language.Haskell.TH+import Data.Word (Word8)+import Data.Bits+import Data.Text.Lazy.Builder (fromLazyText)+import qualified Data.Text.Lazy as TL++renderCssUrl :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> CssUrl url -> TL.Text+renderCssUrl r s = renderCss $ s r++data Color = Color Word8 Word8 Word8+    deriving Show+instance ToCss Color where+    toCss (Color r g b) =+        let (r1, r2) = toHex r+            (g1, g2) = toHex g+            (b1, b2) = toHex b+         in fromText $ TS.pack $ '#' :+            if r1 == r2 && g1 == g2 && b1 == b2+                then [r1, g1, b1]+                else [r1, r2, g1, g2, b1, b2]+      where+        toHex :: Word8 -> (Char, Char)+        toHex x = (toChar $ shiftR x 4, toChar $ x .&. 15)+        toChar :: Word8 -> Char+        toChar c+            | c < 10 = mkChar c 0 '0'+            | otherwise = mkChar c 10 'A'+        mkChar :: Word8 -> Word8 -> Char -> Char+        mkChar a b' c =+            toEnum $ fromIntegral $ a - b' + fromIntegral (fromEnum c)++colorRed :: Color+colorRed = Color 255 0 0++colorBlack :: Color+colorBlack = Color 0 0 0++-- CSS size wrappers++-- | Create a CSS size, e.g. $(mkSize "100px").+mkSize :: String -> ExpQ+mkSize s = appE nameE valueE+  where [(value, unit)] = reads s :: [(Double, String)]+        absoluteSizeE = varE $ mkName "absoluteSize"+        nameE = case unit of+          "cm" -> appE absoluteSizeE (conE $ mkName "Centimeter")+          "em" -> conE $ mkName "EmSize"+          "ex" -> conE $ mkName "ExSize"+          "in" -> appE absoluteSizeE (conE $ mkName "Inch")+          "mm" -> appE absoluteSizeE (conE $ mkName "Millimeter")+          "pc" -> appE absoluteSizeE (conE $ mkName "Pica")+          "pt" -> appE absoluteSizeE (conE $ mkName "Point")+          "px" -> conE $ mkName "PixelSize"+          "%" -> varE $ mkName "percentageSize"+          _ -> error $ "In mkSize, invalid unit: " ++ unit+        valueE = litE $ rationalL (toRational value)++-- | Absolute size units.+data AbsoluteUnit = Centimeter+                  | Inch+                  | Millimeter+                  | Pica+                  | Point+                  deriving (Eq, Show)++-- | Not intended for direct use, see 'mkSize'.+data AbsoluteSize = AbsoluteSize+    { absoluteSizeUnit :: AbsoluteUnit -- ^ Units used for text formatting.+    , absoluteSizeValue :: Rational -- ^ Normalized value in centimeters.+    }++-- | Absolute size unit convertion rate to centimeters.+absoluteUnitRate :: AbsoluteUnit -> Rational+absoluteUnitRate Centimeter = 1+absoluteUnitRate Inch = 2.54+absoluteUnitRate Millimeter = 0.1+absoluteUnitRate Pica = 12 * absoluteUnitRate Point+absoluteUnitRate Point = 1 / 72 * absoluteUnitRate Inch++-- | Constructs 'AbsoluteSize'. Not intended for direct use, see 'mkSize'.+absoluteSize :: AbsoluteUnit -> Rational -> AbsoluteSize+absoluteSize unit value = AbsoluteSize unit (value * absoluteUnitRate unit)++instance Show AbsoluteSize where+  show (AbsoluteSize unit value') = printf "%f" value ++ suffix+    where value = fromRational (value' / absoluteUnitRate unit) :: Double+          suffix = case unit of+            Centimeter -> "cm"+            Inch -> "in"+            Millimeter -> "mm"+            Pica -> "pc"+            Point -> "pt"++instance Eq AbsoluteSize where+  (AbsoluteSize _ v1) == (AbsoluteSize _ v2) = v1 == v2++instance Ord AbsoluteSize where+  compare (AbsoluteSize _ v1) (AbsoluteSize _ v2) = compare v1 v2++instance Num AbsoluteSize where+  (AbsoluteSize u1 v1) + (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 + v2)+  (AbsoluteSize u1 v1) * (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 * v2)+  (AbsoluteSize u1 v1) - (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 - v2)+  abs (AbsoluteSize u v) = AbsoluteSize u (abs v)+  signum (AbsoluteSize u v) = AbsoluteSize u (abs v)+  fromInteger x = AbsoluteSize Centimeter (fromInteger x)++instance Fractional AbsoluteSize where+  (AbsoluteSize u1 v1) / (AbsoluteSize _ v2) = AbsoluteSize u1 (v1 / v2)+  fromRational x = AbsoluteSize Centimeter (fromRational x)++instance ToCss AbsoluteSize where+  toCss = fromText . TS.pack . show++-- | Not intended for direct use, see 'mkSize'.+data PercentageSize = PercentageSize+    { percentageSizeValue :: Rational -- ^ Normalized value, 1 == 100%.+    }+                    deriving (Eq, Ord)++-- | Constructs 'PercentageSize'. Not intended for direct use, see 'mkSize'.+percentageSize :: Rational -> PercentageSize+percentageSize value = PercentageSize (value / 100)++instance Show PercentageSize where+  show (PercentageSize value') = printf "%f" value ++ "%"+    where value = fromRational (value' * 100) :: Double++instance Num PercentageSize where+  (PercentageSize v1) + (PercentageSize v2) = PercentageSize (v1 + v2)+  (PercentageSize v1) * (PercentageSize v2) = PercentageSize (v1 * v2)+  (PercentageSize v1) - (PercentageSize v2) = PercentageSize (v1 - v2)+  abs (PercentageSize v) = PercentageSize (abs v)+  signum (PercentageSize v) = PercentageSize (abs v)+  fromInteger x = PercentageSize (fromInteger x)++instance Fractional PercentageSize where+  (PercentageSize v1) / (PercentageSize v2) = PercentageSize (v1 / v2)+  fromRational x = PercentageSize (fromRational x)++instance ToCss PercentageSize where+  toCss = fromText . TS.pack . show++-- | Converts number and unit suffix to CSS format.+showSize :: Rational -> String -> String+showSize value' unit = printf "%f" value ++ unit+  where value = fromRational value' :: Double++mkSizeType "EmSize" "em"+mkSizeType "ExSize" "ex"+mkSizeType "PixelSize" "px"
+ Text/Hamlet.hs view
@@ -0,0 +1,587 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE PatternGuards #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+module Text.Hamlet+    ( -- * Plain HTML+      Html+    , shamlet+    , shamletFile+    , xshamlet+    , xshamletFile+      -- * Hamlet+    , HtmlUrl+    , hamlet+    , hamletFile+    , hamletFileReload+    , ihamletFileReload+    , xhamlet+    , xhamletFile+      -- * I18N Hamlet+    , HtmlUrlI18n+    , ihamlet+    , ihamletFile+      -- * Type classes+    , ToAttributes (..)+      -- * Internal, for making more+    , HamletSettings (..)+    , NewlineStyle (..)+    , hamletWithSettings+    , hamletFileWithSettings+    , defaultHamletSettings+    , xhtmlHamletSettings+    , Env (..)+    , HamletRules (..)+    , hamletRules+    , ihamletRules+    , htmlRules+    , CloseStyle (..)+      -- * Used by generated code+    , condH+    , maybeH+    , asHtmlUrl+    , attrsToHtml+    ) where++import Text.Shakespeare.Base+import Text.Hamlet.Parse+#if MIN_VERSION_template_haskell(2,9,0)+import Language.Haskell.TH.Syntax hiding (Module)+#else+import Language.Haskell.TH.Syntax+#endif+import Language.Haskell.TH.Quote+import Data.Char (isUpper, isDigit)+import Data.Maybe (fromMaybe)+import Data.Text (Text, pack)+import qualified Data.Text.Lazy as TL+import Text.Blaze.Html (Html, toHtml)+import Text.Blaze.Internal (preEscapedText)+import qualified Data.Foldable as F+import Control.Monad (mplus)+import Data.Monoid (mempty, mappend, mconcat)+import Control.Arrow ((***))+import Data.List (intercalate)++import Data.IORef+import qualified Data.Map as M+import System.IO.Unsafe (unsafePerformIO)+import Filesystem (getModified)+import Data.Time (UTCTime)+import Filesystem.Path.CurrentOS (decodeString)+import Text.Blaze.Html (preEscapedToHtml)++-- | Convert some value to a list of attribute pairs.+class ToAttributes a where+    toAttributes :: a -> [(Text, Text)]+instance ToAttributes (Text, Text) where+    toAttributes = return+instance ToAttributes (String, String) where+    toAttributes (k, v) = [(pack k, pack v)]+instance ToAttributes [(Text, Text)] where+    toAttributes = id+instance ToAttributes [(String, String)] where+    toAttributes = map (pack *** pack)++attrsToHtml :: [(Text, Text)] -> Html+attrsToHtml =+    foldr go mempty+  where+    go (k, v) rest =+        toHtml " "+        `mappend` preEscapedText k+        `mappend` preEscapedText (pack "=\"")+        `mappend` toHtml v+        `mappend` preEscapedText (pack "\"")+        `mappend` rest++type Render url = url -> [(Text, Text)] -> Text+type Translate msg = msg -> Html++-- | A function generating an 'Html' given a URL-rendering function.+type HtmlUrl url = Render url -> Html++-- | A function generating an 'Html' given a message translator and a URL rendering function.+type HtmlUrlI18n msg url = Translate msg -> Render url -> Html++docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp+docsToExp env hr scope docs = do+    exps <- mapM (docToExp env hr scope) docs+    case exps of+        [] -> [|return ()|]+        [x] -> return x+        _ -> return $ DoE $ map NoBindS exps++unIdent :: Ident -> String+unIdent (Ident s) = s++bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])+bindingPattern (BindAs i@(Ident s) b) = do+    name <- newName s+    (pattern, scope) <- bindingPattern b+    return (AsP name pattern, (i, VarE name):scope)+bindingPattern (BindVar i@(Ident s))+    | all isDigit s = do+        return (LitP $ IntegerL $ read s, [])+    | otherwise = do+        name <- newName s+        return (VarP name, [(i, VarE name)])+bindingPattern (BindTuple is) = do+    (patterns, scopes) <- fmap unzip $ mapM bindingPattern is+    return (TupP patterns, concat scopes)+bindingPattern (BindList is) = do+    (patterns, scopes) <- fmap unzip $ mapM bindingPattern is+    return (ListP patterns, concat scopes)+bindingPattern (BindConstr con is) = do+    (patterns, scopes) <- fmap unzip $ mapM bindingPattern is+    return (ConP (mkConName con) patterns, concat scopes)+bindingPattern (BindRecord con fields wild) = do+    let f (Ident field,b) =+           do (p,s) <- bindingPattern b+              return ((mkName field,p),s)+    (patterns, scopes) <- fmap unzip $ mapM f fields+    (patterns1, scopes1) <- if wild+       then bindWildFields con $ map fst fields+       else return ([],[])+    return (RecP (mkConName con) (patterns++patterns1), concat scopes ++ scopes1)++mkConName :: DataConstr -> Name+mkConName = mkName . conToStr++conToStr :: DataConstr -> String+conToStr (DCUnqualified (Ident x)) = x+conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x]++-- Wildcards bind all of the unbound fields to variables whose name+-- matches the field name.+--+-- For example: data R = C { f1, f2 :: Int }+-- C {..}           is equivalent to   C {f1=f1, f2=f2}+-- C {f1 = a, ..}   is equivalent to   C {f1=a,  f2=f2}+-- C {f2 = a, ..}   is equivalent to   C {f1=f1, f2=a}+bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])+bindWildFields conName fields = do+  fieldNames <- recordToFieldNames conName+  let available n     = nameBase n `notElem` map unIdent fields+  let remainingFields = filter available fieldNames+  let mkPat n = do+        e <- newName (nameBase n)+        return ((n,VarP e), (Ident (nameBase n), VarE e))+  fmap unzip $ mapM mkPat remainingFields++-- Important note! reify will fail if the record type is defined in the+-- same module as the reify is used. This means quasi-quoted Hamlet+-- literals will not be able to use wildcards to match record types+-- defined in the same module.+recordToFieldNames :: DataConstr -> Q [Name]+recordToFieldNames conStr = do+  -- use 'lookupValueName' instead of just using 'mkName' so we reify the+  -- data constructor and not the type constructor if their names match.+  Just conName                <- lookupValueName $ conToStr conStr+  DataConI _ _ typeName _     <- reify conName+  TyConI (DataD _ _ _ cons _) <- reify typeName+  [fields] <- return [fields | RecC name fields <- cons, name == conName]+  return [fieldName | (fieldName, _, _) <- fields]++docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp+docToExp env hr scope (DocForall list idents inside) = do+    let list' = derefToExp scope list+    (pat, extraScope) <- bindingPattern idents+    let scope' = extraScope ++ scope+    mh <- [|F.mapM_|]+    inside' <- docsToExp env hr scope' inside+    let lam = LamE [pat] inside'+    return $ mh `AppE` lam `AppE` list'+docToExp env hr scope (DocWith [] inside) = do+    inside' <- docsToExp env hr scope inside+    return $ inside'+docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do+    let deref' = derefToExp scope deref+    (pat, extraScope) <- bindingPattern idents+    let scope' = extraScope ++ scope+    inside' <- docToExp env hr scope' (DocWith dis inside)+    let lam = LamE [pat] inside'+    return $ lam `AppE` deref'+docToExp env hr scope (DocMaybe val idents inside mno) = do+    let val' = derefToExp scope val+    (pat, extraScope) <- bindingPattern idents+    let scope' = extraScope ++ scope+    inside' <- docsToExp env hr scope' inside+    let inside'' = LamE [pat] inside'+    ninside' <- case mno of+                    Nothing -> [|Nothing|]+                    Just no -> do+                        no' <- docsToExp env hr scope no+                        j <- [|Just|]+                        return $ j `AppE` no'+    mh <- [|maybeH|]+    return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'+docToExp env hr scope (DocCond conds final) = do+    conds' <- mapM go conds+    final' <- case final of+                Nothing -> [|Nothing|]+                Just f -> do+                    f' <- docsToExp env hr 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' = derefToExp ((specialOrIdent, VarE 'or):scope) d+        docs' <- docsToExp env hr scope docs+        return $ TupE [d', docs']+docToExp env hr scope (DocCase deref cases) = do+    let exp_ = derefToExp scope deref+    matches <- mapM toMatch cases+    return $ CaseE exp_ matches+  where+    toMatch :: (Binding, [Doc]) -> Q Match+    toMatch (idents, inside) = do+        (pat, extraScope) <- bindingPattern idents+        let scope' = extraScope ++ scope+        insideExp <- docsToExp env hr scope' inside+        return $ Match pat (NormalB insideExp) []+docToExp env hr v (DocContent c) = contentToExp env hr v c++contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp+contentToExp _ hr _ (ContentRaw s) = do+    os <- [|preEscapedText . pack|]+    let s' = LitE $ StringL s+    return $ hrFromHtml hr `AppE` (os `AppE` s')+contentToExp _ hr scope (ContentVar d) = do+    str <- [|toHtml|]+    return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)+contentToExp env hr scope (ContentUrl hasParams d) =+    case urlRender env of+        Nothing -> error "URL interpolation used, but no URL renderer provided"+        Just wrender -> wrender $ \render -> do+            let render' = return render+            ou <- if hasParams+                    then [|\(u, p) -> $(render') u p|]+                    else [|\u -> $(render') u []|]+            let d' = derefToExp scope d+            pet <- [|toHtml|]+            return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))+contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d+contentToExp env hr scope (ContentMsg d) =+    case msgRender env of+        Nothing -> error "Message interpolation used, but no message renderer provided"+        Just wrender -> wrender $ \render ->+            return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)+contentToExp _ hr scope (ContentAttrs d) = do+    html <- [|attrsToHtml . toAttributes|]+    return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d)++shamlet :: QuasiQuoter+shamlet = hamletWithSettings htmlRules defaultHamletSettings++xshamlet :: QuasiQuoter+xshamlet = hamletWithSettings htmlRules xhtmlHamletSettings++htmlRules :: Q HamletRules+htmlRules = do+    i <- [|id|]+    return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b)++hamlet :: QuasiQuoter+hamlet = hamletWithSettings hamletRules defaultHamletSettings++xhamlet :: QuasiQuoter+xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings++asHtmlUrl :: HtmlUrl url -> HtmlUrl url+asHtmlUrl = id++hamletRules :: Q HamletRules+hamletRules = do+    i <- [|id|]+    let ur f = do+            r <- newName "_render"+            let env = Env+                    { urlRender = Just ($ (VarE r))+                    , msgRender = Nothing+                    }+            h <- f env+            return $ LamE [VarP r] h+    return $ HamletRules i ur em+  where+    em (Env (Just urender) Nothing) e = do+        asHtmlUrl' <- [|asHtmlUrl|]+        urender $ \ur' -> return ((asHtmlUrl' `AppE` e) `AppE` ur')+    em _ _ = error "bad Env"++ihamlet :: QuasiQuoter+ihamlet = hamletWithSettings ihamletRules defaultHamletSettings++ihamletRules :: Q HamletRules+ihamletRules = do+    i <- [|id|]+    let ur f = do+            u <- newName "_urender"+            m <- newName "_mrender"+            let env = Env+                    { urlRender = Just ($ (VarE u))+                    , msgRender = Just ($ (VarE m))+                    }+            h <- f env+            return $ LamE [VarP m, VarP u] h+    return $ HamletRules i ur em+  where+    em (Env (Just urender) (Just mrender)) e =+          urender $ \ur' -> mrender $ \mr -> return (e `AppE` mr `AppE` ur')+    em _ _ = error "bad Env"++hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter+hamletWithSettings hr set =+    QuasiQuoter+        { quoteExp = hamletFromString hr set+        }++data HamletRules = HamletRules+    { hrFromHtml :: Exp+    , hrWithEnv :: (Env -> Q Exp) -> Q Exp+    , hrEmbed :: Env -> Exp -> Q Exp+    }++data Env = Env+    { urlRender :: Maybe ((Exp -> Q Exp) -> Q Exp)+    , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)+    }++hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp+hamletFromString qhr set s = do+    hr <- qhr+    hrWithEnv hr $ \env -> docsToExp env hr [] $ docFromString set s++docFromString :: HamletSettings -> String -> [Doc]+docFromString set s =+    case parseDoc set s of+        Error s' -> error s'+        Ok (_, d) -> d++hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp+hamletFileWithSettings qhr set fp = do+#ifdef GHC_7_4+    qAddDependentFile fp+#endif+    contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp+    hamletFromString qhr set contents++hamletFile :: FilePath -> Q Exp+hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings++hamletFileReload :: FilePath -> Q Exp+hamletFileReload = hamletFileReloadWithSettings runtimeRules defaultHamletSettings+  where runtimeRules = HamletRuntimeRules { hrrI18n = False }++ihamletFileReload :: FilePath -> Q Exp+ihamletFileReload = hamletFileReloadWithSettings runtimeRules defaultHamletSettings+  where runtimeRules = HamletRuntimeRules { hrrI18n = True }++xhamletFile :: FilePath -> Q Exp+xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings++shamletFile :: FilePath -> Q Exp+shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings++xshamletFile :: FilePath -> Q Exp+xshamletFile = hamletFileWithSettings htmlRules xhtmlHamletSettings++ihamletFile :: FilePath -> Q Exp+ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings++varName :: Scope -> String -> Exp+varName _ "" = error "Illegal empty varName"+varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope++strToExp :: String -> Exp+strToExp s@(c:_)+    | all isDigit s = LitE $ IntegerL $ read s+    | isUpper c = ConE $ mkName s+    | otherwise = VarE $ mkName s+strToExp "" = error "strToExp on empty string"++-- | 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 :: Monad m => [(Bool, m ())] -> Maybe (m ()) -> m ()+condH bms mm = fromMaybe (return ()) $ lookup True bms `mplus` mm++-- | Runs the second argument with the value in the first, if available.+-- Otherwise, runs the third argument, if available.+maybeH :: Monad m => Maybe v -> (v -> m ()) -> Maybe (m ()) -> m ()+maybeH mv f mm = fromMaybe (return ()) $ fmap f mv `mplus` mm+++type MTime = UTCTime+data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin | VTMsg | VTAttrs++type QueryParameters = [(Text, Text)]+type RenderUrl url   = (url -> QueryParameters -> Text)+type Shakespeare url = RenderUrl url -> Html+data VarExp msg url  = EPlain Html+                     | EUrl url+                     | EUrlParam (url, QueryParameters)+                     | EMixin (HtmlUrl url)+                     | EMixinI18n (HtmlUrlI18n msg url)+                     | EMsg msg++getVars :: Content -> [(Deref, VarType)]+getVars ContentRaw{}     = []+getVars (ContentVar d)   = [(d, VTPlain)]+getVars (ContentUrl False d) = [(d, VTUrl)]+getVars (ContentUrl True d) = [(d, VTUrlParam)]+getVars (ContentEmbed d) = [(d, VTMixin)]+getVars (ContentMsg d)   = [(d, VTMsg)]+getVars (ContentAttrs d) = [(d, VTAttrs)]++hamletUsedIdentifiers :: HamletSettings -> String -> [(Deref, VarType)]+hamletUsedIdentifiers settings =+    concatMap getVars . contentFromString settings+++data HamletRuntimeRules = HamletRuntimeRules {+                            hrrI18n :: Bool+                          }++hamletFileReloadWithSettings :: HamletRuntimeRules+                             -> HamletSettings -> FilePath -> Q Exp+hamletFileReloadWithSettings hrr settings fp = do+    s <- readFileQ fp+    let b = hamletUsedIdentifiers settings s+    c <- mapM vtToExp b+    rt <- if hrrI18n hrr+      then [|hamletRuntimeMsg settings fp|]+      else [|hamletRuntime settings fp|]+    return $ rt `AppE` ListE c+  where+    vtToExp :: (Deref, VarType) -> Q Exp+    vtToExp (d, vt) = do+        d' <- lift d+        c' <- toExp vt+        return $ TupE [d', c' `AppE` derefToExp [] d]+      where+        toExp = c+          where+            c :: VarType -> Q Exp+            c VTAttrs = [|EPlain . attrsToHtml . toAttributes|]+            c VTPlain = [|EPlain . toHtml|]+            c VTUrl = [|EUrl|]+            c VTUrlParam = [|EUrlParam|]+            c VTMixin = [|\r -> EMixin $ \c -> r c|]+            c VTMsg = [|EMsg|]++-- move to Shakespeare.Base?+readFileUtf8 :: FilePath -> IO String+readFileUtf8 fp = fmap TL.unpack $ readUtf8File fp++-- move to Shakespeare.Base?+readFileQ :: FilePath -> Q String+readFileQ fp = qRunIO $ readFileUtf8 fp++{-# NOINLINE reloadMapRef #-}+reloadMapRef :: IORef (M.Map FilePath (MTime, [Content]))+reloadMapRef = unsafePerformIO $ newIORef M.empty++lookupReloadMap :: FilePath -> IO (Maybe (MTime, [Content]))+lookupReloadMap fp = do+  reloads <- readIORef reloadMapRef+  return $ M.lookup fp reloads++insertReloadMap :: FilePath -> (MTime, [Content]) -> IO [Content]+insertReloadMap fp (mt, content) = atomicModifyIORef reloadMapRef+  (\reloadMap -> (M.insert fp (mt, content) reloadMap, content))++contentFromString :: HamletSettings -> String -> [Content]+contentFromString set = map justContent . docFromString set+  where+    unsupported msg = error $ "hamletFileReload does not support " ++ msg++    justContent :: Doc -> Content+    justContent (DocContent c) = c+    justContent DocForall{} = unsupported "$forall"+    justContent DocWith{} = unsupported "$with"+    justContent DocMaybe{} = unsupported "$maybe"+    justContent DocCase{} = unsupported "$case"+    justContent DocCond{} = unsupported "attribute conditionals"+++hamletRuntime :: HamletSettings+              -> FilePath+              -> [(Deref, VarExp msg url)]+              -> Shakespeare url+hamletRuntime settings fp cd render = unsafePerformIO $ do+    mtime <- qRunIO $ getModified $ decodeString fp+    mdata <- lookupReloadMap fp+    case mdata of+      Just (lastMtime, lastContents) ->+        if mtime == lastMtime then return $ go' lastContents+          else fmap go' $ newContent mtime+      Nothing -> fmap go' $ newContent mtime+  where+    newContent mtime = do+        s <- readFileUtf8 fp+        insertReloadMap fp (mtime, contentFromString settings s)++    go' = mconcat . map (runtimeContentToHtml cd render (error "I18n embed IMPOSSIBLE") handleMsgEx)+    handleMsgEx _ = error "i18n _{} encountered, but did not use ihamlet"++type RuntimeVars msg url = [(Deref, VarExp msg url)]+hamletRuntimeMsg :: HamletSettings+              -> FilePath+              -> RuntimeVars msg url+              -> HtmlUrlI18n msg url+hamletRuntimeMsg settings fp cd i18nRender render = unsafePerformIO $ do+    mtime <- qRunIO $ getModified $ decodeString fp+    mdata <- lookupReloadMap fp+    case mdata of+      Just (lastMtime, lastContents) ->+        if mtime == lastMtime then return $ go' lastContents+          else fmap go' $ newContent mtime+      Nothing -> fmap go' $ newContent mtime+  where+    newContent mtime = do+        s <- readFileUtf8 fp+        insertReloadMap fp (mtime, contentFromString settings s)++    go' = mconcat . map (runtimeContentToHtml cd render i18nRender handleMsg)+    handleMsg d = case lookup d cd of+            Just (EMsg s) -> i18nRender s+            _ -> error $ show d ++ ": expected EMsg for ContentMsg"++runtimeContentToHtml :: RuntimeVars msg url -> Render url -> Translate msg -> (Deref -> Html) -> Content -> Html+runtimeContentToHtml cd render i18nRender handleMsg = go+  where+    go :: Content -> Html+    go (ContentMsg d) = handleMsg d+    go (ContentRaw s) = preEscapedToHtml s+    go (ContentAttrs d) =+        case lookup d cd of+            Just (EPlain s) -> s+            _ -> error $ show d ++ ": expected EPlain for ContentAttrs"+    go (ContentVar d) =+        case lookup d cd of+            Just (EPlain s) -> s+            _ -> error $ show d ++ ": expected EPlain for ContentVar"+    go (ContentUrl False d) =+        case lookup d cd of+            Just (EUrl u) -> toHtml $ render u []+            _ -> error $ show d ++ ": expected EUrl"+    go (ContentUrl True d) =+        case lookup d cd of+            Just (EUrlParam (u, p)) ->+                toHtml $ render u p+            _ -> error $ show d ++ ": expected EUrlParam"+    go (ContentEmbed d) = case lookup d cd of+        Just (EMixin m) -> m render+        Just (EMixinI18n m) -> m i18nRender render+        _ -> error $ show d ++ ": expected EMixin"
+ Text/Hamlet/Parse.hs view
@@ -0,0 +1,732 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+module Text.Hamlet.Parse+    ( Result (..)+    , Content (..)+    , Doc (..)+    , parseDoc+    , HamletSettings (..)+    , defaultHamletSettings+    , xhtmlHamletSettings+    , CloseStyle (..)+    , Binding (..)+    , NewlineStyle (..)+    , specialOrIdent+    , DataConstr (..)+    , Module (..)+    )+    where++import Text.Shakespeare.Base+import Control.Applicative ((<$>), Applicative (..))+import Control.Monad+import Control.Arrow+import Data.Char (isUpper)+import Data.Data+import Text.ParserCombinators.Parsec hiding (Line)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Maybe (mapMaybe, fromMaybe, isNothing)+import Language.Haskell.TH.Syntax (Lift (..))++data Result v = Error String | Ok v+    deriving (Show, Eq, Read, Data, Typeable)+instance Monad Result where+    return = Ok+    Error s >>= _ = Error s+    Ok v >>= f = f v+    fail = Error+instance Functor Result where+    fmap = liftM+instance Applicative Result where+    pure = return+    (<*>) = ap++data Content = ContentRaw String+             | ContentVar Deref+             | ContentUrl Bool Deref -- ^ bool: does it include params?+             | ContentEmbed Deref+             | ContentMsg Deref+             | ContentAttrs Deref+    deriving (Show, Eq, Read, Data, Typeable)++data Line = LineForall Deref Binding+          | LineIf Deref+          | LineElseIf Deref+          | LineElse+          | LineWith [(Deref, Binding)]+          | LineMaybe Deref Binding+          | LineNothing+          | LineCase Deref+          | LineOf Binding+          | LineTag+            { _lineTagName :: String+            , _lineAttr :: [(Maybe Deref, String, Maybe [Content])]+            , _lineContent :: [Content]+            , _lineClasses :: [(Maybe Deref, [Content])]+            , _lineAttrs :: [Deref]+            , _lineNoNewline :: Bool+            }+          | LineContent [Content] Bool -- ^ True == avoid newlines+    deriving (Eq, Show, Read)++parseLines :: HamletSettings -> String -> Result (Maybe NewlineStyle, HamletSettings, [(Int, Line)])+parseLines set s =+    case parse parser s s of+        Left e -> Error $ show e+        Right x -> Ok x+  where+    parser = do+        mnewline <- parseNewline+        let set' =+                case mnewline of+                    Nothing ->+                        case hamletNewlines set of+                            DefaultNewlineStyle -> set { hamletNewlines = AlwaysNewlines }+                            _ -> set+                    Just n -> set { hamletNewlines = n }+        res <- many (parseLine set')+        return (mnewline, set', res)++    parseNewline =+        (try (many eol' >> spaceTabs >> string "$newline ") >> parseNewline' >>= \nl -> eol' >> return nl) <|>+        return Nothing+    parseNewline' =+        (try (string "always") >> return (Just AlwaysNewlines)) <|>+        (try (string "never") >> return (Just NoNewlines)) <|>+        (try (string "text") >> return (Just NewlinesText))++    eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ())++parseLine :: HamletSettings -> Parser (Int, Line)+parseLine set = do+    ss <- fmap sum $ many ((char ' ' >> return 1) <|>+                           (char '\t' >> fail "Tabs are not allowed in Hamlet indentation"))+    x <- doctype <|>+         doctypeDollar <|>+         comment <|>+         ssiInclude <|>+         htmlComment <|>+         doctypeRaw <|>+         backslash <|>+         controlIf <|>+         controlElseIf <|>+         (try (string "$else") >> spaceTabs >> eol >> return LineElse) <|>+         controlMaybe <|>+         (try (string "$nothing") >> spaceTabs >> eol >> return LineNothing) <|>+         controlForall <|>+         controlWith <|>+         controlCase <|>+         controlOf <|>+         angle <|>+         invalidDollar <|>+         (eol' >> return (LineContent [] True)) <|>+         (do+            (cs, avoidNewLines) <- content InContent+            isEof <- (eof >> return True) <|> return False+            if null cs && ss == 0 && isEof+                then fail "End of Hamlet template"+                else return $ LineContent cs avoidNewLines)+    return (ss, x)+  where+    eol' = (char '\n' >> return ()) <|> (string "\r\n" >> return ())+    eol = eof <|> eol'+    doctype = do+        try $ string "!!!" >> eol+        return $ LineContent [ContentRaw $ hamletDoctype set ++ "\n"] True+    doctypeDollar = do+        _ <- try $ string "$doctype "+        name <- many $ noneOf "\r\n"+        eol+        case lookup name $ hamletDoctypeNames set of+            Nothing -> fail $ "Unknown doctype name: " ++ name+            Just val -> return $ LineContent [ContentRaw $ val ++ "\n"] True++    doctypeRaw = do+        x <- try $ string "<!"+        y <- many $ noneOf "\r\n"+        eol+        return $ LineContent [ContentRaw $ concat [x, y, "\n"]] True++    invalidDollar = do+        _ <- char '$'+        fail "Received a command I did not understand. If you wanted a literal $, start the line with a backslash."+    comment = do+        _ <- try $ string "$#"+        _ <- many $ noneOf "\r\n"+        eol+        return $ LineContent [] True+    ssiInclude = do+        x <- try $ string "<!--#"+        y <- many $ noneOf "\r\n"+        eol+        return $ LineContent [ContentRaw $ x ++ y] False+    htmlComment = do+        _ <- try $ string "<!--"+        _ <- manyTill anyChar $ try $ string "-->"+        x <- many nonComments+        eol+        return $ LineContent [ContentRaw $ concat x] False {- FIXME -} -- FIXME handle variables?+    nonComments = (many1 $ noneOf "\r\n<") <|> (do+        _ <- char '<'+        (do+            _ <- try $ string "!--"+            _ <- manyTill anyChar $ try $ string "-->"+            return "") <|> return "<")+    backslash = do+        _ <- char '\\'+        (eol >> return (LineContent [ContentRaw "\n"] True))+            <|> (uncurry LineContent <$> content InContent)+    controlIf = do+        _ <- try $ string "$if"+        spaces+        x <- parseDeref+        _ <- spaceTabs+        eol+        return $ LineIf x+    controlElseIf = do+        _ <- try $ string "$elseif"+        spaces+        x <- parseDeref+        _ <- spaceTabs+        eol+        return $ LineElseIf x+    binding = do+        y <- identPattern+        spaces+        _ <- string "<-"+        spaces+        x <- parseDeref+        _ <- spaceTabs+        return (x,y)+    bindingSep = char ',' >> spaceTabs+    controlMaybe = do+        _ <- try $ string "$maybe"+        spaces+        (x,y) <- binding+        eol+        return $ LineMaybe x y+    controlForall = do+        _ <- try $ string "$forall"+        spaces+        (x,y) <- binding+        eol+        return $ LineForall x y+    controlWith = do+        _ <- try $ string "$with"+        spaces+        bindings <- (binding `sepBy` bindingSep) `endBy` eol+        return $ LineWith $ concat bindings -- concat because endBy returns a [[(Deref,Ident)]]+    controlCase = do+        _ <- try $ string "$case"+        spaces+        x <- parseDeref+        _ <- spaceTabs+        eol+        return $ LineCase x+    controlOf = do+        _   <- try $ string "$of"+        spaces+        x <- identPattern+        _   <- spaceTabs+        eol+        return $ LineOf x+    content cr = do+        x <- many $ content' cr+        case cr of+            InQuotes -> void $ char '"'+            NotInQuotes -> return ()+            NotInQuotesAttr -> return ()+            InContent -> eol+        return (cc $ map fst x, any snd x)+      where+        cc [] = []+        cc (ContentRaw a:ContentRaw b:c) = cc $ ContentRaw (a ++ b) : c+        cc (a:b) = a : cc b+    content' cr = contentHash <|> contentAt <|> contentCaret+                              <|> contentUnder+                              <|> contentReg' cr+    contentHash = do+        x <- parseHash+        case x of+            Left str -> return (ContentRaw str, null str)+            Right deref -> return (ContentVar deref, False)+    contentAt = do+        x <- parseAt+        return $ case x of+                    Left str -> (ContentRaw str, null str)+                    Right (s, y) -> (ContentUrl y s, False)+    contentCaret = do+        x <- parseCaret+        case x of+            Left str -> return (ContentRaw str, null str)+            Right deref -> return (ContentEmbed deref, False)+    contentUnder = do+        x <- parseUnder+        case x of+            Left str -> return (ContentRaw str, null str)+            Right deref -> return (ContentMsg deref, False)+    contentReg' x = (flip (,) False) <$> contentReg x+    contentReg InContent = (ContentRaw . return) <$> noneOf "#@^\r\n"+    contentReg NotInQuotes = (ContentRaw . return) <$> noneOf "@^#. \t\n\r>"+    contentReg NotInQuotesAttr = (ContentRaw . return) <$> noneOf "@^ \t\n\r>"+    contentReg InQuotes = (ContentRaw . return) <$> noneOf "#@^\"\n\r"+    tagAttribValue notInQuotes = do+        cr <- (char '"' >> return InQuotes) <|> return notInQuotes+        fst <$> content cr+    tagIdent = char '#' >> TagIdent <$> tagAttribValue NotInQuotes+    tagCond = do+        d <- between (char ':') (char ':') parseDeref+        tagClass (Just d) <|> tagAttrib (Just d)+    tagClass x = do+        clazz <- char '.' >> tagAttribValue NotInQuotes+        let hasHash (ContentRaw s) = any (== '#') s+            hasHash _ = False+        if any hasHash clazz+            then fail $ "Invalid class: " ++ show clazz ++ ". Did you want a space between a class and an ID?"+            else return (TagClass (x, clazz))+    tagAttrib cond = do+        s <- many1 $ noneOf " \t=\r\n><"+        v <- (char '=' >> Just <$> tagAttribValue NotInQuotesAttr) <|> return Nothing+        return $ TagAttrib (cond, s, v)++    tagAttrs = do+        _ <- char '*'+        d <- between (char '{') (char '}') parseDeref+        return $ TagAttribs d++    tag' = foldr tag'' ("div", [], [], [])+    tag'' (TagName s) (_, y, z, as) = (s, y, z, as)+    tag'' (TagIdent s) (x, y, z, as) = (x, (Nothing, "id", Just s) : y, z, as)+    tag'' (TagClass s) (x, y, z, as) = (x, y, s : z, as)+    tag'' (TagAttrib s) (x, y, z, as) = (x, s : y, z, as)+    tag'' (TagAttribs s) (x, y, z, as) = (x, y, z, s : as)++    ident :: Parser Ident+    ident = do+      i <- many1 (alphaNum <|> char '_' <|> char '\'')+      white+      return (Ident i)+     <?> "identifier"++    parens = between (char '(' >> white) (char ')' >> white)++    brackets = between (char '[' >> white) (char ']' >> white)++    braces = between (char '{' >> white) (char '}' >> white)++    comma = char ',' >> white++    atsign = char '@' >> white++    equals = char '=' >> white++    white = skipMany $ char ' '++    wildDots = string ".." >> white++    isVariable (Ident (x:_)) = not (isUpper x)+    isVariable (Ident []) = error "isVariable: bad identifier"++    isConstructor (Ident (x:_)) = isUpper x+    isConstructor (Ident []) = error "isConstructor: bad identifier"++    identPattern :: Parser Binding+    identPattern = gcon True <|> apat+      where+      apat = choice+        [ varpat+        , gcon False+        , parens tuplepat+        , brackets listpat+        ]++      varpat = do+        v <- try $ do v <- ident+                      guard (isVariable v)+                      return v+        option (BindVar v) $ do+          atsign+          b <- apat+          return (BindAs v b)+       <?> "variable"++      gcon :: Bool -> Parser Binding+      gcon allowArgs = do+        c <- try $ do c <- dataConstr+                      return c+        choice+          [ record c+          , fmap (BindConstr c) (guard allowArgs >> many apat)+          , return (BindConstr c [])+          ]+       <?> "constructor"++      dataConstr = do+        p <- dcPiece+        ps <- many dcPieces+        return $ toDataConstr p ps++      dcPiece = do+        x@(Ident y) <- ident+        guard $ isConstructor x+        return y++      dcPieces = do+        _ <- char '.'+        dcPiece++      toDataConstr x [] = DCUnqualified $ Ident x+      toDataConstr x (y:ys) =+          go (x:) y ys+        where+          go front next [] = DCQualified (Module $ front []) (Ident next)+          go front next (rest:rests) = go (front . (next:)) rest rests++      record c = braces $ do+        (fields, wild) <- option ([], False) $ go+        return (BindRecord c fields wild)+        where+        go = (wildDots >> return ([], True))+           <|> (do x         <- recordField+                   (xs,wild) <- option ([],False) (comma >> go)+                   return (x:xs,wild))++      recordField = do+        field <- ident+        p <- option (BindVar field) -- support punning+                    (equals >> identPattern)+        return (field,p)++      tuplepat = do+        xs <- identPattern `sepBy` comma+        return $ case xs of+          [x] -> x+          _   -> BindTuple xs++      listpat = BindList <$> identPattern `sepBy` comma++    angle = do+        _ <- char '<'+        name' <- many  $ noneOf " \t.#\r\n!>"+        let name = if null name' then "div" else name'+        xs <- many $ try ((many $ oneOf " \t\r\n") >>+              (tagIdent <|> tagCond <|> tagClass Nothing <|> tagAttrs <|> tagAttrib Nothing))+        _ <- many $ oneOf " \t\r\n"+        _ <- char '>'+        (c, avoidNewLines) <- content InContent+        let (tn, attr, classes, attrsd) = tag' $ TagName name : xs+        if '/' `elem` tn+          then fail "A tag name may not contain a slash. Perhaps you have a closing tag in your HTML."+          else return $ LineTag tn attr c classes attrsd avoidNewLines++data TagPiece = TagName String+              | TagIdent [Content]+              | TagClass (Maybe Deref, [Content])+              | TagAttrib (Maybe Deref, String, Maybe [Content])+              | TagAttribs Deref+    deriving Show++data ContentRule = InQuotes | NotInQuotes | NotInQuotesAttr | InContent++data Nest = Nest Line [Nest]++nestLines :: [(Int, Line)] -> [Nest]+nestLines [] = []+nestLines ((i, l):rest) =+    let (deeper, rest') = span (\(i', _) -> i' > i) rest+     in Nest l (nestLines deeper) : nestLines rest'++data Doc = DocForall Deref Binding [Doc]+         | DocWith [(Deref, Binding)] [Doc]+         | DocCond [(Deref, [Doc])] (Maybe [Doc])+         | DocMaybe Deref Binding [Doc] (Maybe [Doc])+         | DocCase Deref [(Binding, [Doc])]+         | DocContent Content+    deriving (Show, Eq, Read, Data, Typeable)++nestToDoc :: HamletSettings -> [Nest] -> Result [Doc]+nestToDoc _set [] = Ok []+nestToDoc set (Nest (LineForall d i) inside:rest) = do+    inside' <- nestToDoc set inside+    rest' <- nestToDoc set rest+    Ok $ DocForall d i inside' : rest'+nestToDoc set (Nest (LineWith dis) inside:rest) = do+    inside' <- nestToDoc set inside+    rest' <- nestToDoc set rest+    Ok $ DocWith dis inside' : rest'+nestToDoc set (Nest (LineIf d) inside:rest) = do+    inside' <- nestToDoc set inside+    (ifs, el, rest') <- parseConds set ((:) (d, inside')) rest+    rest'' <- nestToDoc set rest'+    Ok $ DocCond ifs el : rest''+nestToDoc set (Nest (LineMaybe d i) inside:rest) = do+    inside' <- nestToDoc set inside+    (nothing, rest') <-+        case rest of+            Nest LineNothing ninside:x -> do+                ninside' <- nestToDoc set ninside+                return (Just ninside', x)+            _ -> return (Nothing, rest)+    rest'' <- nestToDoc set rest'+    Ok $ DocMaybe d i inside' nothing : rest''+nestToDoc set (Nest (LineCase d) inside:rest) = do+    let getOf (Nest (LineOf x) insideC) = do+            insideC' <- nestToDoc set insideC+            Ok (x, insideC')+        getOf _ = Error "Inside a $case there may only be $of.  Use '$of _' for a wildcard."+    cases <- mapM getOf inside+    rest' <- nestToDoc set rest+    Ok $ DocCase d cases : rest'+nestToDoc set (Nest (LineTag tn attrs content classes attrsD avoidNewLine) inside:rest) = do+    let attrFix (x, y, z) = (x, y, [(Nothing, z)])+    let takeClass (a, "class", b) = Just (a, fromMaybe [] b)+        takeClass _ = Nothing+    let clazzes = classes ++ mapMaybe takeClass attrs+    let notClass (_, x, _) = x /= "class"+    let noclass = filter notClass attrs+    let attrs' =+            case clazzes of+              [] -> map attrFix noclass+              _ -> (testIncludeClazzes clazzes, "class", map (second Just) clazzes)+                       : map attrFix noclass+    let closeStyle =+            if not (null content) || not (null inside)+                then CloseSeparate+                else hamletCloseStyle set tn+    let end = case closeStyle of+                CloseSeparate ->+                    DocContent $ ContentRaw $ "</" ++ tn ++ ">"+                _ -> DocContent $ ContentRaw ""+        seal = case closeStyle of+                 CloseInside -> DocContent $ ContentRaw "/>"+                 _ -> DocContent $ ContentRaw ">"+        start = DocContent $ ContentRaw $ "<" ++ tn+        attrs'' = concatMap attrToContent attrs'+        newline' = DocContent $ ContentRaw+                 $ case hamletNewlines set of { AlwaysNewlines | not avoidNewLine -> "\n"; _ -> "" }+    inside' <- nestToDoc set inside+    rest' <- nestToDoc set rest+    Ok $ start+       : attrs''+      ++ map (DocContent . ContentAttrs) attrsD+      ++ seal+       : map DocContent content+      ++ inside'+      ++ end+       : newline'+       : rest'+nestToDoc set (Nest (LineContent content avoidNewLine) inside:rest) = do+    inside' <- nestToDoc set inside+    rest' <- nestToDoc set rest+    let newline' = DocContent $ ContentRaw+                   $ case hamletNewlines set of { NoNewlines -> ""; _ -> if nextIsContent && not avoidNewLine then "\n" else "" }+        nextIsContent =+            case (inside, rest) of+                ([], Nest LineContent{} _:_) -> True+                ([], Nest LineTag{} _:_) -> True+                _ -> False+    Ok $ map DocContent content ++ newline':inside' ++ rest'+nestToDoc _set (Nest (LineElseIf _) _:_) = Error "Unexpected elseif"+nestToDoc _set (Nest LineElse _:_) = Error "Unexpected else"+nestToDoc _set (Nest LineNothing _:_) = Error "Unexpected nothing"+nestToDoc _set (Nest (LineOf _) _:_) = Error "Unexpected 'of' (did you forget a $case?)"++compressDoc :: [Doc] -> [Doc]+compressDoc [] = []+compressDoc (DocForall d i doc:rest) =+    DocForall d i (compressDoc doc) : compressDoc rest+compressDoc (DocWith dis doc:rest) =+    DocWith dis (compressDoc doc) : compressDoc rest+compressDoc (DocMaybe d i doc mnothing:rest) =+    DocMaybe d i (compressDoc doc) (fmap compressDoc mnothing)+  : compressDoc rest+compressDoc (DocCond [(a, x)] Nothing:DocCond [(b, y)] Nothing:rest)+    | a == b = compressDoc $ DocCond [(a, x ++ y)] Nothing : rest+compressDoc (DocCond x y:rest) =+    DocCond (map (second compressDoc) x) (compressDoc `fmap` y)+    : compressDoc rest+compressDoc (DocCase d cs:rest) =+    DocCase d (map (second compressDoc) cs) : compressDoc rest+compressDoc (DocContent (ContentRaw ""):rest) = compressDoc rest+compressDoc ( DocContent (ContentRaw x)+            : DocContent (ContentRaw y)+            : rest+            ) = compressDoc $ (DocContent $ ContentRaw $ x ++ y) : rest+compressDoc (DocContent x:rest) = DocContent x : compressDoc rest++parseDoc :: HamletSettings -> String -> Result (Maybe NewlineStyle, [Doc])+parseDoc set s = do+    (mnl, set', ls) <- parseLines set s+    let notEmpty (_, LineContent [] _) = False+        notEmpty _ = True+    let ns = nestLines $ filter notEmpty ls+    ds <- nestToDoc set' ns+    return (mnl, compressDoc ds)++attrToContent :: (Maybe Deref, String, [(Maybe Deref, Maybe [Content])]) -> [Doc]+attrToContent (Just cond, k, v) =+    [DocCond [(cond, attrToContent (Nothing, k, v))] Nothing]+attrToContent (Nothing, k, []) = [DocContent $ ContentRaw $ ' ' : k]+attrToContent (Nothing, k, [(Nothing, Nothing)]) = [DocContent $ ContentRaw $ ' ' : k]+attrToContent (Nothing, k, [(Nothing, Just v)]) =+    DocContent (ContentRaw (' ' : k ++ "=\""))+  : map DocContent v+  ++ [DocContent $ ContentRaw "\""]+attrToContent (Nothing, k, v) = -- only for class+      DocContent (ContentRaw (' ' : k ++ "=\""))+    : concatMap go (init v)+    ++ go' (last v)+    ++ [DocContent $ ContentRaw "\""]+  where+    go (Nothing, x) = map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "]+    go (Just b, x) =+        [ DocCond+            [(b, map DocContent (fromMaybe [] x) ++ [DocContent $ ContentRaw " "])]+            Nothing+        ]+    go' (Nothing, x) = maybe [] (map DocContent) x+    go' (Just b, x) =+        [ DocCond+            [(b, maybe [] (map DocContent) x)]+            Nothing+        ]++-- | Settings for parsing of a hamlet document.+data HamletSettings = HamletSettings+    {+      -- | The value to replace a \"!!!\" with. Do not include the trailing+      -- newline.+      hamletDoctype :: String+      -- | Should we add newlines to the output, making it more human-readable?+      --  Useful for client-side debugging but may alter browser page layout.+    , hamletNewlines :: NewlineStyle+      -- | How a tag should be closed. Use this to switch between HTML, XHTML+      -- or even XML output.+    , hamletCloseStyle :: String -> CloseStyle+      -- | Mapping from short names in \"$doctype\" statements to full doctype.+    , hamletDoctypeNames :: [(String, String)]+    }++data NewlineStyle = NoNewlines -- ^ never add newlines+                  | NewlinesText -- ^ add newlines between consecutive text lines+                  | AlwaysNewlines -- ^ add newlines everywhere+                  | DefaultNewlineStyle+    deriving Show++instance Lift NewlineStyle where+    lift NoNewlines = [|NoNewlines|]+    lift NewlinesText = [|NewlinesText|]+    lift AlwaysNewlines = [|AlwaysNewlines|]+    lift DefaultNewlineStyle = [|DefaultNewlineStyle|]++instance Lift (String -> CloseStyle) where+    lift _ = [|\s -> htmlCloseStyle s|]++instance Lift HamletSettings where+    lift (HamletSettings a b c d) = [|HamletSettings $(lift a) $(lift b) $(lift c) $(lift d)|]+++htmlEmptyTags :: Set String+htmlEmptyTags = Set.fromAscList+    [ "area"+    , "base"+    , "basefont"+    , "br"+    , "col"+    , "frame"+    , "hr"+    , "img"+    , "input"+    , "isindex"+    , "link"+    , "meta"+    , "param"+    ]++-- | Defaults settings: HTML5 doctype and HTML-style empty tags.+defaultHamletSettings :: HamletSettings+defaultHamletSettings = HamletSettings "<!DOCTYPE html>" DefaultNewlineStyle htmlCloseStyle doctypeNames++xhtmlHamletSettings :: HamletSettings+xhtmlHamletSettings =+    HamletSettings doctype DefaultNewlineStyle xhtmlCloseStyle doctypeNames+  where+    doctype =+      "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " +++      "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"++htmlCloseStyle :: String -> CloseStyle+htmlCloseStyle s =+    if Set.member s htmlEmptyTags+        then NoClose+        else CloseSeparate++xhtmlCloseStyle :: String -> CloseStyle+xhtmlCloseStyle s =+    if Set.member s htmlEmptyTags+        then CloseInside+        else CloseSeparate++data CloseStyle = NoClose | CloseInside | CloseSeparate++parseConds :: HamletSettings+           -> ([(Deref, [Doc])] -> [(Deref, [Doc])])+           -> [Nest]+           -> Result ([(Deref, [Doc])], Maybe [Doc], [Nest])+parseConds set front (Nest LineElse inside:rest) = do+    inside' <- nestToDoc set inside+    Ok (front [], Just inside', rest)+parseConds set front (Nest (LineElseIf d) inside:rest) = do+    inside' <- nestToDoc set inside+    parseConds set (front . (:) (d, inside')) rest+parseConds _ front rest = Ok (front [], Nothing, rest)++doctypeNames :: [(String, String)]+doctypeNames =+    [ ("5", "<!DOCTYPE html>")+    , ("html", "<!DOCTYPE html>")+    , ("1.1", "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">")+    , ("strict", "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")+    ]++data Binding = BindVar Ident+             | BindAs Ident Binding+             | BindConstr DataConstr [Binding]+             | BindTuple [Binding]+             | BindList [Binding]+             | BindRecord DataConstr [(Ident, Binding)] Bool+    deriving (Eq, Show, Read, Data, Typeable)++data DataConstr = DCQualified Module Ident+                | DCUnqualified Ident+    deriving (Eq, Show, Read, Data, Typeable)++newtype Module = Module [String]+    deriving (Eq, Show, Read, Data, Typeable)++spaceTabs :: Parser String+spaceTabs = many $ oneOf " \t"++-- | When using conditional classes, it will often be a single class, e.g.:+--+-- > <div :isHome:.homepage>+--+-- If isHome is False, we do not want any class attribute to be present.+-- However, due to combining multiple classes together, the most obvious+-- implementation would produce a class="". The purpose of this function is to+-- work around that. It does so by checking if all the classes on this tag are+-- optional. If so, it will only include the class attribute if at least one+-- conditional is true.+testIncludeClazzes :: [(Maybe Deref, [Content])] -> Maybe Deref+testIncludeClazzes cs+    | any (isNothing . fst) cs = Nothing+    | otherwise = Just $ DerefBranch (DerefIdent specialOrIdent) $ DerefList $ mapMaybe fst cs++-- | This funny hack is to allow us to refer to the 'or' function without+-- requiring the user to have it in scope. See how this function is used in+-- Text.Hamlet.+specialOrIdent :: Ident+specialOrIdent = Ident "__or__hamlet__special"
+ Text/Hamlet/RT.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- | Most everything exported here is exported also by "Text.Hamlet". The+-- exceptions to that rule should not be necessary for normal usage.+module Text.Hamlet.RT+    ( -- * Public API+      HamletRT (..)+    , HamletData (..)+    , HamletMap+    , HamletException (..)+    , parseHamletRT+    , renderHamletRT+    , renderHamletRT'+    , SimpleDoc (..)+    ) where++import Text.Shakespeare.Base+import Data.Monoid (mconcat)+import Control.Monad (liftM, forM)+import Control.Exception (Exception)+import Data.Typeable (Typeable)+import Text.Hamlet.Parse+import Data.List (intercalate)+#if MIN_VERSION_blaze_html(0,5,0)+import Text.Blaze.Html (Html)+import Text.Blaze.Internal (preEscapedString, preEscapedText)+#else+import Text.Blaze (preEscapedString, preEscapedText, Html)+#endif+import Data.Text (Text)+import Control.Monad.Catch (MonadThrow, throwM)++type HamletMap url = [([String], HamletData url)]+type UrlRenderer url = (url -> [(Text, Text)] -> Text)++data HamletData url+    = HDHtml Html+    | HDUrl url+    | HDUrlParams url [(Text, Text)]+    | HDTemplate HamletRT+    | HDBool Bool+    | HDMaybe (Maybe (HamletMap url))+    | HDList [HamletMap url]++-- FIXME switch to Text?+data SimpleDoc = SDRaw String+               | SDVar [String]+               | SDUrl Bool [String]+               | SDTemplate [String]+               | SDForall [String] String [SimpleDoc]+               | SDMaybe [String] String [SimpleDoc] [SimpleDoc]+               | SDCond [([String], [SimpleDoc])] [SimpleDoc]++newtype HamletRT = HamletRT [SimpleDoc]++data HamletException = HamletParseException String+                     | HamletUnsupportedDocException Doc+                     | HamletRenderException String+    deriving (Show, Typeable)+instance Exception HamletException++++parseHamletRT :: MonadThrow m+              => HamletSettings -> String -> m HamletRT+parseHamletRT set s =+    case parseDoc set s of+        Error s' -> throwM $ HamletParseException s'+        Ok (_, x) -> liftM HamletRT $ mapM convert x+  where+    convert x@(DocForall deref (BindAs _ _) docs) =+       error "Runtime Hamlet does not currently support 'as' patterns"+    convert x@(DocForall deref (BindVar (Ident ident)) docs) = do+        deref' <- flattenDeref' x deref+        docs' <- mapM convert docs+        return $ SDForall deref' ident docs'+    convert DocForall{} = error "Runtime Hamlet does not currently support tuple patterns"+    convert x@(DocMaybe deref (BindAs _ _) jdocs ndocs) =+       error "Runtime Hamlet does not currently support 'as' patterns"+    convert x@(DocMaybe deref (BindVar (Ident ident)) jdocs ndocs) = do+        deref' <- flattenDeref' x deref+        jdocs' <- mapM convert jdocs+        ndocs' <- maybe (return []) (mapM convert) ndocs+        return $ SDMaybe deref' ident jdocs' ndocs'+    convert DocMaybe{} = error "Runtime Hamlet does not currently support tuple patterns"+    convert (DocContent (ContentRaw s')) = return $ SDRaw s'+    convert x@(DocContent (ContentVar deref)) = do+        y <- flattenDeref' x deref+        return $ SDVar y+    convert x@(DocContent (ContentUrl p deref)) = do+        y <- flattenDeref' x deref+        return $ SDUrl p y+    convert x@(DocContent (ContentEmbed deref)) = do+        y <- flattenDeref' x deref+        return $ SDTemplate y+    convert (DocContent ContentMsg{}) =+        error "Runtime hamlet does not currently support message interpolation"+    convert (DocContent ContentAttrs{}) =+        error "Runtime hamlet does not currently support attrs interpolation"++    convert x@(DocCond conds els) = do+        conds' <- mapM go conds+        els' <- maybe (return []) (mapM convert) els+        return $ SDCond conds' els'+      where+        -- | See the comments in Text.Hamlet.Parse.testIncludeClazzes. The conditional+        -- added there doesn't work for runtime Hamlet, so we remove it here.+        go (DerefBranch (DerefIdent x) _, docs') | x == specialOrIdent = do+            docs'' <- mapM convert docs'+            return (["True"], docs'')+        go (deref, docs') = do+            deref' <- flattenDeref' x deref+            docs'' <- mapM convert docs'+            return (deref', docs'')+    convert DocWith{} = error "Runtime hamlet does not currently support $with"+    convert DocCase{} = error "Runtime hamlet does not currently support $case"++renderHamletRT :: MonadThrow m+               => HamletRT+               -> HamletMap url+               -> UrlRenderer url+               -> m Html+renderHamletRT = renderHamletRT' False++renderHamletRT' :: MonadThrow m+                => Bool+                -> HamletRT+                -> HamletMap url+                -> (url -> [(Text, Text)] -> Text)+                -> m Html+renderHamletRT' tempAsHtml (HamletRT docs) scope0 renderUrl =+    liftM mconcat $ mapM (go scope0) docs+  where+    go _ (SDRaw s) = return $ preEscapedString s+    go scope (SDVar n) = do+        v <- lookup' n n scope+        case v of+            HDHtml h -> return h+            _ -> fa $ showName n ++ ": expected HDHtml"+    go scope (SDUrl p n) = do+        v <- lookup' n n scope+        case (p, v) of+            (False, HDUrl u) -> return $ preEscapedText $ renderUrl u []+            (True, HDUrlParams u q) ->+                return $ preEscapedText $ renderUrl u q+            (False, _) -> fa $ showName n ++ ": expected HDUrl"+            (True, _) -> fa $ showName n ++ ": expected HDUrlParams"+    go scope (SDTemplate n) = do+        v <- lookup' n n scope+        case (tempAsHtml, v) of+            (False, HDTemplate h) -> renderHamletRT' tempAsHtml h scope renderUrl+            (False, _) -> fa $ showName n ++ ": expected HDTemplate"+            (True, HDHtml h) -> return h+            (True, _) -> fa $ showName n ++ ": expected HDHtml"+    go scope (SDForall n ident docs') = do+        v <- lookup' n n scope+        case v of+            HDList os ->+                liftM mconcat $ forM os $ \o -> do+                    let scope' = map (\(x, y) -> (ident : x, y)) o ++ scope+                    renderHamletRT' tempAsHtml (HamletRT docs') scope' renderUrl+            _ -> fa $ showName n ++ ": expected HDList"+    go scope (SDMaybe n ident jdocs ndocs) = do+        v <- lookup' n n scope+        (scope', docs') <-+            case v of+                HDMaybe Nothing -> return (scope, ndocs)+                HDMaybe (Just o) -> do+                    let scope' = map (\(x, y) -> (ident : x, y)) o ++ scope+                    return (scope', jdocs)+                _ -> fa $ showName n ++ ": expected HDMaybe"+        renderHamletRT' tempAsHtml (HamletRT docs') scope' renderUrl+    go scope (SDCond [] docs') =+        renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl+    go scope (SDCond ((b, docs'):cs) els) = do+        v <- lookup' b b scope+        case v of+            HDBool True ->+                renderHamletRT' tempAsHtml (HamletRT docs') scope renderUrl+            HDBool False -> go scope (SDCond cs els)+            _ -> fa $ showName b ++ ": expected HDBool"+    lookup' :: MonadThrow m+            => [String] -> [String] -> HamletMap url -> m (HamletData url)+    lookup' orig k m =+        case lookup k m of+            Nothing | k == ["True"] -> return $ HDBool True+            Nothing -> fa $ showName orig ++ ": not found"+            Just x -> return x++fa :: MonadThrow m => String -> m a+fa = throwM . HamletRenderException++showName :: [String] -> String+showName = intercalate "." . reverse++flattenDeref' :: MonadThrow f => Doc -> Deref -> f [String]+flattenDeref' orig deref =+    case flattenDeref deref of+        Nothing -> throwM $ HamletUnsupportedDocException orig+        Just x -> return x
+ Text/IndentToBrace.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.IndentToBrace+    ( i2b+    ) where++import Control.Monad.Trans.Writer (execWriter, tell, Writer)+import Data.List (isInfixOf)+import qualified Data.Text as T++i2b :: String -> String+i2b = ($ [])+    . execWriter+    . mapM_ unnest+    . map addClosingCount+    . nest+    . map toL+    . stripComments+    . lines+    . filter (/= '\r')++stripComments :: [String] -> [String]+stripComments =+    map T.unpack . go False . map T.pack+  where+    go _ [] = []++    go False (l:ls) =+        let (before, after') = T.breakOn "/*" l+         in case T.stripPrefix "/*" after' of+                Nothing -> l : go False ls+                Just after ->+                    let (x:xs) = go True $ after : ls+                     in before `T.append` x : xs+    go True (l:ls) =+        let (_, after') = T.breakOn "*/" l+         in case T.stripPrefix "*/" after' of+                Nothing -> T.empty : go True ls+                Just after -> go False $ after : ls++data Line = Line+    { lineIndent  :: Int+    , lineContent :: String+    }+    deriving (Show, Eq)++data Nest = Nest Line Int [Nest]+          | Blank String+    deriving (Show, Eq)++isBlank :: Nest -> Bool+isBlank Blank{} = True+isBlank _ = False++addClosingCount :: Nest -> Nest+addClosingCount (Blank x) = Blank x+addClosingCount (Nest l c children) =+    Nest l c $ increment $ map addClosingCount children+  where+    increment+        | any (not . isBlank) children = increment'+        | otherwise = id++    increment' [] = error "should never happen"+    increment' (Blank x:rest) = Blank x : increment' rest+    increment' (n@(Nest l' c' children'):rest)+        | any (not . isBlank) rest = n : increment' rest+        | any (not . isBlank) children' = Nest l' c' (increment' children') : rest+        | otherwise = Nest l' (c' + 1) children' : rest++toL :: String -> Either String Line+toL s+    | null y = Left s+    | otherwise = Right $ Line (length x) y+  where+    (x, y) = span (== ' ') s++nest :: [Either String Line] -> [Nest]+nest [] = []+nest (Left x:rest) = Blank x : nest rest+nest (Right l:rest) =+    Nest l 0 (nest inside) : nest outside+  where+    (inside, outside) = span isNested rest+    isNested Left{} = True+    isNested (Right l2) = lineIndent l2 > lineIndent l++tell' :: String -> Writer (String -> String) ()+tell' s = tell (s ++)++unnest :: Nest -> Writer (String -> String) ()+unnest (Blank x) = do+    tell' x+    tell' "\n"+unnest (Nest l count inside) = do+    tell' $ replicate (lineIndent l) ' '+    tell' $ lineContent l+    tell' $+        case () of+            ()+                | not $ all isBlank inside -> "{"+                | ";" `isInfixOf` lineContent l -> ""+                | otherwise -> ";"+    tell' $ replicate count '}'+    tell' "\n"+    mapM_ unnest inside
+ Text/Julius.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+-- | A Shakespearean module for Javascript templates, introducing type-safe,+-- compile-time variable and url interpolation.--+--+-- You might consider trying 'Text.Typescript' or 'Text.Coffee' which compile down to Javascript.+--+-- Further reading: <http://www.yesodweb.com/book/templates>+module Text.Julius+    ( -- * Functions+      -- ** Template-Reading Functions+      -- | These QuasiQuoter and Template Haskell methods return values of+      -- type @'JavascriptUrl' url@. See the Yesod book for details.+      js+    , julius+    , juliusFile+    , jsFile+    , juliusFileDebug+    , jsFileDebug+    , juliusFileReload+    , jsFileReload++      -- * Datatypes+    , JavascriptUrl+    , Javascript (..)+    , RawJavascript (..)++      -- * Typeclass for interpolated variables+    , ToJavascript (..)+    , RawJS (..)++      -- ** Rendering Functions+    , renderJavascript+    , renderJavascriptUrl++      -- ** internal, used by 'Text.Coffee'+    , javascriptSettings+      -- ** internal+    , juliusUsedIdentifiers+    , asJavascriptUrl+    ) where++import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText)+import Data.Monoid+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import Text.Shakespeare+import Data.Aeson (Value)+import Data.Aeson.Encode (fromValue)++renderJavascript :: Javascript -> TL.Text+renderJavascript (Javascript b) = toLazyText b++-- | render with route interpolation. If using this module standalone, apart+-- from type-safe routes, a dummy renderer can be used:+-- +-- > renderJavascriptUrl (\_ _ -> undefined) javascriptUrl+--+-- When using Yesod, a renderer is generated for you, which can be accessed+-- within the GHandler monad: 'Yesod.Core.Handler.getUrlRenderParams'.+renderJavascriptUrl :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> JavascriptUrl url -> TL.Text+renderJavascriptUrl r s = renderJavascript $ s r++-- | Newtype wrapper of 'Builder'.+newtype Javascript = Javascript { unJavascript :: Builder }+    deriving Monoid++-- | Return type of template-reading functions.+type JavascriptUrl url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Javascript++asJavascriptUrl :: JavascriptUrl url -> JavascriptUrl url+asJavascriptUrl = id++-- | A typeclass for types that can be interpolated in CoffeeScript templates.+class ToJavascript a where+    toJavascript :: a -> Javascript+#if 0+instance ToJavascript [Char] where toJavascript = Javascript . fromLazyText . TL.pack+instance ToJavascript TS.Text where toJavascript = Javascript . fromText+instance ToJavascript TL.Text where toJavascript = Javascript . fromLazyText+instance ToJavascript Javascript where toJavascript = Javascript . unJavascript+instance ToJavascript Builder where toJavascript = Javascript+#endif+instance ToJavascript Bool where toJavascript = Javascript . fromText . TS.toLower . TS.pack . show+instance ToJavascript Value where toJavascript = Javascript . fromValue++newtype RawJavascript = RawJavascript Builder+instance ToJavascript RawJavascript where+    toJavascript (RawJavascript a) = Javascript a++class RawJS a where+    rawJS :: a -> RawJavascript++instance RawJS [Char] where rawJS = RawJavascript . fromLazyText . TL.pack+instance RawJS TS.Text where rawJS = RawJavascript . fromText+instance RawJS TL.Text where rawJS = RawJavascript . fromLazyText+instance RawJS Builder where rawJS = RawJavascript+instance RawJS Bool where rawJS = RawJavascript . unJavascript . toJavascript++javascriptSettings :: Q ShakespeareSettings+javascriptSettings = do+  toJExp <- [|toJavascript|]+  wrapExp <- [|Javascript|]+  unWrapExp <- [|unJavascript|]+  asJavascriptUrl' <- [|asJavascriptUrl|]+  return $ defaultShakespeareSettings { toBuilder = toJExp+  , wrap = wrapExp+  , unwrap = unWrapExp+  , modifyFinalValue = Just asJavascriptUrl'+  }++js, julius :: QuasiQuoter+js = QuasiQuoter { quoteExp = \s -> do+    rs <- javascriptSettings+    quoteExp (shakespeare rs) s+    }++julius = js++jsFile, juliusFile :: FilePath -> Q Exp+jsFile fp = do+    rs <- javascriptSettings+    shakespeareFile rs fp++juliusFile = jsFile+++jsFileReload, juliusFileReload :: FilePath -> Q Exp+jsFileReload fp = do+    rs <- javascriptSettings+    shakespeareFileReload rs fp++juliusFileReload = jsFileReload++jsFileDebug, juliusFileDebug :: FilePath -> Q Exp+juliusFileDebug = jsFileReload+{-# DEPRECATED juliusFileDebug "Please use juliusFileReload instead." #-}+jsFileDebug = jsFileReload+{-# DEPRECATED jsFileDebug "Please use jsFileReload instead." #-}++-- | Determine which identifiers are used by the given template, useful for+-- creating systems like yesod devel.+juliusUsedIdentifiers :: String -> [(Deref, VarType)]+juliusUsedIdentifiers = shakespeareUsedIdentifiers defaultShakespeareSettings
+ Text/Lucius.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+module Text.Lucius+    ( -- * Parsing+      lucius+    , luciusFile+    , luciusFileDebug+    , luciusFileReload+      -- ** Mixins+    , luciusMixin+    , Mixin+      -- ** Runtime+    , luciusRT+    , luciusRT'+    , luciusRTMinified+      -- *** Mixin+    , luciusRTMixin+    , RTValue (..)+    , -- * Datatypes+      Css+    , CssUrl+      -- * Type class+    , ToCss (..)+      -- * Rendering+    , renderCss+    , renderCssUrl+      -- * ToCss instances+      -- ** Color+    , Color (..)+    , colorRed+    , colorBlack+      -- ** Size+    , mkSize+    , AbsoluteUnit (..)+    , AbsoluteSize (..)+    , absoluteSize+    , EmSize (..)+    , ExSize (..)+    , PercentageSize (..)+    , percentageSize+    , PixelSize (..)+      -- * Internal+    , parseTopLevels+    , luciusUsedIdentifiers+    ) where++import Text.CssCommon+import Text.Shakespeare.Base+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Data.Text (Text, unpack)+import qualified Data.Text.Lazy as TL+import Text.ParserCombinators.Parsec hiding (Line)+import Text.Css+import Data.Char (isSpace, toLower, toUpper)+import Numeric (readHex)+import Control.Applicative ((<$>))+import Control.Monad (when, unless)+import Data.Monoid (mconcat)+import Data.List (isSuffixOf)+import Control.Arrow (second)+import Text.Shakespeare (VarType)++-- |+--+-- >>> renderCss ([lucius|foo{bar:baz}|] undefined)+-- "foo{bar:baz}"+lucius :: QuasiQuoter+lucius = QuasiQuoter { quoteExp = luciusFromString }++luciusFromString :: String -> Q Exp+luciusFromString s =+    topLevelsToCassius+  $ either (error . show) id $ parse parseTopLevels s s++whiteSpace :: Parser ()+whiteSpace = many whiteSpace1 >> return ()++whiteSpace1 :: Parser ()+whiteSpace1 =+    ((oneOf " \t\n\r" >> return ()) <|> (parseComment >> return ()))++parseBlock :: Parser (Block Unresolved)+parseBlock = do+    sel <- parseSelector+    _ <- char '{'+    whiteSpace+    pairsBlocks <- parsePairsBlocks id+    let (pairs, blocks, mixins) = partitionPBs pairsBlocks+    whiteSpace+    return $ Block sel pairs (map detectAmp blocks) mixins++-- | Looks for an & at the beginning of a selector and, if present, indicates+-- that we should not have a leading space. Otherwise, we should have the+-- leading space.+detectAmp :: Block Unresolved -> (Bool, Block Unresolved)+detectAmp (Block (sel) b c d) =+    (hls, Block sel' b c d)+  where+    (hls, sel') =+        case sel of+            (ContentRaw "&":rest):others -> (False, rest : others)+            (ContentRaw ('&':s):rest):others -> (False, (ContentRaw s : rest) : others)+            _ -> (True, sel)++partitionPBs :: [PairBlock] -> ([Attr Unresolved], [Block Unresolved], [Deref])+partitionPBs =+    go id id id+  where+    go a b c [] = (a [], b [], c [])+    go a b c (PBAttr x:xs) = go (a . (x:)) b c xs+    go a b c (PBBlock x:xs) = go a (b . (x:)) c xs+    go a b c (PBMixin x:xs) = go a b (c . (x:)) xs++parseSelector :: Parser (Selector Unresolved)+parseSelector =+    go id+  where+    go front = do+        c <- parseContents "{,"+        let front' = front . (:) (trim c)+        (char ',' >> go front') <|> return (front' [])++trim :: Contents -> Contents+trim =+    reverse . trim' False . reverse . trim' True+  where+    trim' _ [] = []+    trim' b (ContentRaw s:rest) =+        let s' = trimS b s+         in if null s' then trim' b rest else ContentRaw s' : rest+    trim' _ x = x+    trimS True = dropWhile isSpace+    trimS False = reverse . dropWhile isSpace . reverse++data PairBlock = PBAttr (Attr Unresolved)+               | PBBlock (Block Unresolved)+               | PBMixin Deref+parsePairsBlocks :: ([PairBlock] -> [PairBlock]) -> Parser [PairBlock]+parsePairsBlocks front = (char '}' >> return (front [])) <|> (do+    isBlock <- lookAhead checkIfBlock+    x <- grabMixin <|> (if isBlock then grabBlock else grabPair)+    parsePairsBlocks $ front . (:) x)+  where+    grabBlock = do+        b <- parseBlock+        whiteSpace+        return $ PBBlock b+    grabPair = PBAttr <$> parsePair+    grabMixin = try $ do+        whiteSpace+        Right x <- parseCaret+        whiteSpace+        return $ PBMixin x+    checkIfBlock = do+        skipMany $ noneOf "#@{};"+        (parseHash >> checkIfBlock)+            <|> (parseAt >> checkIfBlock)+            <|> (char '{' >> return True)+            <|> (oneOf ";}" >> return False)+            <|> (anyChar >> checkIfBlock)+            <|> fail "checkIfBlock"++parsePair :: Parser (Attr Unresolved)+parsePair = do+    key <- parseContents ":"+    _ <- char ':'+    whiteSpace+    val <- parseContents ";}"+    (char ';' >> return ()) <|> return ()+    whiteSpace+    return $ Attr key val++parseContents :: String -> Parser Contents+parseContents = many1 . parseContent++parseContent :: String -> Parser Content+parseContent restricted =+    parseHash' <|> parseAt' <|> parseComment <|> parseBack <|> parseChar+  where+    parseHash' = either ContentRaw ContentVar `fmap` parseHash+    parseAt' =+        either ContentRaw go `fmap` parseAt+      where+        go (d, False) = ContentUrl d+        go (d, True) = ContentUrlParam d+    parseBack = try $ do+        _ <- char '\\'+        hex <- atMost 6 $ satisfy isHex+        (int, _):_ <- return $ readHex $ dropWhile (== '0') hex+        when (length hex < 6) $+            ((string "\r\n" >> return ()) <|> (satisfy isSpace >> return ()))+        return $ ContentRaw [toEnum int]+    parseChar = (ContentRaw . return) `fmap` noneOf restricted++isHex :: Char -> Bool+isHex c =+    ('0' <= c && c <= '9') ||+    ('A' <= c && c <= 'F') ||+    ('a' <= c && c <= 'f')++atMost :: Int -> Parser a -> Parser [a]+atMost 0 _ = return []+atMost i p = (do+    c <- p+    s <- atMost (i - 1) p+    return $ c : s) <|> return []++parseComment :: Parser Content+parseComment = do+    _ <- try $ string "/*"+    _ <- manyTill anyChar $ try $ string "*/"+    return $ ContentRaw ""++luciusFile :: FilePath -> Q Exp+luciusFile fp = do+#ifdef GHC_7_4+    qAddDependentFile fp+#endif+    contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp+    luciusFromString contents++luciusFileDebug, luciusFileReload :: FilePath -> Q Exp+luciusFileDebug = cssFileDebug False [|parseTopLevels|] parseTopLevels+luciusFileReload = luciusFileDebug++parseTopLevels :: Parser [TopLevel Unresolved]+parseTopLevels =+    go id+  where+    go front = do+        let string' s = string s >> return ()+            ignore = many (whiteSpace1 <|> string' "<!--" <|> string' "-->")+                        >> return ()+        ignore+        tl <- ((charset <|> media <|> impor <|> topAtBlock <|> var <|> fmap TopBlock parseBlock) >>= \x -> go (front . (:) x))+            <|> (return $ map compressTopLevel $ front [])+        ignore+        return tl+    charset = do+        try $ stringCI "@charset "+        cs <- parseContents ";"+        _ <- char ';'+        return $ TopAtDecl "charset" cs+    media = do+        try $ stringCI "@media "+        selector <- parseContents "{"+        _ <- char '{'+        b <- parseBlocks id+        return $ TopAtBlock "media" selector b+    impor = do+        try $ stringCI "@import ";+        val <- parseContents ";"+        _ <- char ';'+        return $ TopAtDecl "import" val+    var = try $ do+        _ <- char '@'+        isPage <- (try $ string "page " >> return True) <|>+                  (try $ string "font-face " >> return True) <|>+                    return False+        when isPage $ fail "page is not a variable"+        k <- many1 $ noneOf ":"+        _ <- char ':'+        v <- many1 $ noneOf ";"+        _ <- char ';'+        let trimS = reverse . dropWhile isSpace . reverse . dropWhile isSpace+        return $ TopVar (trimS k) (trimS v)+    topAtBlock = do+        (name, selector) <- try $ do+            _ <- char '@'+            name <- many1 $ noneOf " \t"+            _ <- many1 $ oneOf " \t"+            unless ("keyframes" `isSuffixOf` name) $ fail "only accepting keyframes"+            selector <- parseContents "{"+            _ <- char '{'+            return (name, selector)+        b <- parseBlocks id+        return $ TopAtBlock name selector b+    parseBlocks front = do+        whiteSpace+        (char '}' >> return (map compressBlock $ front []))+            <|> (parseBlock >>= \x -> parseBlocks (front . (:) x))++stringCI :: String -> Parser ()+stringCI [] = return ()+stringCI (c:cs) = (char (toLower c) <|> char (toUpper c)) >> stringCI cs++luciusRT' :: TL.Text+          -> Either String ([(Text, Text)] -> Either String [TopLevel Resolved])+luciusRT' =+    either Left (Right . go) . luciusRTInternal+  where+    go :: ([(Text, RTValue)] -> Either String [TopLevel Resolved])+       -> ([(Text, Text)] -> Either String [TopLevel Resolved])+    go f = f . map (second RTVRaw)++luciusRTInternal+    :: TL.Text+    -> Either String ([(Text, RTValue)] -> Either String [TopLevel Resolved])+luciusRTInternal tl =+    case parse parseTopLevels (TL.unpack tl) (TL.unpack tl) of+        Left s -> Left $ show s+        Right tops -> Right $ \scope -> go scope tops+  where+    go :: [(Text, RTValue)]+       -> [TopLevel Unresolved]+       -> Either String [TopLevel Resolved]+    go _ [] = Right []+    go scope (TopAtDecl dec cs':rest) = do+        let scope' = map goScope scope+            render = error "luciusRT has no URLs"+        cs <- mapM (contentToBuilderRT scope' render) cs'+        rest' <- go scope rest+        Right $ TopAtDecl dec (mconcat cs) : rest'+    go scope (TopBlock b:rest) = do+        b' <- goBlock scope b+        rest' <- go scope rest+        Right $ map TopBlock b' ++ rest'+    go scope (TopAtBlock name m' bs:rest) = do+        let scope' = map goScope scope+            render = error "luciusRT has no URLs"+        m <- mapM (contentToBuilderRT scope' render) m'+        bs' <- mapM (goBlock scope) bs+        rest' <- go scope rest+        Right $ TopAtBlock name (mconcat m) (concat bs') : rest'+    go scope (TopVar k v:rest) = go ((pack k, RTVRaw $ pack v):scope) rest++    goBlock :: [(Text, RTValue)]+            -> Block Unresolved+            -> Either String [Block Resolved]+    goBlock scope =+        either Left (Right . ($[])) . blockRuntime scope' (error "luciusRT has no URLs")+      where+        scope' = map goScope scope++    goScope (k, rt) =+        (DerefIdent (Ident $ unpack k), cd)+      where+        cd =+            case rt of+                RTVRaw t -> CDPlain $ fromText t+                RTVMixin m -> CDMixin m++luciusRT :: TL.Text -> [(Text, Text)] -> Either String TL.Text+luciusRT tl scope = either Left (Right . renderCss . CssWhitespace) $ either Left ($ scope) (luciusRT' tl)++-- | Runtime Lucius with mixin support.+--+-- Since 1.0.6+luciusRTMixin :: TL.Text -- ^ template+              -> Bool -- ^ minify?+              -> [(Text, RTValue)] -- ^ scope+              -> Either String TL.Text+luciusRTMixin tl minify scope =+    either Left (Right . renderCss . cw) $ either Left ($ scope) (luciusRTInternal tl)+  where+    cw+        | minify = CssNoWhitespace+        | otherwise = CssWhitespace++data RTValue = RTVRaw Text+             | RTVMixin Mixin++-- | Same as 'luciusRT', but output has no added whitespace.+--+-- Since 1.0.3+luciusRTMinified :: TL.Text -> [(Text, Text)] -> Either String TL.Text+luciusRTMinified tl scope = either Left (Right . renderCss . CssNoWhitespace) $ either Left ($ scope) (luciusRT' tl)++-- | Determine which identifiers are used by the given template, useful for+-- creating systems like yesod devel.+luciusUsedIdentifiers :: String -> [(Deref, VarType)]+luciusUsedIdentifiers = cssUsedIdentifiers False parseTopLevels++luciusMixin :: QuasiQuoter+luciusMixin = QuasiQuoter { quoteExp = luciusMixinFromString }++luciusMixinFromString :: String -> Q Exp+luciusMixinFromString s' = do+    r <- newName "_render"+    case fmap compressBlock $ parse parseBlock s s of+        Left e -> error $ show e+        Right block -> blockToMixin r [] block+  where+    s = concat ["mixin{", s', "}"]
+ Text/MkSizeType.hs view
@@ -0,0 +1,73 @@+-- | Internal functions to generate CSS size wrapper types.+module Text.MkSizeType (mkSizeType) where++import Language.Haskell.TH.Syntax++mkSizeType :: String -> String -> Q [Dec]+mkSizeType name' unit = return [ dataDec name+                               , showInstanceDec name unit+                               , numInstanceDec name+                               , fractionalInstanceDec name+                               , toCssInstanceDec name ]+  where name = mkName $ name'++dataDec :: Name -> Dec+dataDec name = DataD [] name [] [constructor] derives+  where constructor = NormalC name [(NotStrict, ConT $ mkName "Rational")]+        derives = map mkName ["Eq", "Ord"]++showInstanceDec :: Name -> String -> Dec+showInstanceDec name unit' = InstanceD [] (instanceType "Show" name) [showDec]+  where showSize = VarE $ mkName "showSize"+        x = mkName "x"+        unit = LitE $ StringL unit'+        showDec = FunD (mkName "show") [Clause [showPat] showBody []]+        showPat = ConP name [VarP x]+        showBody = NormalB $ AppE (AppE showSize $ VarE x) unit++numInstanceDec :: Name -> Dec+numInstanceDec name = InstanceD [] (instanceType "Num" name) decs+  where decs = map (binaryFunDec name) ["+", "*", "-"] +++               map (unariFunDec1 name) ["abs", "signum"] +++               [unariFunDec2 name "fromInteger"]++fractionalInstanceDec :: Name -> Dec+fractionalInstanceDec name = InstanceD [] (instanceType "Fractional" name) decs+  where decs = [binaryFunDec name "/", unariFunDec2 name "fromRational"]++toCssInstanceDec :: Name -> Dec+toCssInstanceDec name = InstanceD [] (instanceType "ToCss" name) [toCssDec]+  where toCssDec = FunD (mkName "toCss") [Clause [] showBody []]+        showBody = NormalB $ (AppE dot from) `AppE` ((AppE dot pack) `AppE` show')+        -- FIXME this whole section makes me a little nervous+        from = VarE (mkName "fromLazyText")+        pack = VarE (mkName "TL.pack")+        dot = VarE (mkName ".")+        show' = VarE (mkName "show")++instanceType :: String -> Name -> Type+instanceType className name = AppT (ConT $ mkName className) (ConT name)++binaryFunDec :: Name -> String -> Dec+binaryFunDec name fun' = FunD fun [Clause [pat1, pat2] body []]+  where pat1 = ConP name [VarP v1]+        pat2 = ConP name [VarP v2]+        body = NormalB $ AppE (ConE name) result+        result = AppE (AppE (VarE fun) (VarE v1)) (VarE v2)+        fun = mkName fun'+        v1 = mkName "v1"+        v2 = mkName "v2"++unariFunDec1 :: Name -> String -> Dec+unariFunDec1 name fun' = FunD fun [Clause [pat] body []]+  where pat = ConP name [VarP v]+        body = NormalB $ AppE (ConE name) (AppE (VarE fun) (VarE v))+        fun = mkName fun'+        v = mkName "v"++unariFunDec2 :: Name -> String -> Dec+unariFunDec2 name fun' = FunD fun [Clause [pat] body []]+  where pat = VarP x+        body = NormalB $ AppE (ConE name) (AppE (VarE fun) (VarE x))+        fun = mkName fun'+        x = mkName "x"
+ Text/Roy.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+-- | A Shakespearean module for Roy, introducing type-safe,+-- compile-time variable and url interpolation. It is exactly the same as+-- "Text.Julius", except that the template is first compiled to Javascript with+-- the system tool @roy@.+--+-- To use this module, @roy@ must be installed on your system.+--+-- If you interpolate variables,+-- the template is first wrapped with a function containing javascript variables representing shakespeare variables,+-- then compiled with @roy@,+-- and then the value of the variables are applied to the function.+-- This means that in production the template can be compiled+-- once at compile time and there will be no dependency in your production+-- system on @roy@. +--+-- Your code:+--+-- > let b = 1+-- > console.log(#{a} + b)+--+-- Final Result:+--+-- > ;(function(shakespeare_var_a){+-- >   var b = 1;+-- >   console.log(shakespeare_var_a + b);+-- > })(#{a});+--+-- Further reading:+--+-- 1. Shakespearean templates: <http://www.yesodweb.com/book/templates>+--+-- 2. Roy: <http://roy.brianmckenna.org/>+module Text.Roy+    ( -- * Functions+      -- ** Template-Reading Functions+      -- | These QuasiQuoter and Template Haskell methods return values of+      -- type @'JavascriptUrl' url@. See the Yesod book for details.+      roy+    , royFile+    , royFileReload++#ifdef TEST_EXPORT+    , roySettings+#endif+    ) where++import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Text.Shakespeare+import Text.Julius++-- | The Roy language compiles down to Javascript.+-- We do this compilation once at compile time to avoid needing to do it during the request.+-- We call this a preConversion because other shakespeare modules like Lucius use Haskell to compile during the request instead rather than a system call.+roySettings :: Q ShakespeareSettings+roySettings = do+  jsettings <- javascriptSettings+  return $ jsettings { varChar = '#'+  , preConversion = Just PreConvert {+      preConvert = ReadProcess "roy" ["--stdio", "--browser"]+    , preEscapeIgnoreBalanced = "'\""+    , preEscapeIgnoreLine = "//"+    , wrapInsertion = Just WrapInsertion {+        wrapInsertionIndent = Just "  "+      , wrapInsertionStartBegin = "(\\"+      , wrapInsertionSeparator = " "+      , wrapInsertionStartClose = " ->\n"+      , wrapInsertionEnd = ")"+      , wrapInsertionAddParens = True+      }+    }+  }++-- | Read inline, quasiquoted Roy.+roy :: QuasiQuoter+roy = QuasiQuoter { quoteExp = \s -> do+    rs <- roySettings+    quoteExp (shakespeare rs) s+    }++-- | Read in a Roy template file. This function reads the file once, at+-- compile time.+royFile :: FilePath -> Q Exp+royFile fp = do+    rs <- roySettings+    shakespeareFile rs fp++-- | Read in a Roy template file. This impure function uses+-- unsafePerformIO to re-read the file on every call, allowing for rapid+-- iteration.+royFileReload :: FilePath -> Q Exp+royFileReload fp = do+    rs <- roySettings+    shakespeareFileReload rs fp
Text/Shakespeare.hs view
@@ -7,7 +7,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# OPTIONS_GHC -fno-warn-missing-fields #-} {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}--- | For lack of a better name... a parameterized version of Julius.+-- | NOTE: This module should be considered internal, and will be hidden in+-- future releases. module Text.Shakespeare     ( ShakespeareSettings (..)     , PreConvert (..)@@ -25,9 +26,7 @@     , Deref     , Parser -#ifdef TEST_EXPORT     , preFilter-#endif       -- * Internal       -- can we remove this?     , shakespeareRuntime
+ Text/Shakespeare/I18N.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Text.Shakespeare.I18N+-- Copyright   :  2012 Michael Snoyman <michael@snoyman.com>, Jeremy Shaw+-- License     :  BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer  :  Michael Snoyman <michael@snoyman.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- This module provides a type-based system for providing translations+-- for text strings.+--+-- It is similar in purpose to gettext or Java message bundles.+--+-- The core idea is to create simple data type where each constructor+-- represents a phrase, sentence, paragraph, etc. For example:+--+-- > data AppMessages = Hello | Goodbye+--+-- The 'RenderMessage' class is used to retrieve the appropriate+-- translation for a message value:+--+-- > class RenderMessage master message where+-- >   renderMessage :: master  -- ^ type that specifies which set of translations to use+-- >                 -> [Lang]  -- ^ acceptable languages in descending order of preference+-- >                 -> message -- ^ message to translate+-- >                 -> Text+--+-- Defining the translation type and providing the 'RenderMessage'+-- instance in Haskell is not very translator friendly. Instead,+-- translations are generally provided in external translations+-- files. Then the 'mkMessage' Template Haskell function is used to+-- read the external translation files and automatically create the+-- translation type and the @RenderMessage@ instance.+--+-- A full description of using this module to create translations for @Hamlet@ can be found here:+--+--  <http://www.yesodweb.com/book/internationalization>+--+-- A full description of using the module to create translations for @HSP@ can be found here:+--+--  <http://happstack.com/docs/crashcourse/Templates.html#hsp-i18n>+--+-- You can also adapt those instructions for use with other systems.+module Text.Shakespeare.I18N+    ( mkMessage+    , mkMessageFor+    , mkMessageVariant+    , RenderMessage (..)+    , ToMessage (..)+    , SomeMessage (..)+    , Lang+    ) where++import Language.Haskell.TH.Syntax+import Data.Text (Text, pack, unpack)+import System.Directory+import Data.Maybe (catMaybes)+import Data.List (isSuffixOf, sortBy, foldl')+import qualified Data.ByteString as S+import Data.Text.Encoding (decodeUtf8)+import Data.Char (isSpace, toLower, toUpper)+import Data.Ord (comparing)+import Text.Shakespeare.Base (Deref (..), Ident (..), parseHash, derefToExp)+import Text.ParserCombinators.Parsec (parse, many, eof, many1, noneOf, (<|>))+import Control.Arrow ((***))+import Data.Monoid (mempty, mappend)+import qualified Data.Text as T+import Data.String (IsString (fromString))++-- | 'ToMessage' is used to convert the value inside #{ } to 'Text'+--+-- The primary purpose of this class is to allow the value in #{ } to+-- be a 'String' or 'Text' rather than forcing it to always be 'Text'.+class ToMessage a where+    toMessage :: a -> Text+instance ToMessage Text where+    toMessage = id+instance ToMessage String where+    toMessage = Data.Text.pack++-- | the 'RenderMessage' is used to provide translations for a message types+--+-- The 'master' argument exists so that it is possible to provide more+-- than one set of translations for a 'message' type. This is useful+-- if a library provides a default set of translations, but the user+-- of the library wants to provide a different set of translations.+class RenderMessage master message where+    renderMessage :: master  -- ^ type that specifies which set of translations to use+                  -> [Lang]  -- ^ acceptable languages in descending order of preference+                  -> message -- ^ message to translate+                  -> Text++instance RenderMessage master Text where+    renderMessage _ _ = id++-- | an RFC1766 / ISO 639-1 language code (eg, @fr@, @en-GB@, etc).+type Lang = Text++-- |generate translations from translation files+--+-- This function will:+--+--  1. look in the supplied subdirectory for files ending in @.msg@+--+--  2. generate a type based on the constructors found+--+--  3. create a 'RenderMessage' instance+--+mkMessage :: String   -- ^ base name to use for translation type+          -> FilePath -- ^ subdirectory which contains the translation files+          -> Lang     -- ^ default translation language+          -> Q [Dec]+mkMessage dt folder lang =+    mkMessageCommon True "Msg" "Message" dt dt folder lang+++-- | create 'RenderMessage' instance for an existing data-type+mkMessageFor :: String     -- ^ master translation data type+             -> String     -- ^ existing type to add translations for+             -> FilePath   -- ^ path to translation folder+             -> Lang       -- ^ default language+             -> Q [Dec]+mkMessageFor master dt folder lang = mkMessageCommon False "" "" master dt folder lang++-- | create an additional set of translations for a type created by `mkMessage`+mkMessageVariant :: String     -- ^ master translation data type+                 -> String     -- ^ existing type to add translations for+                 -> FilePath   -- ^ path to translation folder+                 -> Lang       -- ^ default language+                 -> Q [Dec]+mkMessageVariant master dt folder lang = mkMessageCommon False "Msg" "Message" master dt folder lang++-- |used by 'mkMessage' and 'mkMessageFor' to generate a 'RenderMessage' and possibly a message data type+mkMessageCommon :: Bool      -- ^ generate a new datatype from the constructors found in the .msg files+                -> String    -- ^ string to append to constructor names+                -> String    -- ^ string to append to datatype name+                -> String    -- ^ base name of master datatype+                -> String    -- ^ base name of translation datatype+                -> FilePath  -- ^ path to translation folder+                -> Lang      -- ^ default lang+                -> Q [Dec]+mkMessageCommon genType prefix postfix master dt folder lang = do+    files <- qRunIO $ getDirectoryContents folder+    (_files', contents) <- qRunIO $ fmap (unzip . catMaybes) $ mapM (loadLang folder) files+#ifdef GHC_7_4+    mapM_ qAddDependentFile _files'+#endif+    sdef <-+        case lookup lang contents of+            Nothing -> error $ "Did not find main language file: " ++ unpack lang+            Just def -> toSDefs def+    mapM_ (checkDef sdef) $ map snd contents+    let mname = mkName $ dt ++ postfix+    c1 <- fmap concat $ mapM (toClauses prefix dt) contents+    c2 <- mapM (sToClause prefix dt) sdef+    c3 <- defClause+    return $+     ( if genType +       then ((DataD [] mname [] (map (toCon dt) sdef) []) :)+       else id)+        [ InstanceD+            []+            (ConT ''RenderMessage `AppT` (ConT $ mkName master) `AppT` ConT mname)+            [ FunD (mkName "renderMessage") $ c1 ++ c2 ++ [c3]+            ]+        ]++toClauses :: String -> String -> (Lang, [Def]) -> Q [Clause]+toClauses prefix dt (lang, defs) =+    mapM go defs+  where+    go def = do+        a <- newName "lang"+        (pat, bod) <- mkBody dt (prefix ++ constr def) (map fst $ vars def) (content def)+        guard <- fmap NormalG [|$(return $ VarE a) == pack $(lift $ unpack lang)|]+        return $ Clause+            [WildP, ConP (mkName ":") [VarP a, WildP], pat]+            (GuardedB [(guard, bod)])+            []++mkBody :: String -- ^ datatype+       -> String -- ^ constructor+       -> [String] -- ^ variable names+       -> [Content]+       -> Q (Pat, Exp)+mkBody dt cs vs ct = do+    vp <- mapM go vs+    let pat = RecP (mkName cs) (map (varName dt *** VarP) vp)+    let ct' = map (fixVars vp) ct+    pack' <- [|Data.Text.pack|]+    tomsg <- [|toMessage|]+    let ct'' = map (toH pack' tomsg) ct'+    mapp <- [|mappend|]+    let app a b = InfixE (Just a) mapp (Just b)+    e <-+        case ct'' of+            [] -> [|mempty|]+            [x] -> return x+            (x:xs) -> return $ foldl' app x xs+    return (pat, e)+  where+    toH pack' _ (Raw s) = pack' `AppE` SigE (LitE (StringL s)) (ConT ''String)+    toH _ tomsg (Var d) = tomsg `AppE` derefToExp [] d+    go x = do+        let y = mkName $ '_' : x+        return (x, y)+    fixVars vp (Var d) = Var $ fixDeref vp d+    fixVars _ (Raw s) = Raw s+    fixDeref vp (DerefIdent (Ident i)) = DerefIdent $ Ident $ fixIdent vp i+    fixDeref vp (DerefBranch a b) = DerefBranch (fixDeref vp a) (fixDeref vp b)+    fixDeref _ d = d+    fixIdent vp i =+        case lookup i vp of+            Nothing -> i+            Just y -> nameBase y++sToClause :: String -> String -> SDef -> Q Clause+sToClause prefix dt sdef = do+    (pat, bod) <- mkBody dt (prefix ++ sconstr sdef) (map fst $ svars sdef) (scontent sdef)+    return $ Clause+        [WildP, ConP (mkName "[]") [], pat]+        (NormalB bod)+        []++defClause :: Q Clause+defClause = do+    a <- newName "sub"+    c <- newName "langs"+    d <- newName "msg"+    rm <- [|renderMessage|]+    return $ Clause+        [VarP a, ConP (mkName ":") [WildP, VarP c], VarP d]+        (NormalB $ rm `AppE` VarE a `AppE` VarE c `AppE` VarE d)+        []++toCon :: String -> SDef -> Con+toCon dt (SDef c vs _) =+    RecC (mkName $ "Msg" ++ c) $ map go vs+  where+    go (n, t) = (varName dt n, NotStrict, ConT $ mkName t)++varName :: String -> String -> Name+varName a y =+    mkName $ concat [lower a, "Message", upper y]+  where+    lower (x:xs) = toLower x : xs+    lower [] = []+    upper (x:xs) = toUpper x : xs+    upper [] = []++checkDef :: [SDef] -> [Def] -> Q ()+checkDef x y =+    go (sortBy (comparing sconstr) x) (sortBy (comparing constr) y)+  where+    go _ [] = return ()+    go [] (b:_) = error $ "Extra message constructor: " ++ constr b+    go (a:as) (b:bs)+        | sconstr a < constr b = go as (b:bs)+        | sconstr a > constr b = error $ "Extra message constructor: " ++ constr b+        | otherwise = do+            go' (svars a) (vars b)+            go as bs+    go' ((an, at):as) ((bn, mbt):bs)+        | an /= bn = error "Mismatched variable names"+        | otherwise =+            case mbt of+                Nothing -> go' as bs+                Just bt+                    | at == bt -> go' as bs+                    | otherwise -> error "Mismatched variable types"+    go' [] [] = return ()+    go' _ _ = error "Mistmached variable count"++toSDefs :: [Def] -> Q [SDef]+toSDefs = mapM toSDef++toSDef :: Def -> Q SDef+toSDef d = do+    vars' <- mapM go $ vars d+    return $ SDef (constr d) vars' (content d)+  where+    go (a, Just b) = return (a, b)+    go (a, Nothing) = error $ "Main language missing type for " ++ show (constr d, a)++data SDef = SDef+    { sconstr :: String+    , svars :: [(String, String)]+    , scontent :: [Content]+    }++data Def = Def+    { constr :: String+    , vars :: [(String, Maybe String)]+    , content :: [Content]+    }++loadLang :: FilePath -> FilePath -> IO (Maybe (FilePath, (Lang, [Def])))+loadLang folder file = do+    let file' = folder ++ '/' : file+    e <- doesFileExist file'+    if e && ".msg" `isSuffixOf` file+        then do+            let lang = pack $ reverse $ drop 4 $ reverse file+            bs <- S.readFile file'+            let s = unpack $ decodeUtf8 bs+            defs <- fmap catMaybes $ mapM (parseDef . T.unpack . T.strip . T.pack) $ lines s+            return $ Just (file', (lang, defs))+        else return Nothing++parseDef :: String -> IO (Maybe Def)+parseDef "" = return Nothing+parseDef ('#':_) = return Nothing+parseDef s =+    case end of+        ':':end' -> do+            content' <- fmap compress $ parseContent $ dropWhile isSpace end'+            case words begin of+                [] -> error $ "Missing constructor: " ++ s+                (w:ws) -> return $ Just Def+                            { constr = w+                            , vars = map parseVar ws+                            , content = content'+                            }+        _ -> error $ "Missing colon: " ++ s+  where+    (begin, end) = break (== ':') s++data Content = Var Deref | Raw String++compress :: [Content] -> [Content]+compress [] = []+compress (Raw a:Raw b:rest) = compress $ Raw (a ++ b) : rest+compress (x:y) = x : compress y++parseContent :: String -> IO [Content]+parseContent s =+    either (error . show) return $ parse go s s+  where+    go = do+        x <- many go'+        eof+        return x+    go' = (Raw `fmap` many1 (noneOf "#")) <|> (fmap (either Raw Var) parseHash)++parseVar :: String -> (String, Maybe String)+parseVar s =+    case break (== '@') s of+        (x, '@':y) -> (x, Just y)+        _ -> (s, Nothing)++data SomeMessage master = forall msg. RenderMessage master msg => SomeMessage msg++instance IsString (SomeMessage master) where+    fromString = SomeMessage . T.pack++instance RenderMessage master (SomeMessage master) where+    renderMessage a b (SomeMessage msg) = renderMessage a b msg
+ Text/Shakespeare/Text.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+module Text.Shakespeare.Text+    ( TextUrl+    , ToText (..)+    , renderTextUrl+    , stext+    , text+    , textFile+    , textFileDebug+    , textFileReload+    , st -- | strict text+    , lt -- | lazy text, same as stext :)+    -- * Yesod code generation+    , codegen+    , codegenSt+    , codegenFile+    , codegenFileReload+    ) where++import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Language.Haskell.TH.Syntax+import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText)+import qualified Data.Text as TS+import qualified Data.Text.Lazy as TL+import Text.Shakespeare+import Data.Int (Int32, Int64)++renderTextUrl :: RenderUrl url -> TextUrl url -> TL.Text+renderTextUrl r s = toLazyText $ s r++type TextUrl url = RenderUrl url -> Builder++class ToText a where+    toText :: a -> Builder+instance ToText Builder where toText = id+instance ToText [Char ] where toText = fromLazyText . TL.pack+instance ToText TS.Text where toText = fromText+instance ToText TL.Text where toText = fromLazyText++instance ToText Int32 where toText = toText . show+instance ToText Int64 where toText = toText . show+instance ToText Int   where toText = toText . show++settings :: Q ShakespeareSettings+settings = do+  toTExp <- [|toText|]+  wrapExp <- [|id|]+  unWrapExp <- [|id|]+  return $ defaultShakespeareSettings { toBuilder = toTExp+  , wrap = wrapExp+  , unwrap = unWrapExp+  }+++stext, lt, st, text :: QuasiQuoter+stext = +  QuasiQuoter { quoteExp = \s -> do+    rs <- settings+    render <- [|toLazyText|]+    rendered <- shakespeareFromString rs { justVarInterpolation = True } s+    return (render `AppE` rendered)+    }+lt = stext++st = +  QuasiQuoter { quoteExp = \s -> do+    rs <- settings+    render <- [|TL.toStrict . toLazyText|]+    rendered <- shakespeareFromString rs { justVarInterpolation = True } s+    return (render `AppE` rendered)+    }++text = QuasiQuoter { quoteExp = \s -> do+    rs <- settings+    quoteExp (shakespeare rs) $ filter (/='\r') s+    }+++textFile :: FilePath -> Q Exp+textFile fp = do+    rs <- settings+    shakespeareFile rs fp+++textFileDebug :: FilePath -> Q Exp+textFileDebug = textFileReload+{-# DEPRECATED textFileDebug "Please use textFileReload instead" #-}++textFileReload :: FilePath -> Q Exp+textFileReload fp = do+    rs <- settings+    shakespeareFileReload rs fp++-- | codegen is designed for generating Yesod code, including templates+-- So it uses different interpolation characters that won't clash with templates.+codegenSettings :: Q ShakespeareSettings+codegenSettings = do+  toTExp <- [|toText|]+  wrapExp <- [|id|]+  unWrapExp <- [|id|]+  return $ defaultShakespeareSettings { toBuilder = toTExp+  , wrap = wrapExp+  , unwrap = unWrapExp+  , varChar = '~'+  , urlChar = '*'+  , intChar = '&'+  , justVarInterpolation = True -- always!+  }++-- | codegen is designed for generating Yesod code, including templates+-- So it uses different interpolation characters that won't clash with templates.+-- You can use the normal text quasiquoters to generate code+codegen :: QuasiQuoter+codegen =+  QuasiQuoter { quoteExp = \s -> do+    rs <- codegenSettings+    render <- [|toLazyText|]+    rendered <- shakespeareFromString rs { justVarInterpolation = True } s+    return (render `AppE` rendered)+    }++-- | Generates strict Text+-- codegen is designed for generating Yesod code, including templates+-- So it uses different interpolation characters that won't clash with templates.+codegenSt :: QuasiQuoter+codegenSt =+  QuasiQuoter { quoteExp = \s -> do+    rs <- codegenSettings+    render <- [|TL.toStrict . toLazyText|]+    rendered <- shakespeareFromString rs { justVarInterpolation = True } s+    return (render `AppE` rendered)+    }++codegenFileReload :: FilePath -> Q Exp+codegenFileReload fp = do+    rs <- codegenSettings+    render <- [|TL.toStrict . toLazyText|]+    rendered <- shakespeareFileReload rs{ justVarInterpolation = True } fp+    return (render `AppE` rendered)++codegenFile :: FilePath -> Q Exp+codegenFile fp = do+    rs <- codegenSettings+    render <- [|TL.toStrict . toLazyText|]+    rendered <- shakespeareFile rs{ justVarInterpolation = True } fp+    return (render `AppE` rendered)
+ app/servius.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RecordWildCards    #-}+module Main (main) where++import           Blaze.ByteString.Builder.Char.Utf8 (fromLazyText)+import qualified Data.ByteString.Char8              as S8+import           Data.Text                          (Text)+import qualified Data.Text                          as T+import           Data.Text.Encoding                 (decodeUtf8With)+import           Data.Text.Encoding.Error           (lenientDecode)+import qualified Data.Text.Lazy                     as TL+import           Network.HTTP.Types                 (status200)+import           Network.Wai                        (Middleware, Response,+                                                     pathInfo, responseBuilder)+import           Text.Blaze.Html.Renderer.Utf8      (renderHtmlBuilder)+import           Text.Hamlet                        (defaultHamletSettings)+import           Text.Hamlet.RT                     (parseHamletRT,+                                                     renderHamletRT)+import           Text.Lucius                        (luciusRT)+import           WaiAppStatic.CmdLine               (docroot, runCommandLine)++main :: IO ()+main = runCommandLine (shake . docroot)++shake :: FilePath -> Middleware+shake docroot app req+    | any unsafe p = app req+    | null p = app req+    | ".hamlet" `T.isSuffixOf` l = hamlet pr+    | ".lucius" `T.isSuffixOf` l = lucius pr+    | otherwise = app req+  where+    p = pathInfo req+    pr = T.intercalate "/" $ T.pack docroot : p+    l = last p++unsafe :: Text -> Bool+unsafe s+    | T.null s = False+    | T.head s == '.' = True+    | otherwise = T.any (== '/') s++readFileUtf8 :: Text -> IO String+readFileUtf8 fp = do+    bs <- S8.readFile $ T.unpack fp+    let t = decodeUtf8With lenientDecode bs+    return $ T.unpack t++hamlet :: Text -> IO Response+hamlet fp = do+    str <- readFileUtf8 fp+    hrt <- parseHamletRT defaultHamletSettings str+    html <- renderHamletRT hrt [] (error "No URLs allowed")+    return $ responseBuilder status200 [("Content-Type", "text/html; charset=utf-8")] $ renderHtmlBuilder html++lucius :: Text -> IO Response+lucius fp = do+    str <- readFileUtf8 fp+    let text = either error id $ luciusRT (TL.pack str) []+    return $ responseBuilder status200 [("Content-Type", "text/css; charset=utf-8")] $ fromLazyText text
shakespeare.cabal view
@@ -1,5 +1,5 @@ name:            shakespeare-version:         1.2.1.1+version:         2.0.0 license:         MIT license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -21,7 +21,16 @@ cabal-version:   >= 1.8 build-type:      Simple homepage:        http://www.yesodweb.com/book/shakespearean-templates-extra-source-files: test/reload.txt+extra-source-files:+  test/reload.txt+  test/texts/*.text+  test/juliuses/*.julius+  test/juliuses/*.coffee+  test-messages/*.msg+  test/cassiuses/*.cassius+  test/cassiuses/*.lucius+  test/hamlets/*.hamlet+  test/tmp.hs  library     build-depends:   base             >= 4       && < 5@@ -34,10 +43,30 @@                    , text             >= 0.7                    , process          >= 1.0                    , ghc-prim+                   , bytestring+                   , directory+                   , aeson+                   , blaze-markup+                   , blaze-html+                   , exceptions+                   , transformers -    exposed-modules: -                     Text.Shakespeare+    exposed-modules: Text.Shakespeare.I18N+                     Text.Shakespeare.Text+                     Text.Roy+                     Text.Julius+                     Text.Coffee+                     Text.Hamlet+                     Text.Hamlet.RT+                     Text.Lucius+                     Text.Cassius                      Text.Shakespeare.Base+                     Text.Shakespeare+    other-modules:   Text.Hamlet.Parse+                     Text.Css+                     Text.MkSizeType+                     Text.IndentToBrace+                     Text.CssCommon     ghc-options:     -Wall      if flag(test_export)@@ -45,13 +74,66 @@      extensions: TemplateHaskell +    if impl(ghc >= 7.4)+       cpp-options: -DGHC_7_4++    if os(windows)+      CPP-Options: "-DWINDOWS"++    if flag(test_coffee)+        cpp-options: -DTEST_COFFEE++    if flag(test_roy)+        cpp-options: -DTEST_ROY++    if flag(test_export)+        cpp-options: -DTEST_EXPORT+ Flag test_export   default: False +flag test_coffee+    description: render tests through coffeescript render function+    -- cabal configure --enable-tests -ftest_coffee && cabal build && dist/build/test/test+    default: False++flag test_roy+    description: render tests through coffeescript render function+    -- cabal configure --enable-tests -ftest_coffee && cabal build && dist/build/test/test+    default: False++flag servius+    description: build the servius web server+    default: True++Executable servius+  Main-is:       servius.hs+  hs-source-dirs: app+  if flag(servius)+      buildable: True+  else+      buildable: False+  Build-depends: base            >= 4                  && < 5+               , wai-app-static  >= 2.0.1              && < 2.1+               , bytestring      >= 0.9.1.4+               , text            >= 0.7+               , http-types+               , shakespeare+               , wai             >= 1.3                && < 2.2+               , blaze-html      >= 0.5+               , blaze-builder+ test-suite test-    hs-source-dirs: ., test-    main-is: test.hs-    other-modules:  ShakespeareBaseTest+    hs-source-dirs: test+    main-is: Spec.hs+    other-modules:  Text.Shakespeare.BaseSpec+                    Text.Shakespeare.I18NSpec+                    Text.Shakespeare.JsSpec+                    Text.Shakespeare.TextSpec+                    Text.Shakespeare.CssSpec+                    Text.Shakespeare.HamletSpec+                    Quoter+                    HamletTestTypes      cpp-options: -DTEST_EXPORT @@ -59,6 +141,7 @@      ghc-options:   -Wall     build-depends: base             >= 4       && < 5+                 , shakespeare                  , time             >= 1                  , system-filepath  >= 0.4                  , system-fileio    >= 0.3@@ -69,6 +152,14 @@                  , process                  , template-haskell                  , ghc-prim+                 , HUnit+                 , bytestring+                 , directory+                 , aeson+                 , transformers+                 , blaze-markup+                 , blaze-html+                 , exceptions      extensions: TemplateHaskell
+ test-messages/en.msg view
@@ -0,0 +1,29 @@+NotAnAdmin: You must be an administrator to access this page.
+
+WelcomeHomepage: Welcome to the homepage
+SeeArchive: See the archive
+
+NoEntries: There are no entries in the blog
+LoginToPost: Admins can login to post
+NewEntry: Post to blog
+NewEntryTitle: Title
+NewEntryContent: Content
+
+PleaseCorrectEntry: Your submitted entry had some errors, please correct and try again.
+EntryCreated title@Text: Your new blog post, #{title}, has been created
+
+EntryTitle title@Text: Blog post: #{title}
+CommentsHeading: Comments
+NoComments: There are no comments
+AddCommentHeading: Add a Comment
+LoginToComment: You must be logged in to comment
+AddCommentButton: Add comment
+
+CommentName: Your display name
+CommentText: Comment
+CommentAdded: Your comment has been added
+PleaseCorrectComment: Your submitted comment had some errors, please correct and try again.
+
+HomepageTitle: Yesod Blog Demo
+BlogArchiveTitle: Blog Archive
+
− test.hs 
@@ -1,5 +0,0 @@-import Test.Hspec.Monadic-import ShakespeareBaseTest (specs)--main :: IO ()-main = hspec $ specs
+ test/HamletTestTypes.hs view
@@ -0,0 +1,7 @@+module HamletTestTypes where++-- This record is defined outside of the HamletTest module+-- because record wildcards use 'reify' and reify doesn't+-- see types defined in the local module.++data ARecord = ARecord { field1 :: Int, field2 :: Bool }
+ test/Quoter.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+module Quoter (quote, quoteFile, quoteFileReload) where++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote (QuasiQuoter (..))++#ifdef TEST_COFFEE+import Text.Coffee+import Text.Coffee (coffeeSettings)+import Text.Shakespeare (shakespeare)+#else+#  ifdef TEST_ROY+import Text.Roy+#  else+import Text.Julius+#  endif+#endif++quote :: QuasiQuoter+quoteFile :: FilePath -> Q Exp+quoteFileReload :: FilePath -> Q Exp+#ifdef TEST_COFFEE+translate ('#':'{':rest) = translate $ '%':'{':translate rest+translate (c:other) = c:translate other+translate [] = []++quote = QuasiQuoter { quoteExp = \s -> do+    rs <- coffeeSettings+    quoteExp (shakespeare rs) (translate s)+    }++quoteFile = coffeeFile+quoteFileReload = coffeeFileReload+#else+#  ifdef TEST_ROY+quote = roy+quoteFile = royFile+quoteFileReload = royFileReload+#  else+quote = julius+quoteFile = juliusFile+quoteFileReload = juliusFileReload+#  endif+#endif
− test/ShakespeareBaseTest.hs 
@@ -1,82 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module ShakespeareBaseTest (specs) where--import Test.Hspec-import Text.Shakespeare--import Text.ParserCombinators.Parsec (parse, ParseError, (<|>))-import Text.Shakespeare.Base (parseVarString, parseUrlString, parseIntString)-import Text.Shakespeare (preFilter, defaultShakespeareSettings, ShakespeareSettings(..), PreConvert(..), PreConversion(..))-import Language.Haskell.TH.Syntax (Exp (VarE))-import Data.Text.Lazy.Builder (fromString, toLazyText, fromLazyText)-import Data.Text.Lazy (pack)---- run :: Text.Parsec.Prim.Parsec Text.Parsec.Pos.SourceName () c -> Text.Parsec.Pos.SourceName -> c--specs :: Spec-specs = describe "shakespeare-js" $ do-  let preFilterN = preFilter Nothing-  {--  it "parseStrings" $ do-    run varString "%{var}" `shouldBe` Right "%{var}"-    run urlString "@{url}" `shouldBe` Right "@{url}"-    run intString "^{int}" `shouldBe` Right "^{int}"--    run (varString <|> urlString <|> intString) "@{url} #{var}" `shouldBe` Right "@{url}"-  -}--  it "preFilter off" $ do-    preFilterN defaultShakespeareSettings template-      `shouldReturn` template--  it "preFilter on" $ do-    preFilterN preConversionSettings template `shouldReturn`-      "(function(shakespeare_var_var, shakespeare_var_url, shakespeare_var_int){unchanged shakespeare_var_var shakespeare_var_url shakespeare_var_int})(#{var}, @{url}, ^{int});\n"--  it "preFilter ignore quotes" $ do-    preFilterN preConversionSettings templateQuote `shouldReturn`-      "(function(shakespeare_var_url){unchanged '#{var}' shakespeare_var_url '^{int}'})(@{url});\n"--  it "preFilter ignore comments" $ do-    preFilterN preConversionSettings templateCommented-      `shouldReturn` "unchanged & '#{var}' @{url} '^{int}'"--  it "reload" $ do-    let helper input = $(do-            shakespeareFileReload defaultShakespeareSettings-                { toBuilder = VarE 'pack-                , wrap = VarE 'toLazyText-                , unwrap = VarE 'fromLazyText-                } "test/reload.txt") undefined-    helper "here1" `shouldBe` pack "here1\n"-    helper "here2" `shouldBe` pack "here2\n"--  where-    varString = parseVarString '%'-    urlString = parseUrlString '@' '?'-    intString = parseIntString '^'--    preConversionSettings = defaultShakespeareSettings {-      preConversion = Just PreConvert {-          preConvert = Id-        , preEscapeIgnoreBalanced = "'\""-        , preEscapeIgnoreLine = "&"-        , wrapInsertion = Just WrapInsertion { -            wrapInsertionIndent = Nothing-          , wrapInsertionStartBegin = "function("-          , wrapInsertionSeparator = ", "-          , wrapInsertionStartClose = "){"-          , wrapInsertionEnd = "}"-          , wrapInsertionAddParens = True-          }-        }-    }-    template  = "unchanged #{var} @{url} ^{int}"-    templateQuote = "unchanged '#{var}' @{url} '^{int}'"-    templateCommented = "unchanged & '#{var}' @{url} '^{int}'"--    run parser str = eShowErrors $ parse parser str str--    eShowErrors :: Either ParseError c -> c-    eShowErrors = either (error . show) id-
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Text/Shakespeare/BaseSpec.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TemplateHaskell #-}+module Text.Shakespeare.BaseSpec (spec) where++import Test.Hspec+import Text.Shakespeare++import Text.ParserCombinators.Parsec (parse, ParseError, (<|>))+import Text.Shakespeare.Base (parseVarString, parseUrlString, parseIntString)+import Text.Shakespeare (preFilter, defaultShakespeareSettings, ShakespeareSettings(..), PreConvert(..), PreConversion(..))+import Language.Haskell.TH.Syntax (Exp (VarE))+import Data.Text.Lazy.Builder (fromString, toLazyText, fromLazyText)+import Data.Text.Lazy (pack)++-- run :: Text.Parsec.Prim.Parsec Text.Parsec.Pos.SourceName () c -> Text.Parsec.Pos.SourceName -> c++spec :: Spec+spec = describe "shakespeare-js" $ do+  let preFilterN = preFilter Nothing+  {-+  it "parseStrings" $ do+    run varString "%{var}" `shouldBe` Right "%{var}"+    run urlString "@{url}" `shouldBe` Right "@{url}"+    run intString "^{int}" `shouldBe` Right "^{int}"++    run (varString <|> urlString <|> intString) "@{url} #{var}" `shouldBe` Right "@{url}"+  -}++  it "preFilter off" $ do+    preFilterN defaultShakespeareSettings template+      `shouldReturn` template++  it "preFilter on" $ do+    preFilterN preConversionSettings template `shouldReturn`+      "(function(shakespeare_var_var, shakespeare_var_url, shakespeare_var_int){unchanged shakespeare_var_var shakespeare_var_url shakespeare_var_int})(#{var}, @{url}, ^{int});\n"++  it "preFilter ignore quotes" $ do+    preFilterN preConversionSettings templateQuote `shouldReturn`+      "(function(shakespeare_var_url){unchanged '#{var}' shakespeare_var_url '^{int}'})(@{url});\n"++  it "preFilter ignore comments" $ do+    preFilterN preConversionSettings templateCommented+      `shouldReturn` "unchanged & '#{var}' @{url} '^{int}'"++  it "reload" $ do+    let helper input = $(do+            shakespeareFileReload defaultShakespeareSettings+                { toBuilder = VarE 'pack+                , wrap = VarE 'toLazyText+                , unwrap = VarE 'fromLazyText+                } "test/reload.txt") undefined+    helper "here1" `shouldBe` pack "here1\n"+    helper "here2" `shouldBe` pack "here2\n"++  where+    varString = parseVarString '%'+    urlString = parseUrlString '@' '?'+    intString = parseIntString '^'++    preConversionSettings = defaultShakespeareSettings {+      preConversion = Just PreConvert {+          preConvert = Id+        , preEscapeIgnoreBalanced = "'\""+        , preEscapeIgnoreLine = "&"+        , wrapInsertion = Just WrapInsertion { +            wrapInsertionIndent = Nothing+          , wrapInsertionStartBegin = "function("+          , wrapInsertionSeparator = ", "+          , wrapInsertionStartClose = "){"+          , wrapInsertionEnd = "}"+          , wrapInsertionAddParens = True+          }+        }+    }+    template  = "unchanged #{var} @{url} ^{int}"+    templateQuote = "unchanged '#{var}' @{url} '^{int}'"+    templateCommented = "unchanged & '#{var}' @{url} '^{int}'"++    run parser str = eShowErrors $ parse parser str str++    eShowErrors :: Either ParseError c -> c+    eShowErrors = either (error . show) id+
+ test/Text/Shakespeare/CssSpec.hs view
@@ -0,0 +1,583 @@+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -O0 #-}
+module Text.Shakespeare.CssSpec (spec) where
+
+import Test.HUnit hiding (Test)
+import Test.Hspec
+
+import Prelude hiding (reverse)
+import Text.Cassius
+import Text.Lucius
+import Data.List (intercalate)
+import qualified Data.Text.Lazy as T
+import qualified Data.Text as TS
+import qualified Data.List
+import qualified Data.List as L
+import Data.Text (Text, pack, unpack)
+import Data.Monoid (mappend)
+
+spec :: Spec
+spec = do
+  describe "shakespeare-css" $ do
+    it "cassius" caseCassius
+    it "cassiusFile" caseCassiusFile
+    it "cassius single comment" caseCassiusSingleComment
+    it "cassius leading comment" caseCassiusLeadingComment
+
+    it "cassiusFileDebug" $ do
+      let var = "var"
+      let selector = "foo"
+      let urlp = (Home, [(pack "p", pack "q")])
+      flip celper $(cassiusFileDebug "test/cassiuses/external1.cassius") $ concat
+          [ "foo {\n    background: #000;\n    bar: baz;\n    color: #F00;\n}\n"
+          , "bin {\n"
+          , "    background-image: url(url);\n"
+          , "    bar: bar;\n    color: #7F6405;\n    fvarx: someval;\n    unicode-test: שלום;\n"
+          , "    urlp: url(url?p=q);\n}\n"
+          ]
+
+{- TODO
+    it "cassiusFileDebugChange" $ do
+    let var = "var"
+    writeFile "test/cassiuses/external2.cassius" "foo\n  #{var}: 1"
+    celper "foo{var:1}" $(cassiusFileDebug "test/cassiuses/external2.cassius")
+    writeFile "test/cassiuses/external2.cassius" "foo\n  #{var}: 2"
+    celper "foo{var:2}" $(cassiusFileDebug "test/cassiuses/external2.cassius")
+    writeFile "test/cassiuses/external2.cassius" "foo\n  #{var}: 1"
+    -}
+
+
+    it "comments" $ do
+      -- FIXME reconsider Hamlet comment syntax?
+      celper "" [cassius|/* this is a comment */
+/* another comment */
+/*a third one*/|]
+
+
+    it "cassius pseudo-class" $
+      flip celper [cassius|
+a:visited
+    color: blue
+|] "a:visited{color:blue}"
+
+
+    it "ignores a blank line" $ do
+      celper "foo{bar:baz}" [cassius|
+foo
+
+    bar: baz
+
+|]
+
+
+    it "leading spaces" $
+      celper "foo{bar:baz}" [cassius|
+  foo
+    bar: baz
+|]
+
+
+    it "cassius all spaces" $
+      celper "h1{color:green }" [cassius|
+    h1
+        color: green 
+    |]
+
+
+    it "cassius whitespace and colons" $ do
+      celper "h1:hover{color:green ;font-family:sans-serif}" [cassius|
+    h1:hover
+        color: green 
+        font-family:sans-serif
+    |]
+
+
+    it "cassius trailing comments" $
+      celper "h1:hover{color:green ;font-family:sans-serif}" [cassius|
+    h1:hover /* Please ignore this */
+        color: green /* This is a comment. */
+        /* Obviously this is ignored too. */
+        font-family:sans-serif
+    |]
+
+    it "cassius nesting" $
+      celper "foo bar{baz:bin}" [cassius|
+    foo
+        bar
+            baz: bin
+    |]
+
+    it "cassius variable" $
+      celper "foo bar{baz:bin}" [cassius|
+    @binvar: bin
+    foo
+        bar
+            baz: #{binvar}
+    |]
+
+    it "cassius trailing semicolon" $
+      celper "foo bar{baz:bin}" [cassius|
+    @binvar: bin
+    foo
+        bar
+            baz: #{binvar};
+    |]
+
+
+
+    it "cassius module names" $ do
+      let foo = "foo"
+          dub = 3.14::Double
+          int = -5::Int
+      celper "sel{bar:oof oof 3.14 -5}"
+        [cassius|
+sel
+    bar: #{Data.List.reverse foo} #{L.reverse foo} #{show dub} #{show int}
+|]
+
+
+
+    it "single dollar at and caret" $ do
+      celper "sel{att:$@^}" [cassius|
+sel
+    att: $@^
+|]
+
+  {-
+      celper "sel{att:#{@{^{}" [cassius|
+sel
+    att: #\{@\{^{
+|]
+-}
+
+
+    it "dollar operator" $ do
+      let val = (1, (2, 3)) :: (Integer, (Integer, Integer))
+      celper "sel{att:2}" [cassius|
+sel
+    att: #{ show $ fst $ snd val }
+|]
+      celper "sel{att:2}" [cassius|
+sel
+    att: #{ show $ fst $ snd $ val}
+|]
+
+
+
+    it "embedded slash" $ do
+      celper "sel{att:///}" [cassius|
+sel
+    att: ///
+|]
+
+
+
+
+
+
+    it "multi cassius" $ do
+      celper "foo{bar:baz;bar:bin}" [cassius|
+foo
+    bar: baz
+    bar: bin
+|]
+
+
+
+
+
+
+    it "lucius" $ do
+      let var = "var"
+      let urlp = (Home, [(pack "p", pack "q")])
+      flip celper [lucius|
+foo {
+    background: #{colorBlack};
+    bar: baz;
+    color: #{colorRed};
+}
+bin {
+        background-image: url(@{Home});
+        bar: bar;
+        color: #{(((Color 127) 100) 5)};
+        f#{var}x: someval;
+        unicode-test: שלום;
+        urlp: url(@?{urlp});
+}
+|] $ concat
+        [ "foo{background:#000;bar:baz;color:#F00}"
+        , "bin{"
+        , "background-image:url(url);"
+        , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;"
+        , "urlp:url(url?p=q)}"
+        ]
+
+
+
+    it "lucius file" $ do
+      let var = "var"
+      let urlp = (Home, [(pack "p", pack "q")])
+      flip celper $(luciusFile "test/cassiuses/external1.lucius") $ concat
+          [ "foo{background:#000;bar:baz;color:#F00}"
+          , "bin{"
+          , "background-image:url(url);"
+          , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;"
+          , "urlp:url(url?p=q)}"
+          ]
+
+    it "lucius file debug" caseLuciusFileDebug
+
+
+
+
+    it "lucius nested" $ do
+      celper "foo bar{baz:bin}" $(luciusFile "test/cassiuses/external-nested.lucius")
+      celper "foo bar {\n    baz: bin;\n}\n" $(luciusFileDebug "test/cassiuses/external-nested.lucius")
+      celper "foo bar{baz:bin}" [lucius|
+        foo {
+            bar {
+                baz: bin;
+            }
+        }
+        |]
+      celper "foo1 bar,foo2 bar{baz:bin}" [lucius|
+        foo1, foo2 {
+            bar {
+                baz: bin;
+            }
+        }
+        |]
+
+
+    it "lucius charset" $ do
+      celper (concat ["@charset \"utf-8\";"
+        , "#content ul{list-style:none;padding:0 5em}"
+        , "#content ul li{padding:1em 0}"
+        , "#content ul li a{color:#419a56;font-family:'TeXGyreHerosBold',helvetica,arial,sans-serif;font-weight:bold;text-transform:uppercase;white-space:nowrap}"
+        ]) [lucius|
+@charset "utf-8";
+#content ul
+{
+    list-style: none;
+    padding: 0 5em;
+    li
+    {
+        padding: 1em 0;
+        a
+        {
+            color: #419a56;
+            font-family: 'TeXGyreHerosBold',helvetica,arial,sans-serif;
+            font-weight: bold;
+            text-transform: uppercase;
+            white-space: nowrap;
+        }
+    }
+}
+|]
+
+    it "lucius media" $ do
+      celper "@media only screen{foo bar{baz:bin}}" $(luciusFile "test/cassiuses/external-media.lucius")
+      celper "@media only screen {\n    foo bar {\n        baz: bin;\n    }\n}\n" $(luciusFileDebug "test/cassiuses/external-media.lucius")
+      celper "@media only screen{foo bar{baz:bin}}" [lucius|
+        @media only screen{
+            foo {
+                bar {
+                    baz: bin;
+                }
+            }
+        }
+        |]
+
+
+    {-
+    it "cassius removes whitespace" $ do
+      celper "foo{bar:baz}" [cassius|
+      foo
+          bar     :    baz
+      |]
+      -}
+
+
+
+
+
+    it "lucius trailing comments" $
+      celper "foo{bar:baz}" [lucius|foo{bar:baz;}/* ignored*/|]
+
+    it "lucius variables" $ celper "foo{bar:baz}" [lucius|
+@myvar: baz;
+foo {
+    bar: #{myvar};
+}
+|]
+    it "lucius CDO/CDC tokens" $
+       celper "*{a:b}" [lucius|
+<!-- --> <!--
+* {
+  a: b;
+}
+-->
+|]
+    it "lucius @import statements" $
+      celper "@import url(\"bla.css\");" [lucius|
+@import url("bla.css");
+|]
+    it "lucius simple escapes" $
+      celper "*{a:test}" [lucius|
+* {
+  a: t\65 st;
+}
+|]
+    it "lucius bounded escapes" $
+      celper "*{a:teft}" [lucius|
+* {
+  a: t\000065ft;
+}
+|]
+    it "lucius case-insensitive keywords" $
+       celper "@media foo {}" [lucius|
+@MeDIa foo {
+}
+|]
+    it "lucius @page statements" $
+       celper "@page :right{a:b;c:d}" [lucius|
+@page :right {
+a:b;
+c:d;
+}
+|]
+    it "lucius @font-face statements" $
+       celper "@font-face{a:b;c:d}" [lucius|
+@font-face {
+a:b;
+c:d;
+}
+|]
+    it "lucius runtime" $ Right (T.pack "foo {\n    bar: baz;\n}\n") @=? luciusRT (T.pack "foo { bar: #{myvar}}") [(TS.pack "myvar", TS.pack "baz")]
+    it "lucius runtime variables" $ Right (T.pack "foo {\n    bar: baz;\n}\n") @=? luciusRT (T.pack "@dummy: dummy; @myvar: baz; @dummy2: dummy; foo { bar: #{myvar}}") []
+    it "lucius whtiespace" $ Right (T.pack "@media foo {\n    bar {\n        baz: bin;\n        baz2: bin2;\n    }\n}\n")
+      @=? luciusRT (T.pack "@media foo{bar{baz:bin;baz2:bin2}}") []
+    it "variables inside value" $
+        celper "foo{foo:XbarY}" [lucius|
+@bar: bar;
+foo { foo:X#{bar}Y; }
+|]
+    it "variables in media selector" $
+        celper "@media (max-width: 400px){foo{color:red}}" [lucius|
+@mobileWidth: 400px;
+@media (max-width: #{mobileWidth}){ foo { color: red; } }
+|]
+    it "URLs in import" $ celper
+        "@import url(\"suburl\");" [lucius|
+@import url("@{Sub SubUrl}");
+|]
+    it "vars in charset" $ do
+      let charset = "mycharset"
+      celper "@charset mycharset;" [lucius|
+@charset #{charset};
+|]
+    it "keyframes" $ celper
+        "@keyframes mymove {from{top:0px}to{top:200px}}" [lucius|
+@keyframes mymove {
+    from {
+        top: 0px;
+    }
+    to {
+        top: 200px;
+    }
+}
+|]
+    it "prefixed keyframes" $ celper
+        "@-webkit-keyframes mymove {from{top:0px}to{top:200px}}" [lucius|
+@-webkit-keyframes mymove {
+    from {
+        top: 0px;
+    }
+    to {
+        top: 200px;
+    }
+}
+|]
+    it "mixins" $ do
+        let bins = [luciusMixin|
+                   bin:bin2;
+                   /* FIXME not currently implementing sublocks in mixins
+                   foo2 {
+                       x: y
+                   }
+                   */
+                   |] :: Mixin
+        -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius|
+        celper "foo{bar:baz;bin:bin2}" [lucius|
+            foo {
+                bar: baz;
+                ^{bins}
+            }
+        |]
+    it "more complicated mixins" $ do
+        let transition val =
+                [luciusMixin|
+                    -webkit-transition: #{val};
+                    -moz-transition: #{val};
+                    -ms-transition: #{val};
+                    -o-transition: #{val};
+                    transition: #{val};
+                |]
+
+        celper ".some-class{-webkit-transition:all 4s ease;-moz-transition:all 4s ease;-ms-transition:all 4s ease;-o-transition:all 4s ease;transition:all 4s ease}"
+                [lucius|
+                    .some-class {
+                        ^{transition "all 4s ease"}
+                    }
+                |]
+
+    it "runtime mixin" $ do
+        let bins = [luciusMixin|
+                   bin:bin2;
+                   /* FIXME not currently implementing sublocks in mixins
+                   foo2 {
+                       x: y
+                   }
+                   */
+                   |] :: Mixin
+        -- No sublocks celper "foo{bar:baz;bin:bin2}foo foo2{x:y}" [lucius|
+        Right (T.pack "foo{bar:baz;bin:bin2}") @=? luciusRTMixin
+            (T.pack "foo { bar: baz; ^{bins} }")
+            True
+            [(TS.pack "bins", RTVMixin bins)]
+
+    it "luciusFileReload mixin" $ do
+      let mixin = [luciusMixin|foo:bar;baz:bin|]
+      flip celper $(luciusFileReload "test/cassiuses/mixin.lucius") $ concat
+          [ "selector {\n    foo: bar;\n    baz: bin;\n}\n"
+          ]
+
+    it "cassiusFileReload with import URL" $ do
+      celper
+        "@import url(url);\n"
+        $(cassiusFileReload "test/cassiuses/reload-import.cassius")
+
+    it "& subblocks" $
+        celper "foo:bar{baz:bin}"
+        [lucius|
+            foo {
+                &:bar {
+                    baz: bin;
+                }
+            }
+        |]
+
+data Url = Home | Sub SubUrl
+data SubUrl = SubUrl
+render :: Url -> [(Text, Text)] -> Text
+render Home qs = pack "url" `mappend` showParams qs
+render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs
+
+showParams :: [(Text, Text)] -> Text
+showParams [] = pack ""
+showParams z =
+    pack $ '?' : intercalate "&" (map go z)
+  where
+    go (x, y) = go' x ++ '=' : go' y
+    go' = concatMap encodeUrlChar . unpack
+
+-- | 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]
+
+
+
+celper :: String -> CssUrl Url -> Assertion
+celper res h = do
+    let x = renderCssUrl render h
+    T.pack res @=? x
+
+caseCassius :: Assertion
+caseCassius = do
+    let var = "var"
+    let urlp = (Home, [(pack "p", pack "q")])
+    flip celper [cassius|
+foo
+    background: #{colorBlack}
+    bar: baz
+    color: #{colorRed}
+bin
+        background-image: url(@{Home})
+        bar: bar
+        color: #{(((Color 127) 100) 5)}
+        f#{var}x: someval
+        unicode-test: שלום
+        urlp: url(@?{urlp})
+|] $ concat
+        [ "foo{background:#000;bar:baz;color:#F00}"
+        , "bin{"
+        , "background-image:url(url);"
+        , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;"
+        , "urlp:url(url?p=q)}"
+        ]
+
+caseCassiusFile :: Assertion
+caseCassiusFile = do
+    let var = "var"
+    let selector = "foo"
+    let urlp = (Home, [(pack "p", pack "q")])
+    flip celper $(cassiusFile "test/cassiuses/external1.cassius") $ concat
+        [ "foo{background:#000;bar:baz;color:#F00}"
+        , "bin{"
+        , "background-image:url(url);"
+        , "bar:bar;color:#7F6405;fvarx:someval;unicode-test:שלום;"
+        , "urlp:url(url?p=q)}"
+        ]
+
+caseCassiusSingleComment :: Assertion
+caseCassiusSingleComment =
+    flip celper [cassius|
+        /*
+        this is a comment
+        */
+        |] ""
+
+caseCassiusLeadingComment :: Assertion
+caseCassiusLeadingComment =
+    flip celper [cassius|
+        /*
+        this is a comment
+        */
+        sel1
+            foo: bar
+        sel2
+            baz: bin
+        |] "sel1{foo:bar}sel2{baz:bin}"
+
+instance Show Url where
+    show _ = "FIXME remove this instance show Url"
+
+
+caseLuciusFileDebug :: Assertion
+caseLuciusFileDebug = do
+    let var = "var"
+    writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}"
+    celper "foo {\n    var: 1;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius")
+    writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 2}"
+    celper "foo {\n    var: 2;\n}\n" $(luciusFileDebug "test/cassiuses/external2.lucius")
+    writeFile "test/cassiuses/external2.lucius" "foo{#{var}: 1}"
+ test/Text/Shakespeare/HamletSpec.hs view
@@ -0,0 +1,1068 @@+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Text.Shakespeare.HamletSpec (spec) where
+
+import HamletTestTypes (ARecord(..))
+
+import Test.HUnit hiding (Test)
+import Test.Hspec
+
+import Prelude hiding (reverse)
+import Text.Hamlet
+import Text.Hamlet.RT
+import Data.List (intercalate)
+import qualified Data.Text.Lazy as T
+import qualified Data.List
+import qualified Data.List as L
+import qualified Data.Map as Map
+import Data.Text (Text, pack, unpack)
+import Data.Monoid (mappend,mconcat)
+import qualified Data.Set as Set
+import qualified Text.Blaze.Html.Renderer.Text
+import Text.Blaze.Html (toHtml)
+import Text.Blaze.Internal (preEscapedString)
+import Text.Blaze
+
+spec = do
+  describe "hamlet" $ do
+    it "empty" caseEmpty
+    it "static" caseStatic
+    it "tag" caseTag
+    it "var" caseVar
+    it "var chain " caseVarChain
+    it "url" caseUrl
+    it "url chain " caseUrlChain
+    it "embed" caseEmbed
+    it "embed chain " caseEmbedChain
+    it "if" caseIf
+    it "if chain " caseIfChain
+    it "else" caseElse
+    it "else chain " caseElseChain
+    it "elseif" caseElseIf
+    it "elseif chain " caseElseIfChain
+    it "list" caseList
+    it "list chain" caseListChain
+    it "with" caseWith
+    it "with multi" caseWithMulti
+    it "with chain" caseWithChain
+    it "with comma string" caseWithCommaString
+    it "with multi scope" caseWithMultiBindingScope
+    it "script not empty" caseScriptNotEmpty
+    it "meta empty" caseMetaEmpty
+    it "input empty" caseInputEmpty
+    it "multiple classes" caseMultiClass
+    it "attrib order" caseAttribOrder
+    it "nothing" caseNothing
+    it "nothing chain " caseNothingChain
+    it "just" caseJust
+    it "just chain " caseJustChain
+    it "constructor" caseConstructor
+    it "url + params" caseUrlParams
+    it "escape" caseEscape
+    it "empty statement list" caseEmptyStatementList
+    it "attribute conditionals" caseAttribCond
+    it "non-ascii" caseNonAscii
+    it "maybe function" caseMaybeFunction
+    it "trailing dollar sign" caseTrailingDollarSign
+    it "non leading percent sign" caseNonLeadingPercent
+    it "quoted attributes" caseQuotedAttribs
+    it "spaced derefs" caseSpacedDerefs
+    it "attrib vars" caseAttribVars
+    it "strings and html" caseStringsAndHtml
+    it "nesting" caseNesting
+    it "trailing space" caseTrailingSpace
+    it "currency symbols" caseCurrency
+    it "external" caseExternal
+    it "parens" caseParens
+    it "hamlet literals" caseHamletLiterals
+    it "hamlet' and xhamlet'" caseHamlet'
+    it "hamlet tuple" caseTuple
+    it "complex pattern" caseComplex
+    it "record pattern" caseRecord
+    it "record wildcard pattern #1" caseRecordWildCard
+    it "record wildcard pattern #2" caseRecordWildCard1
+
+
+
+    it "comments" $ do
+    -- FIXME reconsider Hamlet comment syntax?
+      helper "" [hamlet|$# this is a comment
+$# another comment
+$#a third one|]
+
+
+    it "ignores a blank line" $ do
+      helper "<p>foo</p>\n" [hamlet|
+<p>
+
+    foo
+
+
+|]
+
+
+
+
+    it "angle bracket syntax" $
+      helper "<p class=\"foo\" height=\"100\"><span id=\"bar\" width=\"50\">HELLO</span></p>"
+        [hamlet|
+$newline never
+<p.foo height="100">
+    <span #bar width=50>HELLO
+|]
+
+
+
+    it "hamlet module names" $ do
+      let foo = "foo"
+      helper "oof oof 3.14 -5"
+        [hamlet|
+$newline never
+#{Data.List.reverse foo} #
+#{L.reverse foo} #
+#{show 3.14} #{show -5}|]
+
+
+
+
+
+    it "single dollar at and caret" $ do
+      helper "$@^" [hamlet|\$@^|]
+
+      helper "#{@{^{" [hamlet|#\{@\{^\{|]
+
+
+    it "dollar operator" $ do
+      let val = (1, (2, 3))
+      helper "2" [hamlet|#{ show $ fst $ snd val }|]
+      helper "2" [hamlet|#{ show $ fst $ snd $ val}|]
+
+
+    it "in a row" $ do
+      helper "1" [hamlet|#{ show $ const 1 2 }|]
+
+
+    it "embedded slash" $ do
+      helper "///" [hamlet|///|]
+
+{- compile-time error
+    it "tag with slash" $ do
+    helper "" [hamlet|
+<p>
+  Text
+</p>
+|]
+-}
+
+    it "string literals" $ do
+      helper "string" [hamlet|#{"string"}|]
+      helper "string" [hamlet|#{id "string"}|]
+      helper "gnirts" [hamlet|#{L.reverse $ id "string"}|]
+      helper "str&quot;ing" [hamlet|#{"str\"ing"}|]
+      helper "str&lt;ing" [hamlet|#{"str<ing"}|]
+
+
+    it "interpolated operators" $ do
+      helper "3" [hamlet|#{show $ (+) 1 2}|]
+      helper "6" [hamlet|#{show $ sum $ (:) 1 ((:) 2 $ return 3)}|]
+
+
+    it "HTML comments" $ do
+      helper "<p>1</p><p>2 not ignored</p>" [hamlet|
+$newline never
+<p>1
+<!-- ignored comment -->
+<p>
+    2
+    <!-- ignored --> not ignored<!-- ignored -->
+|]
+
+    it "Keeps SSI includes" $
+      helper "<!--# SSI -->" [hamlet|<!--# SSI -->|]
+
+
+
+    it "nested maybes" $ do
+      let muser = Just "User" :: Maybe String
+          mprof = Nothing :: Maybe Int
+          m3 = Nothing :: Maybe String
+      helper "justnothing" [hamlet|
+$maybe user <- muser
+    $maybe profile <- mprof
+        First two are Just
+        $maybe desc <- m3
+            \ and left us a description:
+            <p>#{desc}
+        $nothing
+        and has left us no description.
+    $nothing
+        justnothing
+$nothing
+    <h1>No such Person exists.
+   |]
+
+
+    it "maybe with qualified constructor" $ do
+        helper "5" [hamlet|
+            $maybe HamletTestTypes.ARecord x y <- Just $ ARecord 5 True
+                \#{x}
+        |]
+
+    it "record with qualified constructor" $ do
+        helper "5" [hamlet|
+            $maybe HamletTestTypes.ARecord {..} <- Just $ ARecord 5 True
+                \#{field1}
+        |]
+
+
+
+
+    it "conditional class" $ do
+      helper "<p class=\"current\"></p>\n"
+        [hamlet|<p :False:.ignored :True:.current>|]
+
+      helper "<p class=\"1 3 2 4\"></p>\n"
+        [hamlet|<p :True:.1 :True:class=2 :False:.a :False:class=b .3 class=4>|]
+
+      helper "<p class=\"foo bar baz\"></p>\n"
+        [hamlet|<p class=foo class=bar class=baz>|]
+
+
+
+
+    it "forall on Foldable" $ do
+      let set = Set.fromList [1..5 :: Int]
+      helper "12345" [hamlet|
+$forall x <- set
+  #{x}
+|]
+
+
+
+    it "non-poly HTML" $ do
+      helperHtml "<h1>HELLO WORLD</h1>\n" [shamlet|
+  <h1>HELLO WORLD
+  |]
+      helperHtml "<h1>HELLO WORLD</h1>\n" $(shamletFile "test/hamlets/nonpolyhtml.hamlet")
+      helper "<h1>HELLO WORLD</h1>\n" $(hamletFileReload "test/hamlets/nonpolyhtml.hamlet")
+
+
+    it "non-poly Hamlet" $ do
+      let embed = [hamlet|<p>EMBEDDED|]
+      helper "<h1>url</h1>\n<p>EMBEDDED</p>\n" [hamlet|
+  <h1>@{Home}
+  ^{embed}
+  |]
+      helper "<h1>url</h1>\n" $(hamletFile "test/hamlets/nonpolyhamlet.hamlet")
+      helper "<h1>url</h1>\n" $(hamletFileReload "test/hamlets/nonpolyhamlet.hamlet")
+
+    it "non-poly IHamlet" $ do
+      let embed = [ihamlet|<p>EMBEDDED|]
+      ihelper "<h1>Adios</h1>\n<p>EMBEDDED</p>\n" [ihamlet|
+  <h1>_{Goodbye}
+  ^{embed}
+  |]
+      ihelper "<h1>Hola</h1>\n" $(ihamletFile "test/hamlets/nonpolyihamlet.hamlet")
+      ihelper "<h1>Hola</h1>\n" $(ihamletFileReload "test/hamlets/nonpolyihamlet.hamlet")
+
+    it "pattern-match tuples: forall" $ do
+      let people = [("Michael", 26), ("Miriam", 25)]
+      helper "<dl><dt>Michael</dt><dd>26</dd><dt>Miriam</dt><dd>25</dd></dl>" [hamlet|
+$newline never
+<dl>
+    $forall (name, age) <- people
+        <dt>#{name}
+        <dd>#{show age}
+|]
+    it "pattern-match tuples: maybe" $ do
+      let people = Just ("Michael", 26)
+      helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet|
+$newline never
+<dl>
+    $maybe (name, age) <- people
+        <dt>#{name}
+        <dd>#{show age}
+|]
+    it "pattern-match tuples: with" $ do
+      let people = ("Michael", 26)
+      helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet|
+$newline never
+<dl>
+    $with (name, age) <- people
+        <dt>#{name}
+        <dd>#{show age}
+|]
+    it "list syntax for interpolation" $ do
+      helper "<ul><li>1</li><li>2</li><li>3</li></ul>" [hamlet|
+$newline never
+<ul>
+    $forall num <- [1, 2, 3]
+        <li>#{show num}
+|]
+    it "infix operators" $
+      helper "5" [hamlet|#{show $ (4 + 5) - (2 + 2)}|]
+    it "infix operators with parens" $
+      helper "5" [hamlet|#{show ((+) 1 1 + 3)}|]
+    it "doctypes" $ helper "<!DOCTYPE html>\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n" [hamlet|
+$newline never
+$doctype 5
+$doctype strict
+|]
+
+    it "case on Maybe" $
+      let nothing  = Nothing
+          justTrue = Just True
+      in helper "<br><br><br><br>" [hamlet|
+$newline never
+$case nothing
+    $of Just val
+    $of Nothing
+        <br>
+$case justTrue
+    $of Just val
+        $if val
+            <br>
+    $of Nothing
+$case (Just $ not False)
+    $of Nothing
+    $of Just val
+        $if val
+            <br>
+$case Nothing
+    $of Just val
+    $of _
+        <br>
+|]
+
+    it "case on Url" $
+      let url1 = Home
+          url2 = Sub SubUrl
+      in helper "<br>\n<br>\n" [hamlet|
+$newline always
+$case url1
+    $of Home
+        <br>
+    $of _
+$case url2
+    $of Sub sub
+        $case sub
+            $of SubUrl
+                <br>
+    $of Home
+|]
+
+    it "pattern-match constructors: forall" $ do
+      let people = [Pair "Michael" 26, Pair "Miriam" 25]
+      helper "<dl><dt>Michael</dt><dd>26</dd><dt>Miriam</dt><dd>25</dd></dl>" [hamlet|
+$newline text
+<dl>
+    $forall Pair name age <- people
+        <dt>#{name}
+        <dd>#{show age}
+|]
+    it "pattern-match constructors: maybe" $ do
+      let people = Just $ Pair "Michael" 26
+      helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet|
+$newline text
+<dl>
+    $maybe Pair name age <- people
+        <dt>#{name}
+        <dd>#{show age}
+|]
+    it "pattern-match constructors: with" $ do
+      let people = Pair "Michael" 26
+      helper "<dl><dt>Michael</dt><dd>26</dd></dl>" [hamlet|
+$newline text
+<dl>
+    $with Pair name age <- people
+        <dt>#{name}
+        <dd>#{show age}
+|]
+
+    it "multiline tags" $ helper
+      "<foo bar=\"baz\" bin=\"bin\">content</foo>\n" [hamlet|
+<foo bar=baz
+     bin=bin>content
+|]
+    it "*{...} attributes" $
+      let attrs = [("bar", "baz"), ("bin", "<>\"&")] in helper
+      "<foo bar=\"baz\" bin=\"&lt;&gt;&quot;&amp;\">content</foo>\n" [hamlet|
+<foo *{attrs}>content
+|]
+    it "blank attr values" $ helper
+      "<foo bar=\"\" baz bin=\"\"></foo>\n"
+      [hamlet|<foo bar="" baz bin=>|]
+    it "greater than in attr" $ helper
+      "<button data-bind=\"enable: someFunction() > 5\">hello</button>\n"
+      [hamlet|<button data-bind="enable: someFunction() > 5">hello|]
+    it "normal doctype" $ helper
+      "<!DOCTYPE html>\n"
+      [hamlet|<!DOCTYPE html>|]
+    it "newline style" $ helper
+      "<p>foo</p>\n<pre>bar\nbaz\nbin</pre>\n"
+      [hamlet|
+$newline always
+<p>foo
+<pre>
+    bar
+    baz
+    bin
+|]
+    it "avoid newlines" $ helper
+      "<p>foo</p><pre>barbazbin</pre>"
+      [hamlet|
+$newline always
+<p>foo#
+<pre>#
+    bar#
+    baz#
+    bin#
+|]
+    it "manual linebreaks" $ helper
+      "<p>foo</p><pre>bar\nbaz\nbin</pre>"
+      [hamlet|
+$newline never
+<p>foo
+<pre>
+    bar
+    \
+    baz
+    \
+    bin
+|]
+    it "indented newline" $ helper
+      "<p>foo</p><pre>bar\nbaz\nbin</pre>"
+      [hamlet|
+    $newline never
+    <p>foo
+    <pre>
+        bar
+        \
+        baz
+        \
+        bin
+|]
+    it "case underscore" $
+        let num = 3
+         in helper "<p>Many</p>\n" [hamlet|
+$case num
+    $of 1
+        <p>1
+    $of 2
+        <p>2
+    $of _
+        <p>Many
+|]
+    it "optional and missing classes" $
+        helper "<i>foo</i>\n" [hamlet|<i :False:.not-present>foo|]
+    it "multiple optional and missing classes" $
+        helper "<i>foo</i>\n" [hamlet|<i :False:.not-present :False:.also-not-here>foo|]
+    it "optional and present classes" $
+        helper "<i class=\"present\">foo</i>\n" [hamlet|<i :False:.not-present :True:.present>foo|]
+    it "punctuation operators #115" $
+        helper "foo"
+            [hamlet|
+                $if True && True
+                    foo
+                $else
+                    bar
+            |]
+
+    it "list syntax" $
+        helper "123"
+            [hamlet|
+                $forall x <- []
+                    ignored
+                $forall x <- [1, 2, 3]
+                    #{show x}
+            |]
+
+    it "list in attribute" $
+        let myShow :: [Int] -> String
+            myShow = show
+         in helper "<a href=\"[]\">foo</a>\n<a href=\"[1,2]\">bar</a>\n"
+            [hamlet|
+                <a href=#{myShow []}>foo
+                <a href=#{myShow [1, 2]}>bar
+            |]
+
+    it "AngularJS attribute values #122" $
+        helper "<li ng-repeat=\"addr in msgForm.new.split(/\\\\s/)\">{{addr}}</li>\n"
+            [hamlet|<li ng-repeat="addr in msgForm.new.split(/\\s/)">{{addr}}|]
+
+    it "runtime Hamlet with caret interpolation" $ do
+        let toInclude render = render (5, [("hello", "world")])
+        let renderer x y = pack $ show (x :: Int, y :: [(Text, Text)])
+            template1 = "@?{url}"
+            template2 = "foo^{toInclude}bar"
+        toInclude <- parseHamletRT defaultHamletSettings template1
+        hamletRT <- parseHamletRT defaultHamletSettings template2
+        res <- renderHamletRT hamletRT
+            [ (["toInclude"], HDTemplate toInclude)
+            , (["url"], HDUrlParams 5 [(pack "hello", pack "world")])
+            ] renderer
+        helperHtml "foo(5,[(\"hello\",\"world\")])bar" res
+
+data Pair = Pair String Int
+
+data Url = Home | Sub SubUrl
+data SubUrl = SubUrl
+render :: Url -> [(Text, Text)] -> Text
+render Home qs = pack "url" `mappend` showParams qs
+render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs
+
+showParams :: [(Text, Text)] -> Text
+showParams [] = pack ""
+showParams z =
+    pack $ '?' : intercalate "&" (map go z)
+  where
+    go (x, y) = go' x ++ '=' : go' y
+    go' = concatMap encodeUrlChar . unpack
+
+-- | 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]
+
+data Arg url = Arg
+    { getArg :: Arg url
+    , var :: Html
+    , url :: Url
+    , embed :: HtmlUrl url
+    , true :: Bool
+    , false :: Bool
+    , list :: [Arg url]
+    , nothing :: Maybe String
+    , just :: Maybe String
+    , urlParams :: (Url, [(Text, Text)])
+    }
+
+theArg :: Arg url
+theArg = Arg
+    { getArg = theArg
+    , var = toHtml "<var>"
+    , url = Home
+    , embed = [hamlet|embed|]
+    , true = True
+    , false = False
+    , list = [theArg, theArg, theArg]
+    , nothing = Nothing
+    , just = Just "just"
+    , urlParams = (Home, [(pack "foo", pack "bar"), (pack "foo1", pack "bar1")])
+    }
+
+helperHtml :: String -> Html -> Assertion
+helperHtml res h = do
+    let x = Text.Blaze.Html.Renderer.Text.renderHtml h
+    T.pack res @=? x
+
+helper :: String -> HtmlUrl Url -> Assertion
+helper res h = do
+    let x = Text.Blaze.Html.Renderer.Text.renderHtml $ h render
+    T.pack res @=? x
+
+caseEmpty :: Assertion
+caseEmpty = helper "" [hamlet||]
+
+caseStatic :: Assertion
+caseStatic = helper "some static content" [hamlet|some static content|]
+
+caseTag :: Assertion
+caseTag = do
+    helper "<p class=\"foo\"><div id=\"bar\">baz</div></p>" [hamlet|
+$newline text
+<p .foo>
+  <#bar>baz
+|]
+    helper "<p class=\"foo.bar\"><div id=\"bar\">baz</div></p>" [hamlet|
+$newline text
+<p class=foo.bar>
+  <#bar>baz
+|]
+
+caseVar :: Assertion
+caseVar = do
+    helper "&lt;var&gt;" [hamlet|#{var theArg}|]
+
+caseVarChain :: Assertion
+caseVarChain = do
+    helper "&lt;var&gt;" [hamlet|#{var (getArg (getArg (getArg theArg)))}|]
+
+caseUrl :: Assertion
+caseUrl = do
+    helper (unpack $ render Home []) [hamlet|@{url theArg}|]
+
+caseUrlChain :: Assertion
+caseUrlChain = do
+    helper (unpack $ render Home []) [hamlet|@{url (getArg (getArg (getArg theArg)))}|]
+
+caseEmbed :: Assertion
+caseEmbed = do
+    helper "embed" [hamlet|^{embed theArg}|]
+    helper "embed" $(hamletFileReload "test/hamlets/embed.hamlet")
+    ihelper "embed" $(ihamletFileReload "test/hamlets/embed.hamlet")
+
+caseEmbedChain :: Assertion
+caseEmbedChain = do
+    helper "embed" [hamlet|^{embed (getArg (getArg (getArg theArg)))}|]
+
+caseIf :: Assertion
+caseIf = do
+    helper "if" [hamlet|
+$if true theArg
+    if
+|]
+
+caseIfChain :: Assertion
+caseIfChain = do
+    helper "if" [hamlet|
+$if true (getArg (getArg (getArg theArg)))
+    if
+|]
+
+caseElse :: Assertion
+caseElse = helper "else" [hamlet|
+$if false theArg
+    if
+$else
+    else
+|]
+
+caseElseChain :: Assertion
+caseElseChain = helper "else" [hamlet|
+$if false (getArg (getArg (getArg theArg)))
+    if
+$else
+    else
+|]
+
+caseElseIf :: Assertion
+caseElseIf = helper "elseif" [hamlet|
+$if false theArg
+    if
+$elseif true theArg
+    elseif
+$else
+    else
+|]
+
+caseElseIfChain :: Assertion
+caseElseIfChain = helper "elseif" [hamlet|
+$if false(getArg(getArg(getArg theArg)))
+    if
+$elseif true(getArg(getArg(getArg theArg)))
+    elseif
+$else
+    else
+|]
+
+caseList :: Assertion
+caseList = do
+    helper "xxx" [hamlet|
+$forall _x <- (list theArg)
+    x
+|]
+
+caseListChain :: Assertion
+caseListChain = do
+    helper "urlurlurl" [hamlet|
+$forall x <-  list(getArg(getArg(getArg(getArg(getArg (theArg))))))
+    @{url x}
+|]
+
+caseWith :: Assertion
+caseWith = do
+    helper "it's embedded" [hamlet|
+$with n <- embed theArg
+    it's ^{n}ded
+|]
+
+caseWithMulti :: Assertion
+caseWithMulti = do
+    helper "it's embedded" [hamlet|
+$with n <- embed theArg, m <- true theArg
+    $if m
+        it's ^{n}ded
+|]
+
+caseWithChain :: Assertion
+caseWithChain = do
+    helper "it's true" [hamlet|
+$with n <- true(getArg(getArg(getArg(getArg theArg))))
+    $if n
+        it's true
+|]
+
+-- in multi-with binding, make sure that a comma in a string doesn't confuse the parser.
+caseWithCommaString :: Assertion
+caseWithCommaString = do
+    helper "it's  , something" [hamlet|
+$with n <- " , something"
+    it's #{n}
+|]
+
+caseWithMultiBindingScope :: Assertion
+caseWithMultiBindingScope = do
+    helper "it's  , something" [hamlet|
+$with n <- " , something", y <- n
+    it's #{y}
+|]
+
+caseScriptNotEmpty :: Assertion
+caseScriptNotEmpty = helper "<script></script>\n" [hamlet|<script>|]
+
+caseMetaEmpty :: Assertion
+caseMetaEmpty = do
+    helper "<meta>\n" [hamlet|<meta>|]
+    helper "<meta/>\n" [xhamlet|<meta>|]
+
+caseInputEmpty :: Assertion
+caseInputEmpty = do
+    helper "<input>\n" [hamlet|<input>|]
+    helper "<input/>\n" [xhamlet|<input>|]
+
+caseMultiClass :: Assertion
+caseMultiClass = helper "<div class=\"foo bar\"></div>\n" [hamlet|<.foo.bar>|]
+
+caseAttribOrder :: Assertion
+caseAttribOrder =
+    helper "<meta 1 2 3>\n" [hamlet|<meta 1 2 3>|]
+
+caseNothing :: Assertion
+caseNothing = do
+    helper "" [hamlet|
+$maybe _n <- nothing theArg
+    nothing
+|]
+    helper "nothing" [hamlet|
+$maybe _n <- nothing theArg
+    something
+$nothing
+    nothing
+|]
+
+caseNothingChain :: Assertion
+caseNothingChain = helper "" [hamlet|
+$maybe n <- nothing(getArg(getArg(getArg theArg)))
+    nothing #{n}
+|]
+
+caseJust :: Assertion
+caseJust = helper "it's just" [hamlet|
+$maybe n <- just theArg
+    it's #{n}
+|]
+
+caseJustChain :: Assertion
+caseJustChain = helper "it's just" [hamlet|
+$maybe n <- just(getArg(getArg(getArg theArg)))
+    it's #{n}
+|]
+
+caseConstructor :: Assertion
+caseConstructor = do
+    helper "url" [hamlet|@{Home}|]
+    helper "suburl" [hamlet|@{Sub SubUrl}|]
+    let text = "<raw text>"
+    helper "<raw text>" [hamlet|#{preEscapedString text}|]
+
+caseUrlParams :: Assertion
+caseUrlParams = do
+    helper "url?foo=bar&amp;foo1=bar1" [hamlet|@?{urlParams theArg}|]
+
+caseEscape :: Assertion
+caseEscape = do
+    helper "#this is raw\n " [hamlet|
+$newline never
+\#this is raw
+\
+\ 
+|]
+    helper "$@^" [hamlet|\$@^|]
+
+caseEmptyStatementList :: Assertion
+caseEmptyStatementList = do
+    helper "" [hamlet|$if True|]
+    helper "" [hamlet|$maybe _x <- Nothing|]
+    let emptyList = []
+    helper "" [hamlet|$forall _x <- emptyList|]
+
+caseAttribCond :: Assertion
+caseAttribCond = do
+    helper "<select></select>\n" [hamlet|<select :False:selected>|]
+    helper "<select selected></select>\n" [hamlet|<select :True:selected>|]
+    helper "<meta var=\"foo:bar\">\n" [hamlet|<meta var=foo:bar>|]
+    helper "<select selected></select>\n"
+        [hamlet|<select :true theArg:selected>|]
+
+    helper "<select></select>\n" [hamlet|<select :False:selected>|]
+    helper "<select selected></select>\n" [hamlet|<select :True:selected>|]
+    helper "<meta var=\"foo:bar\">\n" [hamlet|<meta var=foo:bar>|]
+    helper "<select selected></select>\n"
+        [hamlet|<select :true theArg:selected>|]
+
+caseNonAscii :: Assertion
+caseNonAscii = do
+    helper "עִבְרִי" [hamlet|עִבְרִי|]
+
+caseMaybeFunction :: Assertion
+caseMaybeFunction = do
+    helper "url?foo=bar&amp;foo1=bar1" [hamlet|
+$maybe x <- Just urlParams
+    @?{x theArg}
+|]
+
+caseTrailingDollarSign :: Assertion
+caseTrailingDollarSign =
+    helper "trailing space \ndollar sign #" [hamlet|
+$newline never
+trailing space #
+\
+dollar sign #\
+|]
+
+caseNonLeadingPercent :: Assertion
+caseNonLeadingPercent =
+    helper "<span style=\"height:100%\">foo</span>" [hamlet|
+$newline never
+<span style=height:100%>foo
+|]
+
+caseQuotedAttribs :: Assertion
+caseQuotedAttribs =
+    helper "<input type=\"submit\" value=\"Submit response\">" [hamlet|
+$newline never
+<input type=submit value="Submit response">
+|]
+
+caseSpacedDerefs :: Assertion
+caseSpacedDerefs = do
+    helper "&lt;var&gt;" [hamlet|#{var theArg}|]
+    helper "<div class=\"&lt;var&gt;\"></div>\n" [hamlet|<.#{var theArg}>|]
+
+caseAttribVars :: Assertion
+caseAttribVars = do
+    helper "<div id=\"&lt;var&gt;\"></div>\n" [hamlet|<##{var theArg}>|]
+    helper "<div class=\"&lt;var&gt;\"></div>\n" [hamlet|<.#{var theArg}>|]
+    helper "<div f=\"&lt;var&gt;\"></div>\n" [hamlet|< f=#{var theArg}>|]
+
+    helper "<div id=\"&lt;var&gt;\"></div>\n" [hamlet|<##{var theArg}>|]
+    helper "<div class=\"&lt;var&gt;\"></div>\n" [hamlet|<.#{var theArg}>|]
+    helper "<div f=\"&lt;var&gt;\"></div>\n" [hamlet|< f=#{var theArg}>|]
+
+caseStringsAndHtml :: Assertion
+caseStringsAndHtml = do
+    let str = "<string>"
+    let html = preEscapedString "<html>"
+    helper "&lt;string&gt; <html>" [hamlet|#{str} #{html}|]
+
+caseNesting :: Assertion
+caseNesting = do
+    helper
+      "<table><tbody><tr><td>1</td></tr><tr><td>2</td></tr></tbody></table>"
+      [hamlet|
+$newline never
+<table>
+  <tbody>
+    $forall user <- users
+        <tr>
+         <td>#{user}
+|]
+    helper
+        (concat
+          [ "<select id=\"foo\" name=\"foo\"><option selected></option>"
+          , "<option value=\"true\">Yes</option>"
+          , "<option value=\"false\">No</option>"
+          , "</select>"
+          ])
+        [hamlet|
+$newline never
+<select #"#{name}" name=#{name}>
+    <option :isBoolBlank val:selected>
+    <option value=true :isBoolTrue val:selected>Yes
+    <option value=false :isBoolFalse val:selected>No
+|]
+  where
+    users = ["1", "2"]
+    name = "foo"
+    val = 5 :: Int
+    isBoolBlank _ = True
+    isBoolTrue _ = False
+    isBoolFalse _ = False
+
+caseTrailingSpace :: Assertion
+caseTrailingSpace =
+    helper "" [hamlet|        |]
+
+caseCurrency :: Assertion
+caseCurrency =
+    helper foo [hamlet|#{foo}|]
+  where
+    foo = "eg: 5, $6, €7.01, £75"
+
+caseExternal :: Assertion
+caseExternal = do
+    helper "foo\n<br>\n" $(hamletFile "test/hamlets/external.hamlet")
+    helper "foo\n<br/>\n" $(xhamletFile "test/hamlets/external.hamlet")
+    helper "foo\n<br>\n" $(hamletFileReload "test/hamlets/external.hamlet")
+  where
+    foo = "foo"
+
+caseParens :: Assertion
+caseParens = do
+    let plus = (++)
+        x = "x"
+        y = "y"
+    helper "xy" [hamlet|#{(plus x) y}|]
+    helper "xxy" [hamlet|#{plus (plus x x) y}|]
+    let alist = ["1", "2", "3"]
+    helper "123" [hamlet|
+$forall x <- (id id id id alist)
+    #{x}
+|]
+
+caseHamletLiterals :: Assertion
+caseHamletLiterals = do
+    helper "123" [hamlet|#{show 123}|]
+    helper "123.456" [hamlet|#{show 123.456}|]
+    helper "-123" [hamlet|#{show -123}|]
+    helper "-123.456" [hamlet|#{show -123.456}|]
+
+helper' :: String -> Html -> Assertion
+helper' res h = T.pack res @=? Text.Blaze.Html.Renderer.Text.renderHtml h
+
+caseHamlet' :: Assertion
+caseHamlet' = do
+    helper' "foo" [shamlet|foo|]
+    helper' "foo" [xshamlet|foo|]
+    helper "<br>\n" $ const $ [shamlet|<br>|]
+    helper "<br/>\n" $ const $ [xshamlet|<br>|]
+
+    -- new with generalized stuff
+    helper' "foo" [shamlet|foo|]
+    helper' "foo" [xshamlet|foo|]
+    helper "<br>\n" $ const $ [shamlet|<br>|]
+    helper "<br/>\n" $ const $ [xshamlet|<br>|]
+
+
+instance Show Url where
+    show _ = "FIXME remove this instance show Url"
+
+caseDiffBindNames :: Assertion
+caseDiffBindNames = do
+    let list = words "1 2 3"
+    -- FIXME helper "123123" $(hamletFileReload "test/hamlets/external-debug3.hamlet")
+    error "test has been disabled"
+
+
+caseTrailingSpaces :: Assertion
+caseTrailingSpaces = helper "" [hamlet|
+$if   True   
+$elseif   False   
+$else   
+$maybe x <-   Nothing    
+$nothing  
+$forall   x     <-   empty       
+|]
+  where
+    empty = []
+
+
+
+caseTuple :: Assertion
+caseTuple = do
+   helper "(1,1)" [hamlet| #{("1","1")}|]
+   helper "foo" [hamlet| 
+    $with (a,b) <- ("foo","bar")
+      #{a}
+   |]
+   helper "url" [hamlet| 
+    $with (a,b) <- (Home,Home)
+      @{a}
+   |]
+   helper "url" [hamlet| 
+    $with p <- (Home,[])
+      @?{p}
+   |]
+
+
+
+caseComplex :: Assertion
+caseComplex = do
+  let z :: ((Int,Int),Maybe Int,(),Bool,[[Int]])
+      z = ((1,2),Just 3,(),True,[[4],[5,6]])
+  helper "1 2 3 4 5 61 2 3 4 5 6" [hamlet|
+    $with ((a,b),Just c, () ,True,d@[[e],[f,g]]) <- z
+      $forall h <- d
+        #{a} #{b} #{c} #{e} #{f} #{g}
+    |]
+
+caseRecord :: Assertion
+caseRecord = do
+  let z = ARecord 10 True
+  helper "10" [hamlet|
+    $with ARecord { field1, field2 = True } <- z
+        #{field1}
+    |]
+
+caseRecordWildCard :: Assertion
+caseRecordWildCard = do
+  let z = ARecord 10 True
+  helper "10 True" [hamlet|
+    $with ARecord {..} <- z
+        #{field1} #{field2}
+    |]
+
+caseRecordWildCard1 :: Assertion
+caseRecordWildCard1 = do
+  let z = ARecord 10 True
+  helper "10" [hamlet|
+    $with ARecord {field2 = True, ..} <- z
+        #{field1}
+    |]
+
+caseCaseRecord :: Assertion
+caseCaseRecord = do
+  let z = ARecord 10 True
+  helper "10\nTrue" [hamlet|
+    $case z
+      $of ARecord { field1, field2 = x }
+        #{field1}
+        #{x}
+    |]
+
+data Msg = Hello | Goodbye
+
+ihelper :: String -> HtmlUrlI18n Msg Url -> Assertion
+ihelper res h = do
+    let x = Text.Blaze.Html.Renderer.Text.renderHtml $ h showMsg render
+    T.pack res @=? x
+  where
+    showMsg Hello = preEscapedString "Hola"
+    showMsg Goodbye = preEscapedString "Adios"
+
+instance (ToMarkup a, ToMarkup b) => ToMarkup (a,b) where
+  toMarkup (a,b) = do
+    toMarkup "("
+    toMarkup a
+    toMarkup ","
+    toMarkup b
+    toMarkup ")"
+ test/Text/Shakespeare/I18NSpec.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TemplateHaskell       #-}+module Text.Shakespeare.I18NSpec+    ( spec+    ) where++import           Data.Text             (Text)+import           Text.Shakespeare.I18N++spec :: Monad m => m ()+spec = return ()++data Test = Test++mkMessage "Test" "test-messages" "en"
+ test/Text/Shakespeare/JsSpec.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
+module Text.Shakespeare.JsSpec (spec) where
+
+import Test.HUnit hiding (Test)
+import Test.Hspec
+
+import Prelude hiding (reverse)
+#ifdef TEST_COFFEE
+import Text.Coffee
+#endif
+import Text.Julius
+import Quoter (quote, quoteFile, quoteFileReload)
+import Data.List (intercalate)
+import qualified Data.Text.Lazy as T
+import qualified Data.List
+import qualified Data.List as L
+import Data.Text (Text, pack, unpack)
+import Data.Monoid (mappend)
+import Data.Aeson (toJSON)
+
+join :: [String] -> String
+#ifdef TEST_COFFEE
+join l = (intercalate ";\n" l)
+#else
+join = intercalate "\n"
+#endif
+
+spec :: Spec
+spec = describe "shakespeare-js" $ do
+#if !(defined TEST_COFFEE || defined TEST_ROY)
+  it "julius" $ do
+    let var = "x=2"
+    let urlp = (Home, [(pack "p", pack "q")])
+    flip jelper [quote|['שלום', @{Home}, #{rawJS var}, '@?{urlp}', ^{jmixin} ]|]
+      $ intercalate " "
+        [ "['שלום',"
+        , "url, " ++ var ++ ","
+        , "'url?p=q',"
+        , "f(2) ]"
+        ]
+
+
+  it "juliusFile" $ do
+    let var = "x=2"
+    let urlp = (Home, [(pack "p", pack "q")])
+    flip jelper $(quoteFile "test/juliuses/external1.julius") $ join
+        [ "שלום"
+        , var
+        , "url"
+        , "url?p=q"
+        , "f(2)"
+        ] ++ "\n"
+
+
+  it "juliusFileReload" $ do
+    let var = "x=2"
+    let urlp = (Home, [(pack "p", pack "q")])
+    flip jelper $(quoteFileReload "test/juliuses/external1.julius") $ join
+        [ "שלום"
+        , var
+        , "url"
+        , "url?p=q"
+        , "f(2)"
+        ] ++ "\n"
+#endif
+
+{- TODO
+  it "juliusFileDebugChange" $ do
+    let var = "somevar"
+        test result = jelper result $(juliusFileDebug "test/juliuses/external2.julius")
+    writeFile "test/juliuses/external2.julius" "var #{var} = 1;"
+    test "var somevar = 1;"
+    writeFile "test/juliuses/external2.julius" "var #{var} = 2;"
+    test "var somevar = 2;"
+    writeFile "test/juliuses/external2.julius" "var #{var} = 1;"
+    -}
+
+
+  it "julius module names" $
+    let foo = "foo"
+        double = 3.14 :: Double
+        int = -5 :: Int
+#ifdef TEST_COFFEE
+    in jelper "var _this = this;\n\n(function(shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint) {\n  return [shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint];\n})(oof, oof, 3.14, -5);\n"
+#else
+#  ifdef TEST_ROY
+    in jelper "(function(shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint) {\n    return [shakespeare_var_rawJSDataListreversefoo, shakespeare_var_rawJSLreversefoo, shakespeare_var_rawJSshowdouble, shakespeare_var_rawJSshowint];\n})(oof, oof, 3.14, -5);\n"
+#  else
+    in jelper "[oof, oof, 3.14, -5]"
+#  endif
+#endif
+         [quote|[#{rawJS $ Data.List.reverse foo}, #{rawJS $ L.reverse foo}, #{rawJS $ show double}, #{rawJS $ show int}]|]
+
+
+-- not valid coffeescript
+#if !(defined TEST_COFFEE || defined TEST_ROY)
+  it "single dollar at and caret" $ do
+    jelper "$@^" [quote|$@^|]
+    jelper "#{@{^{" [quote|#\{@\{^\{|]
+#endif
+
+  it "dollar operator" $ do
+    let val = (1 :: Int, (2 :: Int, 3 :: Int))
+#if (defined TEST_COFFEE)
+    jelper "var _this = this;\n\n(function(shakespeare_var_rawJSshowfstsndval) {\n  return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|]
+    jelper "var _this = this;\n\n(function(shakespeare_var_rawJSshowfstsndval) {\n  return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|]
+#else
+
+#  if (defined TEST_ROY)
+    jelper "(function(shakespeare_var_rawJSshowfstsndval) {\n    return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|]
+    jelper "(function(shakespeare_var_rawJSshowfstsndval) {\n    return shakespeare_var_rawJSshowfstsndval;\n})(2);\n" [quote|#{ rawJS $ show $ fst $ snd val }|]
+
+#  else
+    jelper "2" [quote|#{ rawJS $ show $ fst $ snd val }|]
+    jelper "2" [quote|#{ rawJS $ show $ fst $ snd $ val}|]
+#  endif
+#endif
+
+#if (defined TEST_ROY)
+  it "roy function wrapper" $ do
+    let royInsert = rawJS "\"royInsert\""
+    jelper "(function(shakespeare_var_royInsert) {\n    var roy = {\n        \"royInsert\": shakespeare_var_royInsert\n    };\n    return console.log(roy);\n})(\"royInsert\");\n" [quote|
+let roy = { royInsert: #{royInsert} }
+console.log roy
+|]
+#endif
+  it "empty file" $ jelper "" [quote||]
+
+  it "JSON data" $ jelper "\"Hello \\\"World!\\\"\"" [julius|#{toJSON "Hello \"World!\""}|]
+
+  it "boolean interpolation" $ jelper
+    "true false true false true false"
+    [julius|#{True} #{False} #{toJSON True} #{toJSON False} #{rawJS True} #{rawJS False}|]
+
+  it "^\\ should not be escaped" $ jelper
+     "var re = /[^\\r]/;"
+     [julius|var re = /[^\r]/;|]
+
+  it "^\\{ should be escaped" $ jelper
+     "var re = /[^{]/;"
+     [julius|var re = /[^\{]/;|]
+
+
+data Url = Home | Sub SubUrl
+data SubUrl = SubUrl
+render :: Url -> [(Text, Text)] -> Text
+render Home qs = pack "url" `mappend` showParams qs
+render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs
+
+showParams :: [(Text, Text)] -> Text
+showParams [] = pack ""
+showParams z =
+    pack $ '?' : intercalate "&" (map go z)
+  where
+    go (x, y) = go' x ++ '=' : go' y
+    go' = concatMap encodeUrlChar . unpack
+
+-- | 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]
+
+
+
+
+#ifndef TEST_ROY
+jmixin :: JavascriptUrl u
+jmixin = [quote|f(2)|]
+#endif
+
+jelper :: String -> JavascriptUrl Url -> Assertion
+jelper res h = do
+  T.pack res @=? renderJavascriptUrl render h
+
+instance Show Url where
+    show _ = "FIXME remove this instance show Url"
+ test/Text/Shakespeare/TextSpec.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Text.Shakespeare.TextSpec (spec) where
+
+import Test.HUnit hiding (Test)
+import Test.Hspec
+
+import Prelude hiding (reverse)
+import Text.Shakespeare.Text
+import Data.List (intercalate)
+import qualified Data.Text.Lazy as TL
+import qualified Data.List
+import qualified Data.List as L
+import Data.Text (Text, pack, unpack)
+import Data.Monoid (mappend)
+
+spec :: Spec
+spec = do
+  describe "shakespeare-text" $ do
+    it "text" $ do
+      let var = "var"
+      let urlp = (Home, [(pack "p", pack "q")])
+      flip telper [text|שלום
+#{var}
+@{Home}
+@?{urlp}
+^{jmixin}
+|] $ intercalate "\n"
+        [ "שלום"
+        , var
+        , "url"
+        , "url?p=q"
+        , "var x;"
+        ] ++ "\n"
+
+
+    it "textFile" $ do
+      let var = "var"
+      let urlp = (Home, [(pack "p", pack "q")])
+      flip telper $(textFile "test/texts/external1.text") $ unlines
+          [ "שלום"
+          , var
+          , "url"
+          , "url?p=q"
+          , "var x;"
+          ]
+
+
+    it "textFileReload" $ do
+      let var = "var"
+      let urlp = (Home, [(pack "p", pack "q")])
+      flip telper $(textFileReload "test/texts/external1.text") $ unlines
+          [ "שלום"
+          , var
+          , "url"
+          , "url?p=q"
+          , "var x;"
+          ]
+
+{- TODO
+    it "textFileReload" $ do
+      let var = "somevar"
+          test result = telper result $(textFileReload "test/texts/external2.text")
+      writeFile "test/texts/external2.text" "var #{var} = 1;"
+      test "var somevar = 1;"
+      writeFile "test/texts/external2.text" "var #{var} = 2;"
+      test "var somevar = 2;"
+      writeFile "test/texts/external2.text" "var #{var} = 1;"
+      -}
+
+
+    it "text module names" $
+      let foo = "foo"
+          double = 3.14 :: Double
+          int = -5 :: Int in
+        telper "oof oof 3.14 -5"
+          [text|#{Data.List.reverse foo} #{L.reverse foo} #{show double} #{show int}|]
+
+    it "stext module names" $
+      let foo = "foo"
+          double = 3.14 :: Double
+          int = -5 :: Int in
+        simpT "oof oof 3.14 -5"
+          [stext|#{Data.List.reverse foo} #{L.reverse foo} #{show double} #{show int}|]
+
+    it "single dollar at and caret" $ do
+      telper "$@^" [text|$@^|]
+      telper "#{@{^{" [text|#\{@\{^\{|]
+
+    it "single dollar at and caret" $ do
+      simpT "$@^" [stext|$@^|]
+      simpT "#{@{^{" [stext|#\{@\{^\{|]
+
+    it "dollar operator" $ do
+      let val = (1 :: Int, (2 :: Int, 3 :: Int))
+      telper "2" [text|#{ show $ fst $ snd val }|]
+      telper "2" [text|#{ show $ fst $ snd $ val}|]
+
+    it "dollar operator" $ do
+      let val = (1 :: Int, (2 :: Int, 3 :: Int))
+      simpT "2" [stext|#{ show $ fst $ snd val }|]
+      simpT "2" [stext|#{ show $ fst $ snd $ val}|]
+
+simpT :: String -> TL.Text -> Assertion
+simpT a b = pack a @=? TL.toStrict b
+
+
+data Url = Home | Sub SubUrl
+data SubUrl = SubUrl
+render :: Url -> [(Text, Text)] -> Text
+render Home qs = pack "url" `mappend` showParams qs
+render (Sub SubUrl) qs = pack "suburl" `mappend` showParams qs
+
+showParams :: [(Text, Text)] -> Text
+showParams [] = pack ""
+showParams z =
+    pack $ '?' : intercalate "&" (map go z)
+  where
+    go (x, y) = go' x ++ '=' : go' y
+    go' = concatMap encodeUrlChar . unpack
+
+-- | 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]
+
+
+
+
+jmixin :: TextUrl url
+jmixin = [text|var x;|]
+
+telper :: String -> TextUrl Url -> Assertion
+telper res h = pack res @=? TL.toStrict (renderTextUrl render h)
+
+instance Show Url where
+    show _ = "FIXME remove this instance show Url"
+ test/cassiuses/external-media.lucius view
@@ -0,0 +1,7 @@+@media only screen{+    foo {+        bar {+            baz: bin;+        }+    }+}
+ test/cassiuses/external-nested.lucius view
@@ -0,0 +1,6 @@+@topvarbin: bin;+foo {+    bar {+        baz: #{topvarbin};+    }+}
+ test/cassiuses/external1.cassius view
@@ -0,0 +1,11 @@+#{selector}+    background: #{colorBlack}+    bar: baz+    color: #{colorRed}+bin+    background-image: url(@{Home})+    bar: bar+    color: #{(((Color 127) 100) 5)}+    f#{var}x: someval+    unicode-test: שלום+    urlp: url(@?{urlp})
+ test/cassiuses/external1.lucius view
@@ -0,0 +1,13 @@+foo {+    background: #{colorBlack};+    bar: baz;+    color: #{colorRed};+}+bin {+    background-image: url(@{Home});+    bar: bar;+    color: #{(((Color 127) 100) 5)};+    f#{var}x: someval;+    unicode-test: שלום;+    urlp: url(@?{urlp});+}
+ test/cassiuses/external2.cassius view
@@ -0,0 +1,2 @@+foo+  #{var}: 2
+ test/cassiuses/external2.lucius view
@@ -0,0 +1,1 @@+foo{#{var}: 1}
+ test/cassiuses/mixin.lucius view
@@ -0,0 +1,1 @@+selector{^{mixin}}
+ test/cassiuses/reload-import.cassius view
@@ -0,0 +1,1 @@+@import url(@{Home})
+ test/hamlets/double-foralls.hamlet view
@@ -0,0 +1,3 @@+$forall _ <- list+$forall l <- list+    #{l}
+ test/hamlets/embed.hamlet view
@@ -0,0 +1,1 @@+^{embed theArg}
+ test/hamlets/external-debug.hamlet view
@@ -0,0 +1,1 @@+#{foo} 1
+ test/hamlets/external-debug2.hamlet view
@@ -0,0 +1,29 @@+#{var}+#{id var}+@{url}+@{Home}+@{Sub SubUrl}+@?{urlp}+^{template}+$if id true+    true+    #{id $ id $ id (id $ id extra)}+$if not true+$else+    not true+    #{id $ id $ id (id extra)}+$if not true+$elseif true+    elseif true+    #{id $ id(id extra)}+$maybe j <- just+    #{j}+    #{id j}+    #{id (id extra)}+$maybe _ <- nothing+$nothing+    nothing+    #{id extra}+$forall l <- list+    #{id $ id l}+    #{extra}
+ test/hamlets/external-debug3.hamlet view
@@ -0,0 +1,4 @@+$forall list a+    $a$+$forall list b+    $b$
+ test/hamlets/external.hamlet view
@@ -0,0 +1,2 @@+#{foo}+<br>
+ test/hamlets/nonpolyhamlet.hamlet view
@@ -0,0 +1,1 @@+<h1>@{Home}
+ test/hamlets/nonpolyhtml.hamlet view
@@ -0,0 +1,1 @@+<h1>HELLO WORLD
+ test/hamlets/nonpolyihamlet.hamlet view
@@ -0,0 +1,1 @@+<h1>_{Hello}
+ test/juliuses/external1.coffee view
@@ -0,0 +1,5 @@+'שלום'+%{var}+'@{Home}'+'@?{urlp}'+^{cofmixin}
+ test/juliuses/external1.julius view
@@ -0,0 +1,5 @@+שלום+#{rawJS var}+@{Home}+@?{urlp}+^{jmixin}
+ test/juliuses/external2.julius view
@@ -0,0 +1,1 @@+var #{var} = 2;
+ test/texts/external1.text view
@@ -0,0 +1,5 @@+שלום+#{var}+@{Home}+@?{urlp}+^{jmixin}
+ test/texts/external2.text view
@@ -0,0 +1,1 @@+var #{var} = 2;
+ test/tmp.hs view
@@ -0,0 +1,17 @@+data Url = Home | Img+renderUrl' Home = "http://localhost/"+renderUrl' Img = "http://localhost/image.png"++data Obj = Obj+    { foo :: Url+    , bar :: IO String+    }++main = myTemp renderUrl' $ Obj Img (return "some bar value")++myTemp renderUrl obj = do+    putStr "<html><head><title>Foo Bar Baz</title></head><body><h1>Hello World</h1><div id=\"content\"><div class=\"foo\">Bar Baz</div>Plain Content<img src=\""+    putStr $ renderUrl $ foo obj+    putStr "\">"+    bar obj >>= putStr+    putStr "</div></body></html>"