{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module Hdoc.TCT.Write.HTML5 where import Control.Monad (Monad(..), forM_, mapM_, join) 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(..), 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.RWS.Strict as RWS import qualified Data.List as List import qualified Data.Sequence as Seq import qualified Data.Text.Lazy as TL import qualified Language.Symantic.XML as XML 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 Text.Blaze.XML () 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{}, ()) = runComposeRWS def def $ html5ify body H.body $ do H.a ! HA.id "line-1" $ return () html5Body titleFrom :: Roots -> Maybe Root titleFrom tct = List.find (\case Tree (unSourced -> NodeHeader HeaderSection{}) _ts -> True _ -> False) tct >>= \case Tree (unSourced -> NodeHeader (HeaderSection _lvl)) (Seq.viewl -> title:<_) -> Just title _ -> Nothing -- * Type 'Html5' type Html5 = ComposeRWS Reader Writer State Blaze.MarkupM () instance IsString Html5 where fromString = mapM_ html5ify html5 :: H.ToMarkup a => a -> Html5 html5 = Compose . return . H.toMarkup -- ** Type 'Reader' data Reader = Reader { reader_indent :: Html5 , reader_italic :: Bool , reader_ext_html :: String } -- deriving (Eq, Show) instance Default Reader where def = Reader { reader_indent = "" , reader_italic = False , reader_ext_html = ".html" } -- ** Type 'Writer' type Writer = () -- ** Type 'State' newtype State = State { state_pos :: LineColumn } -- deriving (Eq, Show) instance Default State where def = State { state_pos = def } -- * Class 'Html5ify' class Html5ify a where html5ify :: a -> Html5 instance Html5ify () where html5ify = mempty instance Html5ify Char where html5ify = \case '\n' -> do st@State{state_pos=LineColumn line _col, ..} <- composeLift RWS.get composeLift $ RWS.put st{state_pos=LineColumn (line <> pos1) pos1} html5 '\n' H.a ! HA.id ("line-"<>attrify (line <> pos1)) $$ return () join $ composeLift $ RWS.asks reader_indent c -> do composeLift $ RWS.modify $ \s@State{state_pos=LineColumn line col} -> s{state_pos=LineColumn line (col <> pos1)} 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 composeLift $ RWS.modify $ \s@State{state_pos} -> s{state_pos=state_pos{colNum = colNum state_pos <> num (TL.length h)}} html5 h Just (_n,ts') -> do html5 h -- NOTE: useless to increment the 'colNum' for h, -- since the following '\n' will reset the 'colNum'. html5ify '\n' html5ify ts' instance Html5ify LineColumn where html5ify new = do Reader{reader_indent} <- composeLift RWS.ask st@State{state_pos=old} <- composeLift RWS.get let lineOld = lineInt old let colOld = colInt old case lineOld`compare`lineNew of LT -> do forM_ [lineOld+1..lineNew] $ \lnum -> do html5 '\n' H.a ! HA.id ("line-"<>attrify lnum) $$ return () composeLift $ RWS.put st{state_pos=LineColumn (lineNum new) pos1} reader_indent mid <- composeLift $ RWS.gets state_pos html5 $ List.replicate (colNew - colInt mid) ' ' composeLift $ RWS.put st{state_pos=new} EQ | colOld <= colNew -> do composeLift $ RWS.put st{state_pos=new} html5 $ List.replicate (colNew - colOld) ' ' _ -> error $ "html5ify: non-ascending LineColumn:" <> "\n old: " <> show old <> "\n new: " <> show new where lineNew = lineInt new colNew = colInt new instance Html5ify Roots where html5ify = mapM_ html5ify instance Html5ify Root where html5ify (Tree (Sourced (FileRange{fileRange_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 "" "" (maybe "" XML.unNCName n) wh ">" "" "great" HeaderBar n wh -> html5HeaderRepeated "" "" (maybe "" XML.unNCName n) wh "|" "" "bar" HeaderColon n wh -> html5Header "" "" (maybe "" XML.unNCName n) wh ":" "" "colon" HeaderEqual n wh -> html5Header "" "" (XML.unNCName 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 <- composeLift $ RWS.asks reader_ext_html if null ext then html5ify file else H.a ! HA.class_ "header-dotslash" ! HA.href (attrify $ file<>ext) $$ html5ify file where html5Head :: TL.Text -> White -> TL.Text -> 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 :: TL.Text -> White -> TL.Text -> White -> TL.Text -> White -> H.AttributeValue -> Html5 html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do localComposeRWS (\ro -> ro{ reader_indent = do reader_indent ro midLC <- composeLift $ RWS.gets state_pos html5ify $ List.replicate (colInt bp - colInt midLC) ' ' html5Head markBegin whmb name whn markEnd whme cl }) $ html5Header markBegin whmb name whn markEnd whme cl ---------------------- NodeText t -> do localComposeRWS (\ro -> ro{ reader_indent = do reader_indent ro midLC <- composeLift $ RWS.gets state_pos html5ify $ List.replicate (colInt bp - colInt midLC) ' ' }) $ html5ify t ---------------------- NodePara -> do localComposeRWS (\ro -> ro{ reader_indent = do reader_indent ro midLC <- composeLift $ RWS.gets state_pos html5ify $ List.replicate (colInt bp - colInt midLC) ' ' }) $ html5ify ts ---------------------- 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 Reader{reader_italic} <- composeLift RWS.ask localComposeRWS (\ro -> ro{reader_italic = not reader_italic}) $ H.em ! HA.class_ (if reader_italic then "even" else "odd") $$ h _ -> h instance Html5ify Token where html5ify tok = case tok of TokenText t -> html5ify t TokenAt b v -> H.span ! HA.class_ "at" $$ do when b $ H.span ! HA.class_ "at-back" $$ html5ify '~' H.span ! HA.class_ "at-open" $$ html5ify '@' html5ify v TokenTag b v -> H.span ! HA.class_ "tag" $$ do when b $ H.span ! HA.class_ "tag-back" $$ html5ify '~' 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 ElemName where html5ify = html5ify . show 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