module Text.Html.Nice.FreeMonad
(
Markup
, FastMarkup
, runMarkup
, compile
, renderM
, renderMs
, render
, Identity (..)
, TLB.toLazyText
, doctype
, node
, Attr (..)
, attr
, empty
, text
, lazyText
, builder
, unescape
, string
, dynamic
, hole
, embed
, nodes
, branch
, stream
, sub
, TLB.decimal
, TLB.realFloat
, TLB.fromText
, TLB.fromString
, TLB.fromLazyText
, TLB.Builder
, Void
) where
import Control.Monad
import Control.Monad.Free.Church
import Data.Bifunctor
import Data.Default.Class
import Data.Foldable as F
import qualified Data.Functor.Foldable as F
import Data.Functor.Identity
import Data.String (IsString (..))
import Data.Text (Text)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Builder.Int as TLB
import qualified Data.Text.Lazy.Builder.RealFloat as TLB
import qualified Data.Vector as V
import Data.Void
import GHC.Exts (IsList (..))
import GHC.OverloadedLabels (IsLabel (..))
import GHC.TypeLits (KnownSymbol, symbolVal')
import Text.Html.Nice.Internal
newtype Markup n a = Markup { unMarkup :: F (Markup'F n) a }
deriving (Functor, Applicative, Monad, MonadFree (Markup'F n))
instance Default (Markup n a) where
def = empty
instance Monoid (Markup n a) where
mempty = empty
mappend a b = nodes [a, b]
instance IsString (Markup n a) where
fromString = text . fromString
instance IsList (Markup n a) where
type Item (Markup n a) = Markup n a
fromList = nodes
toList _ = error "haha, fooled you, Markup has no toList"
instance (a ~ (), KnownSymbol s) => IsLabel s (Markup n a) where
fromLabel p = node (fromString (symbolVal' p)) []
newtype MakeNode n a = N ([Attr n] -> Markup n a)
instance (a ~ (), KnownSymbol s) => IsLabel s (MakeNode n a) where
fromLabel p = N (node (fromString (symbolVal' p)))
instance Bifunctor Markup where
first f = Markup . hoistF (first f) . unMarkup
second = fmap
attr :: MakeNode n a -> [Attr n] -> Markup n a
attr (N f) a = f a
runMarkup :: Markup n a -> Markup' n
runMarkup h = runF (unMarkup h) (const Empty) F.embed
compile :: Markup n a -> FastMarkup n
compile = compile_ . runMarkup
node :: Text -> [Attr n] -> Markup n ()
node t v = liftF (NodeF t (V.fromList v) ())
text :: Text -> Markup n a
text t = liftF (TextF DoEscape (StrictT t))
lazyText :: TL.Text -> Markup n a
lazyText t = liftF (TextF DoEscape (LazyT t))
builder :: TLB.Builder -> Markup n a
builder t = liftF (TextF DoEscape (BuilderT t))
string :: String -> Markup n a
string t = liftF (TextF DoEscape (BuilderT (TLB.fromString t)))
unescape :: Text -> Markup n a
unescape t = liftF (TextF Don'tEscape (StrictT t))
dynamic :: n -> Markup n a
dynamic n = liftF (HoleF DoEscape n)
hole :: Markup (a -> a) t
hole = dynamic id
branch :: [a] -> Markup n a
branch = liftF . ListF
nodes :: [Markup n a] -> Markup n a
nodes = join . liftF . ListF
empty :: Markup n a
empty = liftF EmptyF
sub :: Markup n a -> Markup (FastMarkup n) a
sub x = liftF (HoleF Don'tEscape (compile x))
embed :: (t -> FastMarkup n) -> Markup (t -> FastMarkup n) a
embed f = dynamic f
stream :: Foldable f
=> Markup (a -> n) r'
-> Markup (f a -> FastMarkup n) r
stream m = embed $ \fa -> case F.toList fa of
[] -> FEmpty
list -> FStream (ListS list (\a -> fmap ($ a) fm))
where
!fm = compile m
doctype :: Markup n a
doctype = liftF DoctypeF