module Control.Monad.Takahashi.HtmlBuilder
( HBuilder
, HBuilderRWS
, DivDirection
, buildHtml
, makeDivs
, runBuildHtml
, normalizeDivInfo
, module Control.Monad.Takahashi.HtmlBuilder.Style
, module Control.Monad.Takahashi.HtmlBuilder.Monad
, module Control.Monad.Takahashi.HtmlBuilder.Html
) where
import Control.Lens
import Control.Monad.Takahashi.HtmlBuilder.Style
import Control.Monad.Takahashi.HtmlBuilder.Monad
import Control.Monad.Takahashi.HtmlBuilder.Html
import Control.Monad.Takahashi.Util
import Data.List
import Data.Monoid
import Control.Monad.Skeleton
import Control.Monad.RWS
type HBuilder a = HtmlBuilder Style a
type HBuilderRWS a = RWS () Html Style a
data DivDirection = DivVertical | DivHorizon deriving (Show, Read, Eq, Ord)
buildHtml :: HBuilder a -> HBuilderRWS a
buildHtml t = interpret advent t
where
advent :: HtmlBuilderBase Style x -> HBuilderRWS x
advent GetHtmlOption = get
advent (PutHtmlOption o) = put o
advent (WriteHeader1 str) = tell $ H1 str Emp
advent (WriteHeader2 str) = tell $ H2 str Emp
advent (WriteHeader3 str) = tell $ H3 str Emp
advent (WriteParagraph s) = tell $ P s Emp
advent (WriteList xs) = tell $ Li xs Emp
advent (DrawPicture dt fp) = tell $ Img fp (drawType2Style dt) Emp
advent (VerticalDiv xs) = makeDivs DivVertical $ normalizeDivInfo xs
advent (HorizonDiv xs) = do
makeDivs DivHorizon $ normalizeDivInfo xs
stateSandbox $ do
float .= Just ClearBoth
writeStyle <- get
tell $ Div Nothing Nothing (Just writeStyle) Emp Emp
advent (WriteHtml h) = tell h
makeDivs :: DivDirection -> [DivInfo Style] -> HBuilderRWS ()
makeDivs dir xs = mapM_ tellMakeDiv xs
where
tellMakeDiv :: DivInfo Style -> HBuilderRWS ()
tellMakeDiv (DivInfo raito makeStyle dat) = do
stateSandbox $ do
setStyle raito
writeStyle <- get
tell $ Div (Just "block") Nothing (Just . flip execMakeStyle makeStyle $ writeStyle) (runBuildHtml dat) $ Emp
setStyle :: Int -> HBuilderRWS ()
setStyle raito = do
case dir of
DivVertical -> do
size .= Size { _height = Just $ Per raito, _width = Just $ Per 100 }
DivHorizon -> do
size .= Size { _height = Just $ Per 100, _width = Just $ Per raito }
float .= Just FloatLeft
runBuildHtml :: HBuilder a -> Html
runBuildHtml t = snd $ execRWS (buildHtml t) () defaultStyle
--helper
normalizeDivInfo :: [DivInfo o] -> [DivInfo o]
normalizeDivInfo = map tuple2DivInfo . separatePercentage . map divInfo2Tuple
separatePercentage :: [(Int, b)] -> [(Int, b)]
separatePercentage xs = let
fstlst = map (fromIntegral . fst) xs
sumlst = repeat $ sum fstlst
perlst = zipWith (/) fstlst sumlst
in zip (map (floor . (*100)) perlst) $ map snd xs
drawType2Style :: DrawType -> Style
drawType2Style dt = execMakeStyle defaultStyle (drawType2MakeStyle dt)
where
drawType2MakeStyle :: DrawType -> MakeStyle ()
drawType2MakeStyle SimpleDraw = return ()
drawType2MakeStyle HStretch = size.height .= Just (Per 90)
drawType2MakeStyle WStretch = size.width .= Just (Per 90)
drawType2MakeStyle Stretch = do
size.height .= Just (Per 90)
size.width .= Just (Per 90)