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