{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.DTC.Write.HTML5 where -- import Control.Monad.Trans.Class (MonadTrans(..)) -- import Data.Functor.Identity (Identity(..)) -- import Data.Sequence (Seq) -- import Data.Set (Set) -- import Data.Traversable (Traversable(..)) -- import qualified Data.Sequence as Seq -- import qualified Data.TreeSeq.Strict as Tree import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..), sequence_, forM_, mapM_, when, (>=>)) import Data.Bool import Data.Char (Char) import Data.Default.Class (Default(..)) import Data.Eq (Eq(..)) import Data.Foldable (Foldable(..), concat, any) import Data.Function (($), (.), const, flip, on) import Data.Functor (Functor(..), (<$>)) import Data.Functor.Compose (Compose(..)) import Data.Int (Int) import Data.Map.Strict (Map) import Data.Maybe (Maybe(..), mapMaybe) import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..)) import Data.String (String) import Data.Text (Text) import Data.TreeSeq.Strict (Tree(..), Trees) import Data.Tuple (snd) import Prelude (Num(..)) import System.FilePath (FilePath) 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.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Lazy as TL import qualified Data.TreeSeq.Strict.Zipper as Tree import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as HA import qualified Text.Blaze.Internal as H import Text.Blaze.Utils import Data.Locale hiding (localize, Index) import qualified Data.Locale as Locale import Language.DTC.Document (Document) import Language.DTC.Write.XML () import Language.XML (XmlName(..), XmlPos(..)) import qualified Language.DTC.Document as DTC import qualified Language.DTC.Index as Index -- import Debug.Trace (trace) (<&>) :: Functor f => f a -> (a -> b) -> f b (<&>) = flip (<$>) infixl 4 <&> -- * Type 'Html5' type Html5 = StateMarkup State () -- ** Type 'State' data State = State { styles :: Map FilePath CSS , scripts :: Map FilePath Script , localize :: MsgHtml5 -> Html5 , indexs :: Map XmlPos ( [[Index.Term]] , Map Index.Term [Index.Ref] ) } state :: State state = State { styles = mempty , scripts = mempty , localize = html5ify . show , indexs = mempty } type CSS = Text type Script = Text -- ** Type 'Keys' data Keys = Keys { keys_index :: Map XmlPos [[Index.Term]] } deriving (Show) keys :: Trees DTC.BodyKey DTC.BodyValue -> Keys keys body = foldl' flt (Keys mempty) (Compose body) where flt acc = \case DTC.Index{..} -> acc{keys_index = Map.insert pos terms $ keys_index acc} _ -> acc -- ** Class 'Html5ify' class Html5ify a where html5ify :: a -> Html5 instance Html5ify Char where html5ify = html5ify . H.toMarkup instance Html5ify Text where html5ify = html5ify . H.toMarkup instance Html5ify String where html5ify = html5ify . H.toMarkup instance Html5ify H.Markup where html5ify = Compose . return instance Html5ify DTC.Title where html5ify (DTC.Title t) = html5ify t instance Html5ify DTC.Ident where html5ify (DTC.Ident i) = html5ify i html5Document :: Localize ls Html5 MsgHtml5 => Locales ls => LocaleIn ls -> Document -> Html html5Document locale DTC.Document{..} = do let Keys{..} = keys body let (body',indexs) = if null keys_index then (body, mempty) else let allTerms = (Set.fromList . concat) `foldMap` keys_index in (<$> S.runState (Index.indexify body) Index.state { Index.state_terms = Map.fromSet (const []) allTerms }) $ \Index.State{state_terms} -> (<$> keys_index) $ \terms -> (terms,) $ Map.intersection state_terms $ Map.fromSet (const ()) $ Set.fromList $ concat $ terms let (html5Body, State{styles,scripts}) = runStateMarkup state{indexs} $ do liftStateMarkup $ S.modify $ \s -> s{localize = Locale.localize locale} html5ify body' H.docType H.html ! HA.lang (attrValue $ countryCode locale) $ do H.head $ do H.meta ! HA.httpEquiv "Content-Type" ! HA.content "text/html; charset=UTF-8" whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts -> H.title $ H.toMarkup $ plainify $ List.head ts forM_ (DTC.links $ DTC.about (head :: DTC.Head)) $ \DTC.Link{rel, href} -> H.link ! HA.rel (attrValue rel) ! HA.href (attrValue href) H.meta ! HA.name "generator" ! HA.content "tct" let chapters = (`mapMaybe` toList body) $ \case TreeN k@DTC.Section{} _ -> Just k _ -> Nothing forM_ chapters $ \DTC.Section{..} -> H.link ! HA.rel "Chapter" ! HA.title (attrValue $ plainify title) ! HA.href ("#"<>attrValue pos) H.link ! HA.rel "stylesheet" ! HA.type_ "text/css" ! HA.href "style/dtc-html5.css" forM_ styles $ \style -> H.style ! HA.type_ "text/css" $ H.toMarkup style forM_ scripts $ \script -> H.script ! HA.type_ "application/javascript" $ H.toMarkup script H.body html5Body -- * Type 'BodyCursor' -- | Cursor to navigate within a 'DTC.Body' according to many axis (like in XSLT). type BodyCursor = Tree.Zipper DTC.BodyKey DTC.BodyValue instance Html5ify DTC.Body where html5ify body = forM_ (Tree.zippers body >>= Tree.axis_repeat Tree.axis_following1) $ html5ify instance Html5ify BodyCursor where html5ify z = case Tree.current z of TreeN k _ts -> html5BodyKey z k Tree0 v -> html5BodyValue z v html5BodyKey :: BodyCursor -> DTC.BodyKey -> Html5 html5BodyKey z = \case DTC.Section{..} -> H.section ! HA.class_ "section" ! HA.id (attrValue pos) $$ do html5CommonAttrs attrs $ H.table ! HA.class_ "section-header" $$ H.tbody $$ H.tr $$ do H.td ! HA.class_ "section-number" $$ do html5SectionNumber $ xmlPosAncestors pos H.td ! HA.class_ "section-title" $$ do (case List.length $ xmlPosAncestors pos of 0 -> H.h1 1 -> H.h2 2 -> H.h3 3 -> H.h4 4 -> H.h5 5 -> H.h6 _ -> H.h6) $$ html5ify title forM_ (Tree.axis_child z) $ html5ify html5BodyValue :: BodyCursor -> DTC.BodyValue -> Html5 html5BodyValue z = \case DTC.Vertical v -> do html5ify v DTC.ToC{..} -> do H.nav ! HA.class_ "toc" ! HA.id (attrValue pos) $$ do H.span ! HA.class_ "toc-name" $$ H.a ! HA.href (attrValue pos) $$ html5ify MsgHTML5_Table_of_Contents H.ul $$ forM_ (Tree.axis_following_sibling z) $ html5ToC d where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 } DTC.ToF{..} -> do H.nav ! HA.class_ "tof" ! HA.id (attrValue pos) $$ H.table ! HA.class_ "tof" $$ H.tbody $$ forM_ (Tree.axis_preceding z) $ html5ToF d where d = case depth of { Just (DTC.Nat n) -> n; _ -> 0 } DTC.Figure{..} -> html5CommonAttrs attrs $ H.div ! HA.class_ (attrValue $ "figure-"<>type_) ! HA.id (attrValue pos) $$ do H.table ! HA.class_ "figure-caption" $$ H.tbody $$ H.tr $$ do H.td ! HA.class_ "figure-number" $$ do H.a ! HA.href ("#"<>attrValue pos) $$ html5ify type_ ": " H.td ! HA.class_ "figure-name" $$ html5ify title H.div ! HA.class_ "figure-content" $$ do html5ify verts DTC.Index{pos} -> do (allTerms,refsByTerm) <- liftStateMarkup $ S.gets $ (Map.! pos) . indexs let chars = Index.aliasesByChar allTerms H.div ! HA.class_ "index" ! HA.id (attrValue pos) $$ do H.nav ! HA.class_ "index-nav-chars" $$ do forM_ (Map.keys chars) $ \char -> H.a ! HA.href ("#"<>(attrValue pos <> "." <> attrValue char)) $$ html5ify char H.dl $$ forM_ (Map.toList chars) $ \(char,terms) -> do H.dt $$ let i = attrValue pos <> "." <> attrValue char in H.a ! HA.id i ! HA.href ("#"<>i) $$ html5ify char H.dd $$ H.dl ! HA.class_ "index-char-refs" $$ do forM_ terms $ \aliases -> do H.dt $$ forM_ aliases $ \term -> H.ul $$ H.li ! HA.id (attrValue Index.Ref{term, count=0, section=def}) $$ html5ify term H.dd $$ do let refs = List.sortBy (compare `on` Index.section) $ (`foldMap` aliases) $ \term -> refsByTerm Map.! term sequence_ $ List.intersperse ", " $ (<$> refs) $ \ref@Index.Ref{..} -> H.a ! HA.href ("#"<>attrValue ref) $$ html5ify $ List.intercalate "." $ List.reverse $ (<$> xmlPosAncestors section) $ \(_n,c) -> show c html5ToC :: Int -> BodyCursor -> Html5 html5ToC depth z = case Tree.current z of TreeN DTC.Section{..} _ts -> do H.li $$ do H.table ! HA.class_ "toc-entry" $$ H.tbody $$ H.tr $$ do H.td ! HA.class_ "section-number" $$ html5SectionRef $ xmlPosAncestors pos H.td ! HA.class_ "section-title" $$ html5ify $ DTC.unTitle title >>= \case DTC.Iref{..} -> text DTC.Note{} -> [] h -> [h] let sections = ($ z) $ Tree.axis_child `Tree.axis_filter_current` \case TreeN DTC.Section{} _ -> True _ -> False when (depth > 0 && not (null sections)) $ H.ul $$ forM_ sections $ html5ToC (depth - 1) _ -> pure () html5ToF :: Int -> BodyCursor -> Html5 html5ToF depth z = case Tree.current z of Tree0 v -> case v of DTC.Figure{..} -> H.tr $$ do H.td ! HA.class_ "figure-number" $$ H.a ! HA.href ("#"<>attrValue pos) $$ html5ify type_ H.td ! HA.class_ "figure-name" $$ html5ify title _ -> pure () _ -> pure () instance Html5ify [DTC.Vertical] where html5ify = mapM_ html5ify instance Html5ify DTC.Vertical where html5ify = \case DTC.Para{..} -> html5CommonAttrs attrs $ H.p ! HA.class_ "para" ! HA.id (attrValue pos) $$ do html5ify horis DTC.OL{..} -> html5CommonAttrs attrs $ H.ol ! HA.class_ "ol" ! HA.id (attrValue pos) $$ do forM_ items $ \item -> H.li $$ html5ify item DTC.UL{..} -> html5CommonAttrs attrs $ H.ul ! HA.class_ "ul" ! HA.id (attrValue pos) $$ do forM_ items $ \item -> H.li $$ html5ify item DTC.RL{..} -> html5CommonAttrs attrs $ H.div ! HA.class_ "rl" ! HA.id (attrValue pos) $$ do H.table $$ forM_ refs html5ify DTC.Comment t -> html5ify $ H.Comment (H.Text t) () instance Html5ify DTC.Horizontal where html5ify = \case DTC.BR -> html5ify H.br DTC.B hs -> H.strong $$ html5ify hs DTC.Code hs -> H.code $$ html5ify hs DTC.Del hs -> H.del $$ html5ify hs DTC.I hs -> H.i $$ html5ify hs DTC.Note _ -> "" DTC.Q hs -> H.span ! HA.class_ "q" $$ do "« "::Html5 H.i $$ html5ify hs " »" DTC.SC hs -> H.span ! HA.class_ "smallcaps" $$ html5ify hs DTC.Sub hs -> H.sub $$ html5ify hs DTC.Sup hs -> H.sup $$ html5ify hs DTC.U hs -> H.span ! HA.class_ "underline" $$ html5ify hs DTC.Eref{..} -> H.a ! HA.class_ "eref" ! HA.href (attrValue href) $$ html5ify text DTC.Iref{..} -> H.span ! HA.class_ "iref" ! HA.id (attrValue Index.Ref{term, count, section=def}) $$ html5ify text DTC.Ref{..} -> H.a ! HA.class_ "ref" ! HA.href ("#"<>attrValue to) $$ if null text then html5ify to else html5ify text DTC.Rref{..} -> H.a ! HA.class_ "rref" ! HA.href (attrValue to) $$ html5ify text DTC.Plain t -> html5ify t instance AttrValue Index.Ref where attrValue Index.Ref{..} = "iref" <> "." <> attrValue term <> if count > 0 then "." <> attrValue count else "" instance Html5ify [DTC.Horizontal] where html5ify = mapM_ html5ify instance Html5ify DTC.About where html5ify DTC.About{..} = forM_ titles $ \(DTC.Title title) -> html5ify $ DTC.Q title instance Html5ify DTC.Reference where html5ify DTC.Reference{..} = H.tr $$ do H.td ! HA.class_ "reference-key" $$ html5ify id H.td ! HA.class_ "reference-content" $$ html5ify about html5CommonAttrs :: DTC.CommonAttrs -> Html5 -> Html5 html5CommonAttrs DTC.CommonAttrs{..} = Compose . (addClass . addId <$>) . getCompose where addClass = case classes of [] -> \x -> x _ -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes) addId = case id of Nothing -> \x -> x Just (DTC.Ident i) -> H.AddCustomAttribute "id" (H.Text i) html5SectionNumber :: [(XmlName,Int)] -> Html5 html5SectionNumber = go [] . List.reverse where go :: [(XmlName,Int)] -> [(XmlName,Int)] -> Html5 go _rs [] = pure () go rs (a@(_n,cnt):as) = do H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors (a:rs)) $$ html5ify $ show cnt html5ify '.' go (a:rs) as html5SectionRef :: [(XmlName,Int)] -> Html5 html5SectionRef as = H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors as) $$ case as of [(_n,c)] -> do html5ify $ show c html5ify '.' _ -> html5ify $ Text.intercalate "." $ Text.pack . show . snd <$> as textXmlPosAncestors :: [(XmlName,Int)] -> Text textXmlPosAncestors = snd . foldr (\(n,c) (nParent,acc) -> (n, (if Text.null acc then acc else acc <> ".") <> Text.pack (if n == nParent then show c else show n<>show c) ) ) ("","") -- * Class 'Plainify' class Plainify a where plainify :: a -> TL.Text instance Plainify DTC.Horizontal where plainify = \case DTC.BR -> "\n" DTC.B hs -> "*"<>plainify hs<>"*" DTC.Code hs -> "`"<>plainify hs<>"`" DTC.Del hs -> "-"<>plainify hs<>"-" DTC.I hs -> "/"<>plainify hs<>"/" DTC.Note _ -> "" DTC.Q hs -> "« "<>plainify hs<>" »" DTC.SC hs -> plainify hs DTC.Sub hs -> plainify hs DTC.Sup hs -> plainify hs DTC.U hs -> "_"<>plainify hs<>"_" DTC.Eref{..} -> plainify text DTC.Iref{..} -> plainify text DTC.Ref{..} -> plainify text DTC.Rref{..} -> plainify text DTC.Plain t -> TL.fromStrict t instance Plainify [DTC.Horizontal] where plainify = foldMap plainify instance Plainify DTC.Title where plainify (DTC.Title t) = plainify t instance AttrValue XmlPos where attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors -- * Type 'MsgHtml5' data MsgHtml5 = MsgHTML5_Table_of_Contents deriving (Show) instance Html5ify MsgHtml5 where html5ify msg = do loc <- liftStateMarkup $ S.gets localize loc msg instance LocalizeIn FR Html5 MsgHtml5 where localizeIn _ = \case MsgHTML5_Table_of_Contents -> "Sommaire" instance LocalizeIn EN Html5 MsgHtml5 where localizeIn _ = \case MsgHTML5_Table_of_Contents -> "Summary"