Language/DTC/Write/HTML5.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE DisambiguateRecordFields #-}
   3 {-# LANGUAGE DuplicateRecordFields #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE RecordWildCards #-}
   7 {-# LANGUAGE TypeApplications #-}
   8 {-# LANGUAGE FlexibleInstances #-}
   9 {-# LANGUAGE ScopedTypeVariables #-}
  10 {-# LANGUAGE ViewPatterns #-}
  11 {-# OPTIONS_GHC -fno-warn-orphans #-}
  12 -- | Render a DTC source file in HTML5.
  13 module Language.DTC.Write.HTML5 where
  14
  15 -- import Control.Monad.Trans.Class (MonadTrans(..))
  16 -- import Data.Bool
  17 -- import Data.Eq (Eq(..))
  18 -- import Data.String (IsString(..))
  19 -- import Prelude (Num(..), undefined)
  20 import Control.Applicative (Applicative(..))
  21 import Control.Monad (Monad(..), forM_, mapM_)
  22 import Data.Eq (Eq(..))
  23 import Data.Foldable (Foldable(..))
  24 import Data.Function (($), (.), const)
  25 import Data.Functor (Functor(..), (<$>), ($>))
  26 import Data.Functor.Compose (Compose(..))
  27 import Data.Functor.Identity (Identity(..))
  28 import Data.Int (Int)
  29 import Data.Map.Strict (Map)
  30 import Data.Maybe (Maybe(..), fromMaybe)
  31 import Data.Monoid (Monoid(..))
  32 import Data.Semigroup (Semigroup(..))
  33 import Data.Text (Text)
  34 import Data.Tuple (snd)
  35 import Text.Blaze ((!))
  36 import Text.Blaze.Html (Html)
  37 import Text.Show (Show(..))
  38 import qualified Control.Monad.Trans.State as S
  39 import qualified Data.List as List
  40 import qualified Data.Map.Strict as Map
  41 import qualified Data.Text as Text
  42 import qualified Data.Text.Lazy as TL
  43 import qualified Text.Blaze.Html5 as H
  44 import qualified Text.Blaze.Html5.Attributes  as HA
  45 import qualified Text.Blaze.Internal as H
  46
  47 import Text.Blaze.Utils
  48
  49 import Language.DTC.Document (Document)
  50 import Language.DTC.Write.XML ()
  51 import Language.TCT.Write.XML (XmlName(..), XmlPos(..))
  52 import qualified Language.DTC.Document as DTC
  53
  54 -- import Debug.Trace (trace)
  55
  56 instance H.ToMarkup DTC.Ident where
  57         toMarkup (DTC.Ident i) = H.toMarkup i
  58 instance AttrValue XmlPos where
  59         attrValue = attrValue . textXmlPosAncestors . xmlPosAncestors
  60
  61 -- * Type 'InhHtml5'
  62 data InhHtml5
  63  =   InhHtml5
  64 inhHtml5 :: InhHtml5
  65 inhHtml5 = InhHtml5
  66
  67 {- NOTE: composing state and markups
  68 type HtmlM st = Compose (S.State st) H.MarkupM
  69 instance Monad (HtmlM st) where
  70         return = pure
  71         Compose sma >>= a2csmb =
  72                 Compose $ sma >>= \ma ->
  73                         case ma >>= H.Empty . a2csmb of
  74                          H.Append _ma (H.Empty csmb) ->
  75                                 H.Append ma <$> getCompose csmb
  76                          _ -> undefined
  77
  78 ($$) :: (Html -> Html) -> HTML -> HTML
  79 ($$) f m = Compose $ f <$> getCompose m
  80 infixr 0 $$
  81 -}
  82
  83 unMarkupValue :: H.MarkupM a -> b -> H.MarkupM b
  84 unMarkupValue = \case
  85  H.Parent x0 x1 x2 m          -> H.Parent x0 x1 x2 . unMarkupValue m
  86  H.CustomParent x0 m          -> H.CustomParent x0 . unMarkupValue m
  87  H.Leaf x0 x1 x2 _            -> H.Leaf x0 x1 x2
  88  H.CustomLeaf x0 x1 _         -> H.CustomLeaf x0 x1
  89  H.Content x0 _               -> H.Content x0
  90  H.Comment x0 _               -> H.Comment x0
  91  H.Append x0 m                -> H.Append x0 . unMarkupValue m
  92  H.AddAttribute x0 x1 x2 m    -> H.AddAttribute x0 x1 x2 . unMarkupValue m
  93  H.AddCustomAttribute x0 x1 m -> H.AddCustomAttribute x0 x1 . unMarkupValue m
  94  H.Empty _                    -> H.Empty
  95
  96 markupValue :: H.MarkupM a -> a
  97 markupValue m0 = case m0 of
  98  H.Parent _ _ _ m1           -> markupValue m1
  99  H.CustomParent _ m1         -> markupValue m1
 100  H.Leaf _ _ _ x              -> x
 101  H.CustomLeaf _ _ x          -> x
 102  H.Content _ x               -> x
 103  H.Comment _ x               -> x
 104  H.Append _ m1               -> markupValue m1
 105  H.AddAttribute _ _ _ m1     -> markupValue m1
 106  H.AddCustomAttribute _ _ m1 -> markupValue m1
 107  H.Empty x                   -> x
 108
 109 html5Document :: Document -> Html
 110 html5Document DTC.Document{..} = do
 111         H.docType
 112         H.html $ do
 113                 H.head $ do
 114                         H.meta ! HA.httpEquiv "Content-Type"
 115                                ! HA.content "text/html; charset=UTF-8"
 116                         whenSome (DTC.titles $ DTC.about (head :: DTC.Head)) $ \ts ->
 117                                 let t = textHorizontals $ List.head $ (DTC.unTitle <$> ts) <> [[DTC.Plain ""]] in
 118                                 H.title $ H.toMarkup t
 119                         -- link ! rel "Chapter" ! title "SomeTitle">
 120                         H.link ! HA.rel "stylesheet"
 121                                ! HA.type_ "text/css"
 122                                ! HA.href "style/dtc-html5.css"
 123                 H.body $
 124                         forM_ body html5Body
 125 html5Body :: DTC.Body -> Html
 126 html5Body = \case
 127          DTC.Section{..} ->
 128                 H.section
 129                  ! HA.class_ "section"
 130                  ! HA.id (attrValue pos) $ do
 131                         html5CommonAttrs attrs $
 132                                 H.table ! HA.class_ "section-header" $
 133                                         H.tbody $
 134                                                 H.tr $ do
 135                                                         H.td ! HA.class_ "section-number" $ do
 136                                                                 html5SectionNumber $ xmlPosAncestors pos
 137                                                         H.td ! HA.class_ "section-title" $ do
 138                                                                 html5Horizontals $ DTC.unTitle title
 139                         forM_ body html5Body
 140                 {- aliases :: [Alias]
 141                 -}
 142          DTC.Verticals vs -> html5Verticals vs
 143
 144 textXmlPosAncestors :: [(XmlName,Int)] -> Text
 145 textXmlPosAncestors =
 146         snd . foldr (\(n,c) (nParent,acc) ->
 147                 (n,
 148                         (if Text.null acc
 149                                 then acc
 150                                 else acc <> ".") <>
 151                         Text.pack
 152                          (if n == nParent
 153                                 then show c
 154                                 else show n<>show c)
 155                 )
 156          ) ("","")
 157
 158 html5SectionNumber :: [(XmlName,Int)] -> Html
 159 html5SectionNumber = go [] . List.reverse
 160         where
 161         go :: [(XmlName,Int)] -> [(XmlName,Int)] -> Html
 162         go _rs [] = mempty
 163         go rs (a@(_n,cnt):as) = do
 164                 H.a ! HA.href (attrValue $ "#"<>textXmlPosAncestors (a:rs)) $
 165                         H.toMarkup $ show cnt
 166                 H.toMarkup '.'
 167                 go (a:rs) as
 168
 169 html5Verticals :: [DTC.Vertical] -> Html
 170 html5Verticals = foldMap html5Vertical
 171
 172 html5Vertical :: DTC.Vertical -> Html
 173 html5Vertical = \case
 174          DTC.Para{..} ->
 175                 html5CommonAttrs attrs $
 176                 H.div ! HA.class_ "para"
 177                       ! HA.id (attrValue pos) $ do
 178                         html5Horizontals horis
 179          DTC.OL{..} ->
 180                 html5CommonAttrs attrs $
 181                 H.ol ! HA.class_ "ol"
 182                      ! HA.id (attrValue pos) $ do
 183                         forM_ items $ \item ->
 184                                 H.li $ html5Verticals item
 185          DTC.UL{..} ->
 186                 html5CommonAttrs attrs $
 187                 H.ul ! HA.class_ "ul"
 188                      ! HA.id (attrValue pos) $ do
 189                         forM_ items $ \item ->
 190                                 H.li $ html5Verticals item
 191          DTC.RL{..} ->
 192                 html5CommonAttrs attrs $
 193                 H.div ! HA.class_ "rl"
 194                       ! HA.id (attrValue pos) $ do
 195                         H.table $
 196                                 forM_ refs html5Reference
 197          DTC.Comment t ->
 198                 H.Comment (H.Text t) ()
 199          DTC.Figure{..} ->
 200                 html5CommonAttrs attrs $
 201                 H.div ! HA.class_ (attrValue $ "figure-"<>type_)
 202                       ! HA.id (attrValue pos) $ do
 203                         H.table ! HA.class_ "figure-caption" $
 204                                 H.tbody $
 205                                         H.tr $ do
 206                                                 H.td ! HA.class_ "figure-number" $ do
 207                                                         H.a ! HA.href "" $ H.toMarkup type_
 208                                                         ": "
 209                                                 H.td ! HA.class_ "figure-name" $
 210                                                         html5Horizontals $ DTC.unTitle title
 211                         H.div ! HA.class_ "figure-content" $ do
 212                                 html5Verticals verts
 213          DTC.ToC{..} ->
 214                 H.nav ! HA.class_ "toc"
 215                       ! HA.id (attrValue pos) $
 216                 ""
 217          DTC.ToF{..} ->
 218                 H.nav ! HA.class_ "tof"
 219                       ! HA.id (attrValue pos) $
 220                 ""
 221         {-
 222          Index{..} ->
 223          Artwork{..} ->
 224         -}
 225
 226 html5Reference :: DTC.Reference -> Html
 227 html5Reference DTC.Reference{..} =
 228         H.tr $ do
 229                 H.td ! HA.class_ "reference-key" $
 230                         H.toMarkup id
 231                 H.td ! HA.class_ "reference-content" $
 232                         html5About about
 233
 234 html5About :: DTC.About -> Html
 235 html5About DTC.About{..} =
 236         forM_ titles $ \(DTC.Title title) -> do
 237                 html5Horizontal $ DTC.Q title
 238         {-
 239         authors
 240         editor
 241         date
 242         version
 243         keywords
 244         links
 245         series
 246         includes
 247         -}
 248
 249 html5CommonAttrs :: DTC.CommonAttrs -> Html -> Html
 250 html5CommonAttrs DTC.CommonAttrs{..} =
 251         (case classes of
 252          [] -> \x -> x
 253          _  -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)) .
 254         case id of
 255          Nothing -> \x -> x
 256          Just (DTC.Ident i) ->
 257                         H.AddCustomAttribute "id" (H.Text i)
 258
 259 html5Horizontal :: DTC.Horizontal -> Html
 260 html5Horizontal = \case
 261          DTC.BR       -> H.br
 262          DTC.B    hs  -> H.strong $ html5Horizontals hs
 263          DTC.Code hs  -> H.code   $ html5Horizontals hs
 264          DTC.Del  hs  -> H.del    $ html5Horizontals hs
 265          DTC.I    hs  -> H.i      $ html5Horizontals hs
 266          DTC.Note _   -> ""
 267          DTC.Q    hs  -> "« "<>H.i (html5Horizontals hs)<>" »"
 268          DTC.SC   hs  -> html5Horizontals hs
 269          DTC.Sub  hs  -> H.sub $ html5Horizontals hs
 270          DTC.Sup  hs  -> H.sup $ html5Horizontals hs
 271          DTC.U    hs  -> H.span ! HA.class_ "underline" $ html5Horizontals hs
 272          DTC.Eref{..} -> H.a ! HA.class_ "eref" ! HA.href (attrValue href) $ html5Horizontals text
 273          DTC.Iref{..} -> H.a ! HA.class_ "iref" ! HA.href (attrValue to)   $ html5Horizontals text
 274          DTC.Ref{..}  ->
 275                 H.a ! HA.class_ "ref"
 276                     ! HA.href ("#"<>attrValue to) $
 277                 if null text
 278                 then H.toMarkup to
 279                 else html5Horizontals text
 280          DTC.Rref{..} -> H.a ! HA.class_ "rref" ! HA.href (attrValue to)   $ html5Horizontals text
 281          DTC.Plain t  -> H.toMarkup t
 282
 283 html5Horizontals :: [DTC.Horizontal] -> Html
 284 html5Horizontals = mapM_ html5Horizontal
 285
 286 textHorizontal :: DTC.Horizontal -> TL.Text
 287 textHorizontal = \case
 288          DTC.BR       -> "\n"
 289          DTC.B    hs  -> "*"<>textHorizontals hs<>"*"
 290          DTC.Code hs  -> "`"<>textHorizontals hs<>"`"
 291          DTC.Del  hs  -> "-"<>textHorizontals hs<>"-"
 292          DTC.I    hs  -> "/"<>textHorizontals hs<>"/"
 293          DTC.Note _   -> ""
 294          DTC.Q    hs  -> "« "<>textHorizontals hs<>" »"
 295          DTC.SC   hs  -> textHorizontals hs
 296          DTC.Sub  hs  -> textHorizontals hs
 297          DTC.Sup  hs  -> textHorizontals hs
 298          DTC.U    hs  -> "_"<>textHorizontals hs<>"_"
 299          DTC.Eref{..} -> textHorizontals text
 300          DTC.Iref{..} -> textHorizontals text
 301          DTC.Ref{..}  -> textHorizontals text
 302          DTC.Rref{..} -> textHorizontals text
 303          DTC.Plain t  -> TL.fromStrict t
 304
 305 textHorizontals :: [DTC.Horizontal] -> TL.Text
 306 textHorizontals = foldMap textHorizontal