{-# OPTIONS_HADDOCK hide #-}
-- | This module is only being exposed to work around a GHC bug, its API is not stable

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE EmptyDataDecls #-}
module Text.Internal.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.Semigroup (Semigroup(..))
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 (..))

type CssUrl url = (url -> [(T.Text, T.Text)] -> T.Text) -> Css

type DList a = [a] -> [a]

data Resolved = Resolved | Unresolved

-- Should mixins keep order (new version) or not (deprecated version)
data Order = Ordered | Unordered deriving (forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Order -> m Exp
forall (m :: * -> *). Quote m => Order -> Code m Order
liftTyped :: forall (m :: * -> *). Quote m => Order -> Code m Order
$cliftTyped :: forall (m :: * -> *). Quote m => Order -> Code m Order
lift :: forall (m :: * -> *). Quote m => Order -> m Exp
$clift :: forall (m :: * -> *). Quote m => Order -> m Exp
Lift)

type HasLeadingSpace = Bool

type family Str (a :: Resolved)
type instance Str 'Resolved = Builder
type instance Str 'Unresolved = Contents

data Block (a :: Resolved) where
  BlockResolved :: 
    { Block 'Resolved -> Builder
brSelectors :: !Builder
    , Block 'Resolved -> [Attr 'Resolved]
brAttrs     :: ![Attr 'Resolved]
    } -> Block 'Resolved
  BlockUnresolved ::
    { Block 'Unresolved -> [Contents]
buSelectors      :: ![Contents]
    , Block 'Unresolved -> [Either (Attr 'Unresolved) Deref]
buAttrsAndMixins :: ![Either (Attr 'Unresolved) Deref]
    , Block 'Unresolved -> [(Bool, Block 'Unresolved)]
buBlocks         :: ![(HasLeadingSpace, Block 'Unresolved)]
    } -> Block 'Unresolved

data Mixin = Mixin
    { Mixin -> [Attr 'Resolved]
mixinAttrs :: ![Attr 'Resolved]
    , Mixin -> [(Bool, Block 'Resolved)]
mixinBlocks :: ![(HasLeadingSpace, Block 'Resolved)]
    }
    deriving forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Mixin -> m Exp
forall (m :: * -> *). Quote m => Mixin -> Code m Mixin
liftTyped :: forall (m :: * -> *). Quote m => Mixin -> Code m Mixin
$cliftTyped :: forall (m :: * -> *). Quote m => Mixin -> Code m Mixin
lift :: forall (m :: * -> *). Quote m => Mixin -> m Exp
$clift :: forall (m :: * -> *). Quote m => Mixin -> m Exp
Lift
instance Semigroup Mixin where
    Mixin [Attr 'Resolved]
a [(Bool, Block 'Resolved)]
x <> :: Mixin -> Mixin -> Mixin
<> Mixin [Attr 'Resolved]
b [(Bool, Block 'Resolved)]
y = [Attr 'Resolved] -> [(Bool, Block 'Resolved)] -> Mixin
Mixin ([Attr 'Resolved]
a forall a. [a] -> [a] -> [a]
++ [Attr 'Resolved]
b) ([(Bool, Block 'Resolved)]
x forall a. [a] -> [a] -> [a]
++ [(Bool, Block 'Resolved)]
y)
instance Monoid Mixin where
    mempty :: Mixin
mempty = [Attr 'Resolved] -> [(Bool, Block 'Resolved)] -> Mixin
Mixin forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

data TopLevel (a :: Resolved) 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 :: Resolved) where
  AttrResolved ::
    { Attr 'Resolved -> Builder
attrResKey :: !Builder
    , Attr 'Resolved -> Builder
attrResVal :: !Builder
    } -> Attr 'Resolved
  AttrUnresolved ::
    { Attr 'Unresolved -> Contents
attrUnresKey :: !Contents
    , Attr 'Unresolved -> Contents
attrUnresVal :: !Contents
    } -> Attr 'Unresolved

data Css = CssWhitespace ![TopLevel 'Resolved]
         | CssNoWhitespace ![TopLevel 'Resolved]

data Content = ContentRaw String
             | ContentVar Deref
             | ContentUrl Deref
             | ContentUrlParam Deref
             | ContentMixin Deref
    deriving (Int -> Content -> ShowS
Contents -> ShowS
Content -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: Contents -> ShowS
$cshowList :: Contents -> ShowS
show :: Content -> String
$cshow :: Content -> String
showsPrec :: Int -> Content -> ShowS
$cshowsPrec :: Int -> Content -> ShowS
Show, Content -> Content -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Content -> Content -> Bool
$c/= :: Content -> Content -> Bool
== :: Content -> Content -> Bool
$c== :: Content -> Content -> Bool
Eq, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Content -> m Exp
forall (m :: * -> *). Quote m => Content -> Code m Content
liftTyped :: forall (m :: * -> *). Quote m => Content -> Code m Content
$cliftTyped :: forall (m :: * -> *). Quote m => Content -> Code m Content
lift :: forall (m :: * -> *). Quote m => Content -> m Exp
$clift :: forall (m :: * -> *). Quote m => Content -> m Exp
Lift)

type Contents = [Content]

data CDData url = CDPlain Builder
                | CDUrl url
                | CDUrlParam (url, [(Text, Text)])
                | CDMixin Mixin

pack :: String -> Text
pack :: String -> Text
pack = String -> Text
T.pack

fromText :: Text -> Builder
fromText :: Text -> Builder
fromText = Text -> Builder
TLB.fromText
{-# NOINLINE fromText #-}

class ToCss a where
    toCss :: a -> Builder

instance ToCss [Char] where toCss :: String -> Builder
toCss = Text -> Builder
fromLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack
instance ToCss Text where toCss :: Text -> Builder
toCss = Text -> Builder
fromText
instance ToCss TL.Text where toCss :: Text -> Builder
toCss = Text -> Builder
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 :: Bool
-> Parser [TopLevel 'Unresolved] -> String -> [(Deref, VarType)]
cssUsedIdentifiers Bool
toi2b Parser [TopLevel 'Unresolved]
parseBlocks String
s' =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([(String, String)] -> Content -> Either String [(Deref, VarType)]
getVars [(String, String)]
scope0) Contents
contents
  where
    s :: String
s = if Bool
toi2b then ShowS
i2b String
s' else String
s'
    a :: [TopLevel 'Unresolved]
a = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser [TopLevel 'Unresolved]
parseBlocks String
s String
s
    ([(String, String)]
scope0, Contents
contents) = [TopLevel 'Unresolved] -> ([(String, String)], Contents)
go [TopLevel 'Unresolved]
a

    go :: [TopLevel 'Unresolved] -> (Scope, [Content])
    go :: [TopLevel 'Unresolved] -> ([(String, String)], Contents)
go [] = ([], [])
    go (TopAtDecl String
dec Str 'Unresolved
cs:[TopLevel 'Unresolved]
rest) =
        ([(String, String)]
scope, Contents
rest'')
      where
        ([(String, String)]
scope, Contents
rest') = [TopLevel 'Unresolved] -> ([(String, String)], Contents)
go [TopLevel 'Unresolved]
rest
        rest'' :: Contents
rest'' =
            String -> Content
ContentRaw (Char
'@' forall a. a -> [a] -> [a]
: String
dec forall a. [a] -> [a] -> [a]
++ String
" ")
          forall a. a -> [a] -> [a]
: Str 'Unresolved
cs
         forall a. [a] -> [a] -> [a]
++ String -> Content
ContentRaw String
";"
          forall a. a -> [a] -> [a]
: Contents
rest'
    go (TopAtBlock String
_ Str 'Unresolved
_ [Block 'Unresolved]
blocks:[TopLevel 'Unresolved]
rest) =
        ([(String, String)]
scope1 forall a. [a] -> [a] -> [a]
++ [(String, String)]
scope2, Contents
rest1 forall a. [a] -> [a] -> [a]
++ Contents
rest2)
      where
        ([(String, String)]
scope1, Contents
rest1) = [TopLevel 'Unresolved] -> ([(String, String)], Contents)
go (forall a b. (a -> b) -> [a] -> [b]
map forall (a :: Resolved). Block a -> TopLevel a
TopBlock [Block 'Unresolved]
blocks)
        ([(String, String)]
scope2, Contents
rest2) = [TopLevel 'Unresolved] -> ([(String, String)], Contents)
go [TopLevel 'Unresolved]
rest
    go (TopBlock (BlockUnresolved [Contents]
x [Either (Attr 'Unresolved) Deref]
y [(Bool, Block 'Unresolved)]
z):[TopLevel 'Unresolved]
rest) =
        ([(String, String)]
scope1 forall a. [a] -> [a] -> [a]
++ [(String, String)]
scope2, Contents
rest0 forall a. [a] -> [a] -> [a]
++ Contents
rest1 forall a. [a] -> [a] -> [a]
++ Contents
rest2)
      where
        rest0 :: Contents
rest0 = forall a. [a] -> [[a]] -> [a]
intercalate [String -> Content
ContentRaw String
","] [Contents]
x forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Either (Attr 'Unresolved) Deref -> Contents
go' [Either (Attr 'Unresolved) Deref]
y
        ([(String, String)]
scope1, Contents
rest1) = [TopLevel 'Unresolved] -> ([(String, String)], Contents)
go (forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: Resolved). Block a -> TopLevel a
TopBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Bool, Block 'Unresolved)]
z)
        ([(String, String)]
scope2, Contents
rest2) = [TopLevel 'Unresolved] -> ([(String, String)], Contents)
go [TopLevel 'Unresolved]
rest
    go (TopVar String
k String
v:[TopLevel 'Unresolved]
rest) =
        ((String
k, String
v)forall a. a -> [a] -> [a]
:[(String, String)]
scope, Contents
rest')
      where
        ([(String, String)]
scope, Contents
rest') = [TopLevel 'Unresolved] -> ([(String, String)], Contents)
go [TopLevel 'Unresolved]
rest
    go' :: Either (Attr 'Unresolved) Deref -> [Content]
    go' :: Either (Attr 'Unresolved) Deref -> Contents
go' (Left (AttrUnresolved Contents
k Contents
v)) = Contents
k forall a. [a] -> [a] -> [a]
++ (Contents
v :: [Content])
    go' (Right Deref
m) = [Deref -> Content
ContentMixin Deref
m]

cssFileDebug :: Bool  -- ^ perform the indent-to-brace conversion
             -> Q Exp
             -> Parser [TopLevel 'Unresolved]
             -> FilePath
             -> Q Exp
cssFileDebug :: Bool -> Q Exp -> Parser [TopLevel 'Unresolved] -> String -> Q Exp
cssFileDebug Bool
toi2b Q Exp
parseBlocks' Parser [TopLevel 'Unresolved]
parseBlocks String
fp = do
    String
s <- String -> Q String
readFileQ String
fp
    let vs :: [(Deref, VarType)]
vs = Bool
-> Parser [TopLevel 'Unresolved] -> String -> [(Deref, VarType)]
cssUsedIdentifiers Bool
toi2b Parser [TopLevel 'Unresolved]
parseBlocks String
s
    [Exp]
c <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Deref, VarType) -> Q Exp
vtToExp [(Deref, VarType)]
vs
    Exp
cr <- [|cssRuntime toi2b|]
    Exp
parseBlocks'' <- Q Exp
parseBlocks'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
cr Exp -> Exp -> Exp
`AppE` Exp
parseBlocks'' Exp -> Exp -> Exp
`AppE` (Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
fp) Exp -> Exp -> Exp
`AppE` [Exp] -> Exp
ListE [Exp]
c

runtimePrependSelector :: Builder -> (HasLeadingSpace, Block 'Resolved) -> Block 'Resolved
runtimePrependSelector :: Builder -> (Bool, Block 'Resolved) -> Block 'Resolved
runtimePrependSelector Builder
builder (Bool
hsl, BlockResolved Builder
x [Attr 'Resolved]
b) =
    Builder -> [Attr 'Resolved] -> Block 'Resolved
BlockResolved (Builder
builder forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
addSpace Builder
x) [Attr 'Resolved]
b
  where
    addSpace :: Builder -> Builder
addSpace = if Bool
hsl then (Char -> Builder
TLB.singleton Char
' ' forall a. Semigroup a => a -> a -> a
<>) else forall a. a -> a
id

combineSelectors :: HasLeadingSpace
                 -> [Contents]
                 -> [Contents]
                 -> [Contents]
combineSelectors :: Bool -> [Contents] -> [Contents] -> [Contents]
combineSelectors Bool
hsl [Contents]
a [Contents]
b = do
    Contents
a' <- [Contents]
a
    Contents
b' <- [Contents]
b
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Contents
a' forall a. [a] -> [a] -> [a]
++ Contents -> Contents
addSpace Contents
b'
  where
    addSpace :: Contents -> Contents
addSpace
        | Bool
hsl = (String -> Content
ContentRaw String
" " forall a. a -> [a] -> [a]
:)
        | Bool
otherwise = forall a. a -> a
id

blockRuntime :: [(Deref, CDData url)]
             -> (url -> [(Text, Text)] -> Text)
             -> Block 'Unresolved
             -> Either String (DList (Block 'Resolved))
-- FIXME share code with blockToCss
blockRuntime :: forall url.
[(Deref, CDData url)]
-> (url -> [(Text, Text)] -> Text)
-> Block 'Unresolved
-> Either String (DList (Block 'Resolved))
blockRuntime [(Deref, CDData url)]
cd url -> [(Text, Text)] -> Text
render' (BlockUnresolved [Contents]
x [Either (Attr 'Unresolved) Deref]
attrsAndMixins [(Bool, Block 'Unresolved)]
z) = do
    [Builder]
x' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Content -> Either String Builder
go' forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate [String -> Content
ContentRaw String
","] [Contents]
x
    [[Attr 'Resolved]]
attrs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Attr 'Unresolved -> Either String [Attr 'Resolved]
resolveAttr Deref -> Either String [Attr 'Resolved]
getMixinAttrs) [Either (Attr 'Unresolved) Deref]
attrsAndMixins
    [[(Bool, Block 'Resolved)]]
blocks' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right []) Deref -> Either String [(Bool, Block 'Resolved)]
getMixinBlocks) [Either (Attr 'Unresolved) Deref]
attrsAndMixins
    [DList (Block 'Resolved)]
z' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Contents]
-> (Bool, Block 'Unresolved)
-> Either String (DList (Block 'Resolved))
subGo [Contents]
x) [(Bool, Block 'Unresolved)]
z -- FIXME use difflists again
    forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ \[Block 'Resolved]
rest -> BlockResolved
        { brSelectors :: Builder
brSelectors = forall a. Monoid a => [a] -> a
mconcat [Builder]
x'
        , brAttrs :: [Attr 'Resolved]
brAttrs     = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Attr 'Resolved]]
attrs'
        }
        forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Builder -> (Bool, Block 'Resolved) -> Block 'Resolved
runtimePrependSelector forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Builder]
x') (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Bool, Block 'Resolved)]]
blocks')
        forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) [Block 'Resolved]
rest [DList (Block 'Resolved)]
z'
    {-
    (:) (Css' (mconcat $ map go' $ intercalate [ContentRaw "," ] x) (map go'' y))
    . foldr (.) id (map (subGo x) z)
    -}
  where
    go' :: Content -> Either String Builder
go' = forall url.
[(Deref, CDData url)]
-> (url -> [(Text, Text)] -> Text)
-> Content
-> Either String Builder
contentToBuilderRT [(Deref, CDData url)]
cd url -> [(Text, Text)] -> Text
render'

    getMixin :: Deref -> Either String Mixin
    getMixin :: Deref -> Either String Mixin
getMixin Deref
d =
        case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Deref
d [(Deref, CDData url)]
cd of
            Maybe (CDData url)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Mixin not found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Deref
d
            Just (CDMixin Mixin
m) -> forall a b. b -> Either a b
Right Mixin
m
            Just CDData url
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"For " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Deref
d forall a. [a] -> [a] -> [a]
++ String
", expected Mixin"

    getMixinAttrs :: Deref -> Either String [Attr 'Resolved]
    getMixinAttrs :: Deref -> Either String [Attr 'Resolved]
getMixinAttrs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Mixin -> [Attr 'Resolved]
mixinAttrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deref -> Either String Mixin
getMixin

    getMixinBlocks :: Deref -> Either String [(HasLeadingSpace, Block 'Resolved)]
    getMixinBlocks :: Deref -> Either String [(Bool, Block 'Resolved)]
getMixinBlocks = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Mixin -> [(Bool, Block 'Resolved)]
mixinBlocks forall b c a. (b -> c) -> (a -> b) -> a -> c
. Deref -> Either String Mixin
getMixin

    resolveAttr :: Attr 'Unresolved -> Either String [Attr 'Resolved]
    resolveAttr :: Attr 'Unresolved -> Either String [Attr 'Resolved]
resolveAttr (AttrUnresolved Contents
k Contents
v) =
      let eAttr :: Either String (Attr 'Resolved)
eAttr = Builder -> Builder -> Attr 'Resolved
AttrResolved forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Content -> Either String Builder
go' Contents
k) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Content -> Either String Builder
go' Contents
v)
       in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> [a] -> [a]
:[]) Either String (Attr 'Resolved)
eAttr

    subGo :: [Contents] -- ^ parent selectors
          -> (HasLeadingSpace, Block 'Unresolved)
          -> Either String (DList (Block 'Resolved))
    subGo :: [Contents]
-> (Bool, Block 'Unresolved)
-> Either String (DList (Block 'Resolved))
subGo [Contents]
x' (Bool
hls, BlockUnresolved [Contents]
a [Either (Attr 'Unresolved) Deref]
b [(Bool, Block 'Unresolved)]
c) =
        let a' :: [Contents]
a' = Bool -> [Contents] -> [Contents] -> [Contents]
combineSelectors Bool
hls [Contents]
x' [Contents]
a
         in forall url.
[(Deref, CDData url)]
-> (url -> [(Text, Text)] -> Text)
-> Block 'Unresolved
-> Either String (DList (Block 'Resolved))
blockRuntime [(Deref, CDData url)]
cd url -> [(Text, Text)] -> Text
render' ([Contents]
-> [Either (Attr 'Unresolved) Deref]
-> [(Bool, Block 'Unresolved)]
-> Block 'Unresolved
BlockUnresolved [Contents]
a' [Either (Attr 'Unresolved) Deref]
b [(Bool, Block 'Unresolved)]
c)

contentToBuilderRT :: [(Deref, CDData url)]
                   -> (url -> [(Text, Text)] -> Text)
                   -> Content
                   -> Either String Builder
contentToBuilderRT :: forall url.
[(Deref, CDData url)]
-> (url -> [(Text, Text)] -> Text)
-> Content
-> Either String Builder
contentToBuilderRT [(Deref, CDData url)]
_ url -> [(Text, Text)] -> Text
_ (ContentRaw String
s) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Builder
fromText forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
s
contentToBuilderRT [(Deref, CDData url)]
cd url -> [(Text, Text)] -> Text
_ (ContentVar Deref
d) =
    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Deref
d [(Deref, CDData url)]
cd of
        Just (CDPlain Builder
s) -> forall a b. b -> Either a b
Right Builder
s
        Maybe (CDData url)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Deref
d forall a. [a] -> [a] -> [a]
++ String
": expected CDPlain"
contentToBuilderRT [(Deref, CDData url)]
cd url -> [(Text, Text)] -> Text
render' (ContentUrl Deref
d) =
    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Deref
d [(Deref, CDData url)]
cd of
        Just (CDUrl url
u) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Builder
fromText forall a b. (a -> b) -> a -> b
$ url -> [(Text, Text)] -> Text
render' url
u []
        Maybe (CDData url)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Deref
d forall a. [a] -> [a] -> [a]
++ String
": expected CDUrl"
contentToBuilderRT [(Deref, CDData url)]
cd url -> [(Text, Text)] -> Text
render' (ContentUrlParam Deref
d) =
    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Deref
d [(Deref, CDData url)]
cd of
        Just (CDUrlParam (url
u, [(Text, Text)]
p)) ->
            forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Builder
fromText forall a b. (a -> b) -> a -> b
$ url -> [(Text, Text)] -> Text
render' url
u [(Text, Text)]
p
        Maybe (CDData url)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Deref
d forall a. [a] -> [a] -> [a]
++ String
": expected CDUrlParam"
contentToBuilderRT [(Deref, CDData url)]
_ url -> [(Text, Text)] -> Text
_ ContentMixin{} = forall a b. a -> Either a b
Left String
"contentToBuilderRT ContentMixin"

cssRuntime :: Bool -- ^ i2b?
           -> Parser [TopLevel 'Unresolved]
           -> FilePath
           -> [(Deref, CDData url)]
           -> (url -> [(Text, Text)] -> Text)
           -> Css
cssRuntime :: forall url.
Bool
-> Parser [TopLevel 'Unresolved]
-> String
-> [(Deref, CDData url)]
-> (url -> [(Text, Text)] -> Text)
-> Css
cssRuntime Bool
toi2b Parser [TopLevel 'Unresolved]
parseBlocks String
fp [(Deref, CDData url)]
cd url -> [(Text, Text)] -> Text
render' = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    String
s' <- String -> IO String
readUtf8FileString String
fp
    let s :: String
s = if Bool
toi2b then ShowS
i2b String
s' else String
s'
    let a :: [TopLevel 'Unresolved]
a = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parser [TopLevel 'Unresolved]
parseBlocks String
s String
s
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [TopLevel 'Resolved] -> Css
CssWhitespace forall a b. (a -> b) -> a -> b
$ [(String, String)]
-> [TopLevel 'Unresolved] -> [TopLevel 'Resolved]
goTop [] [TopLevel 'Unresolved]
a
  where
    goTop :: [(String, String)] -- ^ scope
          -> [TopLevel 'Unresolved]
          -> [TopLevel 'Resolved]
    goTop :: [(String, String)]
-> [TopLevel 'Unresolved] -> [TopLevel 'Resolved]
goTop [(String, String)]
_ [] = []
    goTop [(String, String)]
scope (TopAtDecl String
dec Str 'Unresolved
cs':[TopLevel 'Unresolved]
rest) =
        forall (a :: Resolved). String -> Str a -> TopLevel a
TopAtDecl String
dec Builder
cs forall a. a -> [a] -> [a]
: [(String, String)]
-> [TopLevel 'Unresolved] -> [TopLevel 'Resolved]
goTop [(String, String)]
scope [TopLevel 'Unresolved]
rest
      where
        cs :: Builder
cs = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall url.
[(Deref, CDData url)]
-> (url -> [(Text, Text)] -> Text)
-> Content
-> Either String Builder
contentToBuilderRT [(Deref, CDData url)]
cd url -> [(Text, Text)] -> Text
render') Str 'Unresolved
cs'
    goTop [(String, String)]
scope (TopBlock Block 'Unresolved
b:[TopLevel 'Unresolved]
rest) =
        forall a b. (a -> b) -> [a] -> [b]
map forall (a :: Resolved). Block a -> TopLevel a
TopBlock (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error (forall a b. (a -> b) -> a -> b
$ []) forall a b. (a -> b) -> a -> b
$ forall url.
[(Deref, CDData url)]
-> (url -> [(Text, Text)] -> Text)
-> Block 'Unresolved
-> Either String (DList (Block 'Resolved))
blockRuntime ([(String, String)] -> [(Deref, CDData url)]
addScope [(String, String)]
scope) url -> [(Text, Text)] -> Text
render' Block 'Unresolved
b) forall a. [a] -> [a] -> [a]
++
        [(String, String)]
-> [TopLevel 'Unresolved] -> [TopLevel 'Resolved]
goTop [(String, String)]
scope [TopLevel 'Unresolved]
rest
    goTop [(String, String)]
scope (TopAtBlock String
name Str 'Unresolved
s' [Block 'Unresolved]
b:[TopLevel 'Unresolved]
rest) =
        forall (a :: Resolved). String -> Str a -> [Block a] -> TopLevel a
TopAtBlock String
name Builder
s (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall url.
[(Deref, CDData url)]
-> (url -> [(Text, Text)] -> Text)
-> Block 'Unresolved
-> Either String (DList (Block 'Resolved))
blockRuntime ([(String, String)] -> [(Deref, CDData url)]
addScope [(String, String)]
scope) url -> [(Text, Text)] -> Text
render') [] [Block 'Unresolved]
b) forall a. a -> [a] -> [a]
:
        [(String, String)]
-> [TopLevel 'Unresolved] -> [TopLevel 'Resolved]
goTop [(String, String)]
scope [TopLevel 'Unresolved]
rest
      where
        s :: Builder
s = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall url.
[(Deref, CDData url)]
-> (url -> [(Text, Text)] -> Text)
-> Content
-> Either String Builder
contentToBuilderRT [(Deref, CDData url)]
cd url -> [(Text, Text)] -> Text
render') Str 'Unresolved
s'
    goTop [(String, String)]
scope (TopVar String
k String
v:[TopLevel 'Unresolved]
rest) = [(String, String)]
-> [TopLevel 'Unresolved] -> [TopLevel 'Resolved]
goTop ((String
k, String
v)forall a. a -> [a] -> [a]
:[(String, String)]
scope) [TopLevel 'Unresolved]
rest

    addScope :: [(String, String)] -> [(Deref, CDData url)]
addScope [(String, String)]
scope = forall a b. (a -> b) -> [a] -> [b]
map (Ident -> Deref
DerefIdent forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Ident
Ident forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** forall url. Builder -> CDData url
CDPlain forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
fromString) [(String, String)]
scope forall a. [a] -> [a] -> [a]
++ [(Deref, CDData url)]
cd

vtToExp :: (Deref, VarType) -> Q Exp
vtToExp :: (Deref, VarType) -> Q Exp
vtToExp (Deref
d, VarType
vt) = do
    Exp
d' <- forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift Deref
d
    Exp
c' <- VarType -> Q Exp
c VarType
vt
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Maybe Exp] -> Exp
TupE
#if MIN_VERSION_template_haskell(2,16,0)
      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just
#endif
      [Exp
d', Exp
c' Exp -> Exp -> Exp
`AppE` Scope -> Deref -> Exp
derefToExp [] Deref
d]
  where
    c :: VarType -> Q Exp
    c :: VarType -> Q Exp
c VarType
VTPlain = [|CDPlain . toCss|]
    c VarType
VTUrl = [|CDUrl|]
    c VarType
VTUrlParam = [|CDUrlParam|]
    c VarType
VTMixin = [|CDMixin|]

getVars :: [(String, String)] -> Content -> Either String [(Deref, VarType)]
getVars :: [(String, String)] -> Content -> Either String [(Deref, VarType)]
getVars [(String, String)]
_ ContentRaw{} = forall (m :: * -> *) a. Monad m => a -> m a
return []
getVars [(String, String)]
scope (ContentVar Deref
d) =
    case forall b. Deref -> [(String, b)] -> Maybe String
lookupD Deref
d [(String, String)]
scope of
        Just String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return [(Deref
d, VarType
VTPlain)]
getVars [(String, String)]
scope (ContentUrl Deref
d) =
    case forall b. Deref -> [(String, b)] -> Maybe String
lookupD Deref
d [(String, String)]
scope of
        Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return [(Deref
d, VarType
VTUrl)]
        Just String
s -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected URL for " forall a. [a] -> [a] -> [a]
++ String
s
getVars [(String, String)]
scope (ContentUrlParam Deref
d) =
    case forall b. Deref -> [(String, b)] -> Maybe String
lookupD Deref
d [(String, String)]
scope of
        Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return [(Deref
d, VarType
VTUrlParam)]
        Just String
s -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected URLParam for " forall a. [a] -> [a] -> [a]
++ String
s
getVars [(String, String)]
scope (ContentMixin Deref
d) =
    case forall b. Deref -> [(String, b)] -> Maybe String
lookupD Deref
d [(String, String)]
scope of
        Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return [(Deref
d, VarType
VTMixin)]
        Just String
s -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected Mixin for " forall a. [a] -> [a] -> [a]
++ String
s

lookupD :: Deref -> [(String, b)] -> Maybe String
lookupD :: forall b. Deref -> [(String, b)] -> Maybe String
lookupD (DerefIdent (Ident String
s)) [(String, b)]
scope =
    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s [(String, b)]
scope of
        Maybe b
Nothing -> forall a. Maybe a
Nothing
        Just b
_ -> forall a. a -> Maybe a
Just String
s
lookupD Deref
_ [(String, b)]
_ = forall a. Maybe a
Nothing

compressTopLevel :: TopLevel 'Unresolved
                 -> TopLevel 'Unresolved
compressTopLevel :: TopLevel 'Unresolved -> TopLevel 'Unresolved
compressTopLevel (TopBlock Block 'Unresolved
b) = forall (a :: Resolved). Block a -> TopLevel a
TopBlock forall a b. (a -> b) -> a -> b
$ Block 'Unresolved -> Block 'Unresolved
compressBlock Block 'Unresolved
b
compressTopLevel (TopAtBlock String
name Str 'Unresolved
s [Block 'Unresolved]
b) = forall (a :: Resolved). String -> Str a -> [Block a] -> TopLevel a
TopAtBlock String
name Str 'Unresolved
s forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Block 'Unresolved -> Block 'Unresolved
compressBlock [Block 'Unresolved]
b
compressTopLevel x :: TopLevel 'Unresolved
x@TopAtDecl{} = TopLevel 'Unresolved
x
compressTopLevel x :: TopLevel 'Unresolved
x@TopVar{} = TopLevel 'Unresolved
x

compressBlock :: Block 'Unresolved
              -> Block 'Unresolved
compressBlock :: Block 'Unresolved -> Block 'Unresolved
compressBlock (BlockUnresolved [Contents]
x [Either (Attr 'Unresolved) Deref]
y [(Bool, Block 'Unresolved)]
blocks) =
    [Contents]
-> [Either (Attr 'Unresolved) Deref]
-> [(Bool, Block 'Unresolved)]
-> Block 'Unresolved
BlockUnresolved (forall a b. (a -> b) -> [a] -> [b]
map Contents -> Contents
cc [Contents]
x) (forall a b. (a -> b) -> [a] -> [b]
map Either (Attr 'Unresolved) Deref -> Either (Attr 'Unresolved) Deref
go [Either (Attr 'Unresolved) Deref]
y) (forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Block 'Unresolved -> Block 'Unresolved
compressBlock) [(Bool, Block 'Unresolved)]
blocks)
  where
    go :: Either (Attr 'Unresolved) Deref -> Either (Attr 'Unresolved) Deref
    go :: Either (Attr 'Unresolved) Deref -> Either (Attr 'Unresolved) Deref
go (Left (AttrUnresolved Contents
k Contents
v)) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Contents -> Contents -> Attr 'Unresolved
AttrUnresolved (Contents -> Contents
cc Contents
k) (Contents -> Contents
cc Contents
v)
    go (Right Deref
m) = forall a b. b -> Either a b
Right Deref
m
    cc :: Contents -> Contents
    cc :: Contents -> Contents
cc [] = []
    cc (ContentRaw String
a:ContentRaw String
b:Contents
c) = Contents -> Contents
cc forall a b. (a -> b) -> a -> b
$ String -> Content
ContentRaw (String
a forall a. [a] -> [a] -> [a]
++ String
b) forall a. a -> [a] -> [a]
: Contents
c
    cc (Content
a:Contents
b) = Content
a forall a. a -> [a] -> [a]
: Contents -> Contents
cc Contents
b

blockToMixin :: Name
             -> Scope
             -> Block 'Unresolved
             -> Q Exp
blockToMixin :: Name -> [(String, String)] -> Block 'Unresolved -> Q Exp
blockToMixin Name
r [(String, String)]
scope (BlockUnresolved [Contents]
_sel [Either (Attr 'Unresolved) Deref]
props [(Bool, Block 'Unresolved)]
subblocks) =
    -- TODO: preserve the CPS in @mixinBlocks@ below
    [| let attrsAndMixins = $(processAttrsAndDerefs r scope props)
        in Mixin
            { mixinAttrs =
                concatMap (either (:[]) mixinAttrs) attrsAndMixins
            , mixinBlocks =
                concat $
                  $(listE $ map subGo subblocks)
                  ++ map (either (const []) mixinBlocks) attrsAndMixins
            }
    |]
  where
    -- We don't use the @hls@ to combine selectors, because the parent
    -- selector for a mixin is the dummy @mixin@ selector. But we may want
    -- to know later if the block needs a leading space, because the mixin
    -- might include an @&@ which needs to mix correctly with the parent
    -- block's selector.
    subGo :: (Bool, Block 'Unresolved) -> Q Exp
subGo (Bool
hls, BlockUnresolved [Contents]
sel' [Either (Attr 'Unresolved) Deref]
b [(Bool, Block 'Unresolved)]
c) =
      [| map (\x -> ($(lift hls), x))
           $ $(blockToCss r scope $ BlockUnresolved sel' b c) []
      |]
        
blockToCss :: Name
           -> Scope
           -> Block 'Unresolved
           -> ExpQ
blockToCss :: Name -> [(String, String)] -> Block 'Unresolved -> Q Exp
blockToCss Name
r [(String, String)]
scope (BlockUnresolved [Contents]
sel [Either (Attr 'Unresolved) Deref]
props [(Bool, Block 'Unresolved)]
subblocks) =
    [| let attrsAndMixins = $(processAttrsAndDerefs r scope props)
           selToBuilder = $(selectorToBuilder r scope sel)
       in ( BlockResolved
            { brSelectors = selToBuilder
            , brAttrs     = concatMap (either (:[]) mixinAttrs) attrsAndMixins
            }:)
          . foldr (.) id $(listE $ map subGo subblocks)
          . (fmap
                (runtimePrependSelector selToBuilder)
                (concatMap (either (const []) mixinBlocks) attrsAndMixins) ++)
    |]
  where
    subGo :: (HasLeadingSpace, Block 'Unresolved) -> Q Exp
    subGo :: (Bool, Block 'Unresolved) -> Q Exp
subGo (Bool
hls, BlockUnresolved [Contents]
sel' [Either (Attr 'Unresolved) Deref]
b [(Bool, Block 'Unresolved)]
c) =
        let sel'' :: [Contents]
sel'' = Bool -> [Contents] -> [Contents] -> [Contents]
combineSelectors Bool
hls [Contents]
sel [Contents]
sel'
         in Name -> [(String, String)] -> Block 'Unresolved -> Q Exp
blockToCss Name
r [(String, String)]
scope forall a b. (a -> b) -> a -> b
$ [Contents]
-> [Either (Attr 'Unresolved) Deref]
-> [(Bool, Block 'Unresolved)]
-> Block 'Unresolved
BlockUnresolved [Contents]
sel'' [Either (Attr 'Unresolved) Deref]
b [(Bool, Block 'Unresolved)]
c


processAttrsAndDerefs ::
     Name
  -> Scope
  -> [Either (Attr 'Unresolved) Deref]
  -> Q Exp -- ^ Either (Attr 'Resolved) Mixin
processAttrsAndDerefs :: Name
-> [(String, String)] -> [Either (Attr 'Unresolved) Deref] -> Q Exp
processAttrsAndDerefs Name
r [(String, String)]
scope [Either (Attr 'Unresolved) Deref]
props = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Either (Attr 'Unresolved) Deref -> Q Exp
go [Either (Attr 'Unresolved) Deref]
props
  where
    go :: Either (Attr 'Unresolved) Deref -> Q Exp
go (Right Deref
deref) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE 'Right Exp -> Exp -> Exp
`AppE` (Scope -> Deref -> Exp
derefToExp [] Deref
deref)
    go (Left (AttrUnresolved Contents
x Contents
y)) =
          forall (m :: * -> *). Quote m => Name -> m Exp
conE 'Left forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
            ( forall (m :: * -> *). Quote m => Name -> m Exp
conE 'AttrResolved
                forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> [(String, String)] -> Contents -> Q Exp
contentsToBuilder Name
r [(String, String)]
scope Contents
x)
                forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> [(String, String)] -> Contents -> Q Exp
contentsToBuilder Name
r [(String, String)]
scope Contents
y)
            )

selectorToBuilder :: Name -> Scope -> [Contents] -> Q Exp
selectorToBuilder :: Name -> [(String, String)] -> [Contents] -> Q Exp
selectorToBuilder Name
r [(String, String)]
scope [Contents]
sels =
    Name -> [(String, String)] -> Contents -> Q Exp
contentsToBuilder Name
r [(String, String)]
scope forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate [String -> Content
ContentRaw String
","] [Contents]
sels

contentsToBuilder :: Name -> Scope -> [Content] -> Q Exp
contentsToBuilder :: Name -> [(String, String)] -> Contents -> Q Exp
contentsToBuilder Name
r [(String, String)]
scope Contents
contents =
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|mconcat|] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name -> [(String, String)] -> Content -> Q Exp
contentToBuilder Name
r [(String, String)]
scope) Contents
contents

contentToBuilder :: Name -> Scope -> Content -> Q Exp
contentToBuilder :: Name -> [(String, String)] -> Content -> Q Exp
contentToBuilder Name
_ [(String, String)]
_ (ContentRaw String
x) =
    [|fromText . pack|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL String
x)
contentToBuilder Name
_ [(String, String)]
scope (ContentVar Deref
d) =
    case Deref
d of
        DerefIdent (Ident String
s)
            | Just String
val <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s [(String, String)]
scope -> [|fromText . pack|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Lit -> m Exp
litE (String -> Lit
StringL String
val)
        Deref
_ -> [|toCss|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *) a. Monad m => a -> m a
return (Scope -> Deref -> Exp
derefToExp [] Deref
d)
contentToBuilder Name
r [(String, String)]
_ (ContentUrl Deref
u) =
    [|fromText|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
        (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *) a. Monad m => a -> m a
return (Scope -> Deref -> Exp
derefToExp [] Deref
u) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE [])
contentToBuilder Name
r [(String, String)]
_ (ContentUrlParam Deref
u) =
    [|fromText|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
        ([|uncurry|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
r forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *) a. Monad m => a -> m a
return (Scope -> Deref -> Exp
derefToExp [] Deref
u))
contentToBuilder Name
_ [(String, String)]
_ ContentMixin{} = forall a. HasCallStack => String -> a
error String
"contentToBuilder on ContentMixin"

type Scope = [(String, String)]

topLevelsToCassius :: [TopLevel 'Unresolved]
                   -> Q Exp
topLevelsToCassius :: [TopLevel 'Unresolved] -> Q Exp
topLevelsToCassius [TopLevel 'Unresolved]
a = do
    Name
r <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_render"
    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
r] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|CssNoWhitespace . foldr ($) []|] forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE forall a b. (a -> b) -> a -> b
$ Name -> [(String, String)] -> [TopLevel 'Unresolved] -> Q [Exp]
go Name
r [] [TopLevel 'Unresolved]
a
  where
    go :: Name -> [(String, String)] -> [TopLevel 'Unresolved] -> Q [Exp]
go Name
_ [(String, String)]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
    go Name
r [(String, String)]
scope (TopBlock Block 'Unresolved
b:[TopLevel 'Unresolved]
rest) = do
        Exp
e <- [|(++) $ map TopBlock ($(blockToCss r scope b) [])|]
        [Exp]
es <- Name -> [(String, String)] -> [TopLevel 'Unresolved] -> Q [Exp]
go Name
r [(String, String)]
scope [TopLevel 'Unresolved]
rest
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
e forall a. a -> [a] -> [a]
: [Exp]
es
    go Name
r [(String, String)]
scope (TopAtBlock String
name Str 'Unresolved
s [Block 'Unresolved]
b:[TopLevel 'Unresolved]
rest) = do
        let s' :: Q Exp
s' = Name -> [(String, String)] -> Contents -> Q Exp
contentsToBuilder Name
r [(String, String)]
scope Str 'Unresolved
s
        Exp
e <- [|(:) $ TopAtBlock $(lift name) $(s') $(blocksToCassius r scope b)|]
        [Exp]
es <- Name -> [(String, String)] -> [TopLevel 'Unresolved] -> Q [Exp]
go Name
r [(String, String)]
scope [TopLevel 'Unresolved]
rest
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
e forall a. a -> [a] -> [a]
: [Exp]
es
    go Name
r [(String, String)]
scope (TopAtDecl String
dec Str 'Unresolved
cs:[TopLevel 'Unresolved]
rest) = do
        Exp
e <- [|(:) $ TopAtDecl $(lift dec) $(contentsToBuilder r scope cs)|]
        [Exp]
es <- Name -> [(String, String)] -> [TopLevel 'Unresolved] -> Q [Exp]
go Name
r [(String, String)]
scope [TopLevel 'Unresolved]
rest
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Exp
e forall a. a -> [a] -> [a]
: [Exp]
es
    go Name
r [(String, String)]
scope (TopVar String
k String
v:[TopLevel 'Unresolved]
rest) = Name -> [(String, String)] -> [TopLevel 'Unresolved] -> Q [Exp]
go Name
r ((String
k, String
v) forall a. a -> [a] -> [a]
: [(String, String)]
scope) [TopLevel 'Unresolved]
rest

blocksToCassius :: Name
                -> Scope
                -> [Block 'Unresolved]
                -> Q Exp
blocksToCassius :: Name -> [(String, String)] -> [Block 'Unresolved] -> Q Exp
blocksToCassius Name
r [(String, String)]
scope [Block 'Unresolved]
a = do
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|foldr ($) []|] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Name -> [(String, String)] -> Block 'Unresolved -> Q Exp
blockToCss Name
r [(String, String)]
scope) [Block 'Unresolved]
a

renderCss :: Css -> TL.Text
renderCss :: Css -> Text
renderCss Css
css =
    Builder -> Text
toLazyText forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TopLevel 'Resolved -> Builder
go [TopLevel 'Resolved]
tops
  where
    (Bool
haveWhiteSpace, [TopLevel 'Resolved]
tops) =
        case Css
css of
            CssWhitespace [TopLevel 'Resolved]
x -> (Bool
True, [TopLevel 'Resolved]
x)
            CssNoWhitespace [TopLevel 'Resolved]
x -> (Bool
False, [TopLevel 'Resolved]
x)
    go :: TopLevel 'Resolved -> Builder
go (TopBlock Block 'Resolved
x) = Bool -> Builder -> Block 'Resolved -> Builder
renderBlock Bool
haveWhiteSpace forall a. Monoid a => a
mempty Block 'Resolved
x
    go (TopAtBlock String
name Str 'Resolved
s [Block 'Resolved]
x) =
        Text -> Builder
fromText (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"@", String
name, String
" "]) forall a. Monoid a => a -> a -> a
`mappend`
        Str 'Resolved
s forall a. Monoid a => a -> a -> a
`mappend`
        Builder
startBlock forall a. Monoid a => a -> a -> a
`mappend`
        forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Monoid a => a -> a -> a
mappend Builder
endBlock (forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Builder -> Block 'Resolved -> Builder
renderBlock Bool
haveWhiteSpace (String -> Builder
fromString String
"    ")) [Block 'Resolved]
x)
    go (TopAtDecl String
dec Str 'Resolved
cs) = Text -> Builder
fromText (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"@", String
dec, String
" "]) forall a. Monoid a => a -> a -> a
`mappend`
                      Str 'Resolved
cs forall a. Monoid a => a -> a -> a
`mappend`
                      Builder
endDecl

    startBlock :: Builder
startBlock
        | Bool
haveWhiteSpace = String -> Builder
fromString String
" {\n"
        | Bool
otherwise = Char -> Builder
singleton Char
'{'

    endBlock :: Builder
endBlock
        | Bool
haveWhiteSpace = String -> Builder
fromString String
"}\n"
        | Bool
otherwise = Char -> Builder
singleton Char
'}'

    endDecl :: Builder
endDecl
        | Bool
haveWhiteSpace = String -> Builder
fromString String
";\n"
        | Bool
otherwise = Char -> Builder
singleton Char
';'

renderBlock :: Bool -- ^ have whitespace?
            -> Builder -- ^ indentation
            -> Block 'Resolved
            -> Builder
renderBlock :: Bool -> Builder -> Block 'Resolved -> Builder
renderBlock Bool
haveWhiteSpace Builder
indent (BlockResolved Builder
sel [Attr 'Resolved]
attrs)
    | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Attr 'Resolved]
attrs = forall a. Monoid a => a
mempty
    | Bool
otherwise = Builder
startSelect
               forall a. Semigroup a => a -> a -> a
<> Builder
sel
               forall a. Semigroup a => a -> a -> a
<> Builder
startBlock
               forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Builder
endDecl forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Attr 'Resolved -> Builder
renderAttr [Attr 'Resolved]
attrs)
               forall a. Semigroup a => a -> a -> a
<> Builder
endBlock
  where
    renderAttr :: Attr 'Resolved -> Builder
renderAttr (AttrResolved Builder
k Builder
v) = Builder
startDecl forall a. Semigroup a => a -> a -> a
<> Builder
k forall a. Semigroup a => a -> a -> a
<> Builder
colon forall a. Semigroup a => a -> a -> a
<> Builder
v

    colon :: Builder
colon
        | Bool
haveWhiteSpace = String -> Builder
fromString String
": "
        | Bool
otherwise = Char -> Builder
singleton Char
':'

    startSelect :: Builder
startSelect
        | Bool
haveWhiteSpace = Builder
indent
        | Bool
otherwise = forall a. Monoid a => a
mempty

    startBlock :: Builder
startBlock
        | Bool
haveWhiteSpace = String -> Builder
fromString String
" {\n"
        | Bool
otherwise = Char -> Builder
singleton Char
'{'

    endBlock :: Builder
endBlock
        | Bool
haveWhiteSpace = String -> Builder
fromString String
";\n" forall a. Monoid a => a -> a -> a
`mappend` Builder
indent forall a. Monoid a => a -> a -> a
`mappend` String -> Builder
fromString String
"}\n"
        | Bool
otherwise = Char -> Builder
singleton Char
'}'

    startDecl :: Builder
startDecl
        | Bool
haveWhiteSpace = Builder
indent forall a. Monoid a => a -> a -> a
`mappend` String -> Builder
fromString String
"    "
        | Bool
otherwise = forall a. Monoid a => a
mempty

    endDecl :: Builder
endDecl
        | Bool
haveWhiteSpace = String -> Builder
fromString String
";\n"
        | Bool
otherwise = Char -> Builder
singleton Char
';'

instance Lift (Attr a) where
  lift :: forall (m :: * -> *). Quote m => Attr a -> m Exp
lift = \case
    AttrResolved Builder
k Builder
v -> [|AttrResolved $(liftBuilder k) $(liftBuilder v)|]
    AttrUnresolved Contents
k Contents
v -> [|AttrUnresolved k v|]
#if MIN_VERSION_template_haskell(2,17,0)
  liftTyped :: forall (m :: * -> *). Quote m => Attr a -> Code m (Attr a)
liftTyped = forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift
#elif MIN_VERSION_template_haskell(2,16,0)
  liftTyped = unsafeTExpCoerce . lift
#endif

#if MIN_VERSION_template_haskell(2,17,0)
liftBuilder :: Quote m => Builder -> m Exp
#else
liftBuilder :: Builder -> Q Exp
#endif
liftBuilder :: forall (m :: * -> *). Quote m => Builder -> m Exp
liftBuilder Builder
b = [|fromText $ pack $(lift $ TL.unpack $ toLazyText b)|]

instance Lift (Block a) where
  lift :: forall (m :: * -> *). Quote m => Block a -> m Exp
lift = \case
    BlockResolved Builder
a [Attr 'Resolved]
b -> [|BlockResolved $(liftBuilder a) b|]
    BlockUnresolved [Contents]
a [Either (Attr 'Unresolved) Deref]
b [(Bool, Block 'Unresolved)]
c -> [|BlockUnresolved a b c|]
#if MIN_VERSION_template_haskell(2,17,0)
  liftTyped :: forall (m :: * -> *). Quote m => Block a -> Code m (Block a)
liftTyped = forall a (m :: * -> *). Quote m => m Exp -> Code m a
unsafeCodeCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift
#elif MIN_VERSION_template_haskell(2,16,0)
  liftTyped = unsafeTExpCoerce . lift
#endif