{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module Hdoc.TCT.Write.HTML5 where import Control.Monad (Monad(..), forM_, mapM_) import Data.Bool import Data.Char (Char) import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..)) import Data.Function (($), (.)) import Data.Functor.Compose (Compose(..)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (Maybe(..)) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..), Ordering(..)) import Data.Semigroup (Semigroup(..)) import Data.Sequence (ViewL(..)) import Data.String (String, IsString(..)) import Prelude (Num(..), undefined, error) import Text.Blaze ((!)) import Text.Blaze.Html (Html) import Text.Show (Show(..)) import qualified Control.Monad.Trans.State as S import qualified Data.List as List import qualified Data.Sequence as Seq import qualified Data.Text.Lazy as TL import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as HA import qualified Text.Blaze.Internal as Blaze -- import Hdoc.TCT.Debug import Hdoc.TCT import Hdoc.TCT.Utils import Control.Monad.Utils import Text.Blaze.Utils import qualified Hdoc.TCT.Write.Plain as Plain writeHTML5 :: Trees (Cell Node) -> Html writeHTML5 body = do H.docType H.html $ do H.head $ do H.meta ! HA.httpEquiv "Content-Type" ! HA.content "text/html; charset=UTF-8" whenJust (titleFrom body) $ \t -> H.title $ H.toMarkup $ Plain.text def t -- link ! rel "Chapter" ! title "SomeTitle"> H.link ! HA.rel "stylesheet" ! HA.type_ "text/css" ! HA.href "style/tct-html5.css" let (html5Body, State{}) = runComposeState def $ html5ify body H.body $ do H.a ! HA.id "line-1" $ return () html5Body titleFrom :: Roots -> Maybe Root titleFrom tct = List.find (\case Tree (unCell -> NodeHeader HeaderSection{}) _ts -> True _ -> False) tct >>= \case Tree (unCell -> NodeHeader (HeaderSection _lvl)) (Seq.viewl -> title:<_) -> Just title _ -> Nothing -- * Type 'Html5' type Html5 = ComposeState State Blaze.MarkupM () instance IsString Html5 where fromString = mapM_ html5ify html5 :: H.ToMarkup a => a -> Html5 html5 = Compose . return . H.toMarkup -- ** Type 'State' data State = State { state_pos :: Pos , state_indent :: Html5 , state_italic :: Bool , state_ext_html :: String } -- deriving (Eq, Show) instance Default State where def = State { state_pos = pos1 , state_indent = "" , state_italic = False , state_ext_html = ".html" } -- instance Pretty State -- * Class 'Html5ify' class Html5ify a where html5ify :: a -> Html5 instance Html5ify () where html5ify = mempty instance Html5ify Char where html5ify = \case '\n' -> do s@State{state_pos=Pos line _col, ..} <- liftComposeState S.get liftComposeState $ S.put s{state_pos=Pos (line + 1) 1} html5 '\n' H.a ! HA.id ("line-"<>attrify (line + 1)) $$ return () state_indent c -> do liftComposeState $ S.modify' $ \s@State{state_pos=Pos line col} -> s{state_pos=Pos line (col + 1)} html5 c instance Html5ify String where html5ify = mapM_ html5ify instance Html5ify TL.Text where html5ify t | TL.null t = mempty | otherwise = let (h,ts) = TL.span (/='\n') t in case TL.uncons ts of Nothing -> do liftComposeState $ S.modify' $ \s@State{state_pos=Pos line col} -> s{state_pos=Pos line $ col + int (TL.length h)} html5 h Just (_n,ts') -> do html5 h -- NOTE: useless to increment the pos_column for h, -- since the following '\n' will reset the pos_column. html5ify '\n' html5ify ts' instance Html5ify Pos where html5ify new@(Pos lineNew colNew) = do s@State { state_pos=old@(Pos lineOld colOld) , state_indent } <- liftComposeState S.get case lineOld`compare`lineNew of LT -> do forM_ [lineOld+1..lineNew] $ \lnum -> do html5 '\n' H.a ! HA.id ("line-"<>attrify lnum) $$ return () liftComposeState $ S.put s{state_pos=Pos lineNew 1} state_indent Pos _lineMid colMid <- liftComposeState $ S.gets state_pos html5 $ List.replicate (colNew - colMid) ' ' liftComposeState $ S.put s{state_pos=new} EQ | colOld <= colNew -> do liftComposeState $ S.put s{state_pos=new} html5 $ List.replicate (colNew - colOld) ' ' _ -> error $ "html5ify: non-ascending Pos:" <> "\n old: " <> show old <> "\n new: " <> show new instance Html5ify Roots where html5ify = mapM_ html5ify instance Html5ify Root where html5ify (Tree (Cell (Span{span_begin=bp}:|_) nod) ts) = do html5ify bp case nod of ---------------------- NodeLower name attrs -> do H.span ! HA.class_ (mconcat ["header header-lower"," header-name-",attrify name]) $$ do H.span ! HA.class_ "header-mark" $$ html5ify '<' H.span ! HA.class_ "header-name" $$ html5ify name html5ify attrs html5ify ts ---------------------- NodeHeader hdr -> case hdr of HeaderGreat n wh -> html5HeaderRepeated "" "" n wh ">" "" "great" HeaderBar n wh -> html5HeaderRepeated "" "" n wh "|" "" "bar" HeaderColon n wh -> html5Header "" "" n wh ":" "" "colon" HeaderEqual n wh -> html5Header "" "" n wh "=" "" "equal" HeaderDot n -> html5Header "" "" n "" "." "" "dot" HeaderDash -> html5Header "" "" "" "" "-" " " "dash" HeaderDashDash -> html5Header "" "" "" "" "--" " " "dashdash" HeaderBrackets n -> html5Header "[" "" n "" "]" "" "dashdash" HeaderSection lvl -> do H.section $$ do H.span ! HA.class_ "section-title" $$ do H.span ! HA.class_ "section-mark" $$ do html5ify $ List.replicate lvl '#' case Seq.viewl ts of title :< _ -> h lvl $$ html5ify title _ -> return () html5ify $ case Seq.viewl ts of _ :< ts' -> ts' _ -> ts where h 1 = H.h1 h 2 = H.h2 h 3 = H.h3 h 4 = H.h4 h 5 = H.h5 h 6 = H.h6 h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n) h _ = undefined HeaderDotSlash file -> do ext <- liftComposeState $ S.gets state_ext_html if null ext then html5ify file else H.a ! HA.class_ "header-dotslash" ! HA.href (attrify $ file<>ext) $$ html5ify file where html5Head :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5 html5Head markBegin whmb name whn markEnd whme cl = do H.span ! HA.class_ (mconcat $ ["header header-",cl] <> if TL.null name then [] else [" header-name-",attrify name]) $$ do when (markBegin/="") $ H.span ! HA.class_ "header-mark" $$ html5ify markBegin html5ify whmb when (name/="") $ H.span ! HA.class_ "header-name" $$ html5ify name html5ify whn when (markEnd/="") $ H.span ! HA.class_ "header-mark" $$ html5ify markEnd html5ify whme html5Header markBegin whmb name whn markEnd whme cl = do html5Head markBegin whmb name whn markEnd whme cl H.span ! HA.class_ "header-value" $$ html5ify ts html5HeaderRepeated :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5 html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do State{state_indent} <- liftComposeState S.get liftComposeState $ S.modify' $ \s -> s{ state_indent = do state_indent Pos _lineMid colMid <- liftComposeState $ S.gets state_pos html5ify $ List.replicate (pos_column bp - colMid) ' ' html5Head markBegin whmb name whn markEnd whme cl } r <- html5Header markBegin whmb name whn markEnd whme cl liftComposeState $ S.modify' $ \s -> s{state_indent} return r ---------------------- NodeText t -> do State{state_indent} <- liftComposeState S.get liftComposeState $ S.modify' $ \s -> s{ state_indent = do state_indent Pos _lineMid colMid <- liftComposeState $ S.gets state_pos html5ify $ List.replicate (pos_column bp - colMid) ' ' } r <- html5ify t liftComposeState $ S.modify' $ \s -> s{state_indent} return r ---------------------- NodePara -> do State{state_indent} <- liftComposeState S.get liftComposeState $ S.modify' $ \s -> s{ state_indent = do state_indent Pos _lineMid colMid <- liftComposeState $ S.gets state_pos html5ify $ List.replicate (pos_column bp - colMid) ' ' } r <- html5ify ts liftComposeState $ S.modify' $ \s -> s{state_indent} return r ---------------------- NodeToken t -> html5ify t <> html5ify ts ---------------------- NodePair pair -> case pair of PairElem name attrs -> do H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do H.span ! HA.class_ "pair-open" $$ o unless (null ts) $ do H.span ! HA.class_ "pair-content" $$ html5ify ts H.span ! HA.class_ "pair-close" $$ c where html5Name = H.span ! HA.class_ "elem-name" $$ html5ify name o,c :: Html5 (o,c) | null ts = ( "<"<>html5Name<>html5ify attrs<>"/>" , mempty ) | otherwise = ( "<"<>html5Name<>html5ify attrs<>">" , "html5Name<>">" ) _ -> do H.span ! HA.class_ ("pair-"<>fromString (show pair)) $$ do let (o,c) = pairBorders pair ts H.span ! HA.class_ "pair-open" $$ html5ify o H.span ! HA.class_ "pair-content" $$ em $ html5ify ts H.span ! HA.class_ "pair-close" $$ html5ify c where em :: Html5 -> Html5 em h = case pair of p | p == PairSlash || p == PairFrenchquote || p == PairDoublequote -> do State{..} <- liftComposeState $ S.get liftComposeState $ S.modify' $ \s -> s{state_italic = not state_italic} r <- H.em ! HA.class_ (if state_italic then "even" else "odd") $$ h liftComposeState $ S.modify' $ \s -> s{state_italic} return r _ -> h instance Html5ify Token where html5ify tok = case tok of TokenText t -> html5ify t TokenTag v -> H.span ! HA.class_ "tag" $$ do H.span ! HA.class_ "tag-open" $$ html5ify '#' html5ify v TokenEscape c -> html5ify ['\\', c] TokenLink l -> do H.a ! HA.href (attrify l) $$ html5ify l instance Html5ify ElemAttrs where html5ify = mapM_ html5ify instance Html5ify (White,ElemAttr) where html5ify (elemAttr_white,ElemAttr{..}) = do html5ify elemAttr_white H.span ! HA.class_ "attr-name" $$ html5ify elemAttr_name html5ify elemAttr_open H.span ! HA.class_ "attr-value" $$ html5ify elemAttr_value html5ify elemAttr_close