Add <URL> when print-only.
[doclang.git] / Language / TCT / Write / HTML5.hs
index 0b4a3f54f8687f8d55e205bf9d6caa78332fa334..ce6bed0dd87ec8f85959d3461744c04cc366f50c 100644 (file)
@@ -3,24 +3,21 @@
 {-# LANGUAGE ViewPatterns #-}
 module Language.TCT.Write.HTML5 where
 
-import Control.Applicative (Applicative(..))
-import Control.Monad (Monad(..), forM_, mapM_, when)
+import Control.Monad (Monad(..), forM_, mapM_, when, unless)
 import Data.Bool
 import Data.Char (Char)
 import Data.Default.Class (Default(..))
 import Data.Eq (Eq(..))
 import Data.Foldable (Foldable(..))
-import Data.Function (($), (.), id)
-import Data.Functor ((<$>))
+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(..))
+import Data.Ord (Ord(..), Ordering(..))
 import Data.Semigroup (Semigroup(..))
 import Data.Sequence (ViewL(..))
 import Data.String (String, IsString(..))
-import Data.Text (Text)
-import Data.TreeSeq.Strict (Tree(..),Trees)
 import Prelude (Num(..), undefined, error)
 import Text.Blaze ((!))
 import Text.Blaze.Html (Html)
@@ -28,26 +25,26 @@ 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 as Text
 import qualified Data.Text.Lazy as TL
 import qualified Text.Blaze.Html5 as H
-import qualified Text.Blaze.Html5.Attributes  as HA
--- import Debug.Trace (trace)
+import qualified Text.Blaze.Html5.Attributes as HA
 
-import Text.Blaze.Utils
 import Language.TCT
+-- import Language.TCT.Debug
+import Language.TCT.Utils
+import Text.Blaze.Utils
 import qualified Language.TCT.Write.Plain as Plain
 
-html5Document :: TCTs -> Html
-html5Document body = do
+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 (tokensTitle body) $ \ts ->
+                       whenJust (titleFrom body) $ \t ->
                                H.title $
-                                       H.toMarkup $ Plain.text def $ List.head $ toList ts
+                                       H.toMarkup $ Plain.text def t
                        -- link ! rel "Chapter" ! title "SomeTitle">
                        H.link ! HA.rel "stylesheet"
                               ! HA.type_ "text/css"
@@ -56,196 +53,265 @@ html5Document body = do
                        runStateMarkup def $
                        html5ify body
                H.body $ do
-                       H.a ! HA.id ("line-1") $ return ()
+                       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 = StateMarkup State ()
 
+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_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_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 H.Markup where
-       html5ify = Compose . return
-instance Html5ify Html5 where
-       html5ify = id
 instance Html5ify () where
        html5ify = mempty
 instance Html5ify Char where
-       html5ify = html5ify . H.toMarkup
-instance Html5ify Text where
-       html5ify = html5ify . H.toMarkup
-instance Html5ify TL.Text where
-       html5ify = html5ify . H.toMarkup
+       html5ify = \case
+        '\n' -> do
+               s@State{state_pos=Pos line _col, ..} <- liftStateMarkup S.get
+               liftStateMarkup $ S.put s{state_pos=Pos (line + 1) 1}
+               html5 '\n'
+               H.a ! HA.id ("line-"<>attrify (line + 1)) $$ return ()
+               state_indent
+        c -> do
+               liftStateMarkup $ S.modify' $ \s@State{state_pos=Pos line col} ->
+                       s{state_pos=Pos line (col + 1)}
+               html5 c
 instance Html5ify String where
-       html5ify = html5ify . H.toMarkup
-instance Html5ify (Trees (Cell Key) Tokens) where
        html5ify = mapM_ html5ify
-instance Html5ify (Tree (Cell Key) Tokens) where
-       html5ify = \case
-        TreeN (Cell bp ep k) ts -> html5ify (Cell bp ep (k,ts))
-        Tree0 ts -> html5ify ts
-instance Html5ify a => Html5ify (Cell a) where
-       html5ify (Cell next@(Pos line col) ep a) = do
-               prev@(Pos lineLast colLast) <- liftStateMarkup $ S.gets state_pos
-               case () of
-                _ | lineLast < line -> do
-                       forM_ [lineLast+1..line] $ \lnum -> do
-                               html5ify '\n'
+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
+                       liftStateMarkup $ 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
+                } <- liftStateMarkup 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 ()
-                       html5ify $ Text.replicate (col - 1) " "
-                _ | lineLast == line && colLast <= col -> do
-                       html5ify $ Text.replicate (col - colLast) " "
-                _ -> error $ "html5ify: non-ascending positions: "
-                        <> "\n prev: " <> show prev
-                        <> "\n next: " <> show next
-               -- liftStateMarkup $ S.modify $ \s -> s{state_pos=bp}
-               liftStateMarkup $ S.modify $ \s -> s{state_pos=ep}
-               html5ify a
-instance Html5ify (Key, Trees (Cell Key) Tokens) where
-       html5ify (key, ts) =
-               case key of
-                KeyPara       -> html5ify ts
-                KeyColon n wh -> html5Key "" "" n wh ":" "" "colon"
-                KeyGreat n wh -> html5Key "" "" n wh ">" "" "great"
-                KeyEqual n wh -> html5Key "" "" n wh "=" "" "equal"
-                KeyBar   n wh -> html5Key "" "" n wh "|" "" "bar"
-                KeyDot   n    -> html5Key "" "" n "" "." "" "dot"
-                KeyDash       -> html5Key "" "" "" "" "-" " " "dash"
-                KeyDashDash   -> html5Key "" "" "" "" "--" " " "dashdash"
-                KeyBrackets n -> html5Key "[" "" n "" "]" "" "dashdash"
-                KeyLower name attrs -> do
-                       H.span ! HA.class_ (mconcat ["key key-lower"," key-name-",attrify name]) $$ do
-                               H.span ! HA.class_ "key-mark" $$ html5ify '<'
-                               H.span ! HA.class_ "key-name" $$ html5ify name
+                       liftStateMarkup $ S.put s{state_pos=Pos lineNew 1}
+                       state_indent
+                       Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
+                       html5 $ List.replicate (colNew - colMid) ' '
+                       liftStateMarkup $ S.put s{state_pos=new}
+                EQ | colOld <= colNew -> do
+                       liftStateMarkup $ 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
-                KeySection lvl -> do
-                       H.section $$ do
-                               H.span ! HA.class_ "section-title" $$ do
-                                       H.span ! HA.class_ "section-mark" $$ do
-                                               html5ify $ Text.replicate lvl "#"
-                                       case Seq.viewl ts of
-                                        Tree0 title :< _ -> h lvl $$ html5ify title
-                                        _ -> return ()
-                               html5ify $
-                                       case Seq.viewl ts of
-                                        Tree0{} :< ts' -> ts'
-                                        _ -> 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 <- liftStateMarkup $ 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
-                       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
-               where
-               html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html5
-               html5Key markBegin whmb name whn markEnd whme cl = do
-                       H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrify name]) $$ do
-                               when (markBegin/="") $
-                                       H.span ! HA.class_ "key-mark" $$ html5ify markBegin
-                               html5ify whmb
-                               when (name/="") $
-                                       H.span ! HA.class_ "key-name" $$ html5ify name
-                               html5ify whn
-                               when (markEnd/="") $
-                                       H.span ! HA.class_ "key-mark" $$ html5ify markEnd
-                               html5ify whme
-                               H.span ! HA.class_ "key-value" $$
+                       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
-instance Html5ify Tokens where
-       html5ify = mapM_ html5ify
-instance Html5ify Token where
-       html5ify (TreeN (Cell bp ep p) ts) = do
-               case p of
-                PairElem name attrs -> do
-                       H.span ! HA.class_ ("pair-PairElem" <> " pair-elem-"<>attrify name) $$ do
-                               html5ify $ Cell bp bp{columnPos = columnPos bp + lenO} ()
-                               when (lenO > 0) $
-                                       H.span ! HA.class_ "pair-open"    $$ o
-                               when (not $ Seq.null ts) $
-                                       H.span ! HA.class_ "pair-content" $$ html5ify ts
-                               html5ify $ Cell ep{columnPos = columnPos ep - lenC} ep ()
-                               when (lenC > 0) $
-                                       H.span ! HA.class_ "pair-close"   $$ c
+                       html5HeaderRepeated :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
+                       html5HeaderRepeated markBegin whmb name whn markEnd whme cl = do
+                               State{state_indent} <- liftStateMarkup S.get
+                               liftStateMarkup $ S.modify' $ \s ->
+                                       s{ state_indent = do
+                                               state_indent
+                                               Pos _lineMid colMid <- liftStateMarkup $ 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
+                               liftStateMarkup $ S.modify' $ \s -> s{state_indent}
+                               return r
+               ----------------------
+                NodeText t -> do
+                       State{state_indent} <- liftStateMarkup S.get
+                       liftStateMarkup $ S.modify' $ \s ->
+                               s{ state_indent = do
+                                       state_indent
+                                       Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
+                                       html5ify $ List.replicate (pos_column bp - colMid) ' '
+                                }
+                       r <- html5ify t
+                       liftStateMarkup $ S.modify' $ \s -> s{state_indent}
+                       return r
+               ----------------------
+                NodePara -> do
+                       State{state_indent} <- liftStateMarkup S.get
+                       liftStateMarkup $ S.modify' $ \s ->
+                               s{ state_indent = do
+                                       state_indent
+                                       Pos _lineMid colMid <- liftStateMarkup $ S.gets state_pos
+                                       html5ify $ List.replicate (pos_column bp - colMid) ' '
+                                }
+                       r <- html5ify ts
+                       liftStateMarkup $ 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
-                       html5Name =
-                               H.span ! HA.class_ "elem-name" $$
-                                       html5ify name
-                       lenName = Text.length name
-                       lenAttrs = sum $ (<$> attrs) $ \(elemAttr_white,ElemAttr{..}) ->
-                               Text.length elemAttr_white +
-                               Text.length elemAttr_name +
-                               Text.length elemAttr_open +
-                               Text.length elemAttr_value +
-                               Text.length elemAttr_close
-                       (lenO,lenC) | Seq.null ts = (1+lenName+lenAttrs+2,0)
-                                   | otherwise   = (1+lenName+lenAttrs+1,2+lenName+1)
-                       o,c :: Html5
-                       (o,c) | Seq.null ts =
-                               ( "<"<>html5Name<>html5ify attrs<>"/>"
-                               , mempty )
-                             | otherwise =
-                               ( "<"<>html5Name<>html5ify attrs<>">"
-                               , "</"<>html5Name<>">" )
-                _ -> do
-                       let (o,c) = pairBorders p ts
-                       H.span ! HA.class_ ("pair-"<>fromString (show p)) $$ do
-                               html5ify $ Cell bp bp{columnPos = columnPos bp + Text.length o} ()
-                               H.span ! HA.class_ "pair-open"    $$ html5ify o
-                               H.span ! HA.class_ "pair-content" $$ html5ify ts
-                               html5ify $ Cell ep{columnPos = columnPos ep - Text.length c} ep ()
-                               H.span ! HA.class_ "pair-close"   $$ html5ify c
-       html5ify (Tree0 tok) = do
-               -- html5ify $ Cell bp ep ()
+                       em :: Html5 -> Html5
+                       em h =
+                               case pair of
+                                p | p == PairSlash
+                                 || p == PairFrenchquote
+                                 || p == PairDoublequote -> do
+                                       State{..} <- liftStateMarkup $ S.get
+                                       liftStateMarkup $ S.modify' $ \s -> s{state_italic = not state_italic}
+                                       r <- H.em ! HA.class_ (if state_italic then "even" else "odd") $$ h
+                                       liftStateMarkup $ S.modify' $ \s -> s{state_italic}
+                                       return r
+                                _ -> h
+instance Html5ify Token where
+       html5ify tok =
                case tok of
-                TokenPhrases ps -> html5ify ps
-                TokenRaw t -> html5ify t
-                       {-do
-                       lin <- S.get
-                       let lines = Text.splitOn "\n" txt
-                       let lnums = html5ify :
-                                [ \line -> do
-                                       html5ify '\n'
-                                       H.a ! HA.id ("line-"<>attrify lnum) $$ return ()
-                                       html5ify indent
-                                       html5ify line
-                                | lnum <- [lin+1..]
-                                ]
-                       S.put (lin - 1 + List.length lines)
-                       return $ mconcat $ List.zipWith ($) lnums lines
-                       -}
+                TokenText t -> html5ify t
                 TokenTag v ->
                        H.span ! HA.class_ "tag" $$ do
                                H.span ! HA.class_ "tag-open" $$
                                        html5ify '#'
                                html5ify v
-                TokenEscape c -> html5ify $ ('\\' :) . pure <$> c
-                TokenLink (Cell bp ep lnk) -> do
-                       html5ify $ Cell bp ep ()
-                       H.a ! HA.href (attrify lnk) $$
-                               html5ify lnk
-instance Html5ify Phrases where
-       html5ify = mapM_ html5ify
-instance Html5ify Phrase where
-       html5ify p =
-               case p of
-                PhraseWord  t -> html5ify t
-                PhraseWhite t -> html5ify t
-                PhraseOther t -> html5ify t
+                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
@@ -257,18 +323,3 @@ instance Html5ify (White,ElemAttr) where
                H.span ! HA.class_ "attr-value" $$
                        html5ify elemAttr_value
                html5ify elemAttr_close
-
--- * Utilities
-
-tokensTitle :: Trees (Cell Key) Tokens -> Maybe Tokens
-tokensTitle tct =
-       List.find (\case
-        TreeN (unCell -> KeySection{}) _ts -> True
-        _ -> False) tct >>=
-       \case
-        TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
-        _ -> Nothing
-
-html5Spaces :: Column -> Html5
-html5Spaces 0  = return ()
-html5Spaces sp = H.span $$ html5ify $ Text.replicate sp " "