Fix Show instances on newtypes.
[doclang.git] / Language / TCT / Write / HTML5.hs
index 511596dc65f14d8c24707da62b61d6e277a3a5ea..ce6bed0dd87ec8f85959d3461744c04cc366f50c 100644 (file)
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns #-}
--- | Render TCT as HTML5.
 module Language.TCT.Write.HTML5 where
 
-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 (($))
-import Data.Int (Int)
+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 (IsString(..))
-import Data.Text (Text)
-import Data.TreeSeq.Strict (Tree(..),Trees)
-import Prelude (Num(..), undefined)
+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.State as S
-import qualified Data.List as L
+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 qualified Text.Blaze.Html5.Attributes as HA
 
-import Text.Blaze.Utils
 import Language.TCT
-import Language.TCT.Write.Text
+-- import Language.TCT.Debug
+import Language.TCT.Utils
+import Text.Blaze.Utils
+import qualified Language.TCT.Write.Plain as Plain
 
-html5Document :: TCTs -> Html
-html5Document tct = 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 tct) $ \ts ->
-                               H.title $ H.toMarkup $ L.head $
-                                       TL.lines (textTokens ts) <> [""]
+                       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{}) =
+                       runStateMarkup def $
+                       html5ify body
                H.body $ do
-                       H.a ! HA.id ("line-1") $ return ()
-                       html5TreesCell (treePosLastCell tct)
+                       H.a ! HA.id "line-1" $ return ()
+                       html5Body
 
-html5TreesCell :: Trees (Pos,Cell Key) (Pos,Tokens) -> Html
-html5TreesCell = foldMap html5TreeCell
-
-tokensTitle :: Trees (Cell Key) Tokens -> Maybe Tokens
-tokensTitle tct =
-       L.find (\case
-        TreeN (unCell -> KeySection{}) _ts -> True
+titleFrom :: Roots -> Maybe Root
+titleFrom tct =
+       List.find (\case
+        Tree (unCell -> NodeHeader HeaderSection{}) _ts -> True
         _ -> False) tct >>=
        \case
-        TreeN (unCell -> KeySection _lvl) (Seq.viewl -> Tree0 title:<_) -> Just title
+        Tree (unCell -> NodeHeader (HeaderSection _lvl))
+             (Seq.viewl -> title:<_) -> Just title
         _ -> Nothing
 
-html5Text :: Text -> Html
-html5Text = H.toMarkup
-
-html5Spaces :: Int -> Html
-html5Spaces 0  = return ()
-html5Spaces sp = H.span $ html5Text $ Text.replicate sp " "
+-- * Type 'Html5'
+type Html5 = StateMarkup State ()
 
-html5TreeCell :: Tree (Pos,Cell Key) (Pos,Tokens) -> Html
-html5TreeCell (TreeN (posEnd, Cell pos _ (KeySection lvl)) ts) = do
-       html5IndentCell (posEnd,pos)
-       H.section $ do
-               H.span ! HA.class_ "section-title" $ do
-                       H.span $ html5Text $ Text.replicate lvl "#" <> " "
-                       case Seq.viewl ts of
-                        Tree0 (_,title) :< _ -> h lvl $ html5IndentToken title
-                        _ -> return ()
-               html5TreesCell $
-                       case Seq.viewl ts of {Tree0{} :< 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 > 0 = H.span ! HA.class_ ("h h"<>attrValue n)
-       h _ = undefined
-html5TreeCell (Tree0 (posEnd,toks)) =
-       case Seq.viewl toks of
-        EmptyL -> html5IndentToken toks
-        t0:<_  -> html5IndentCell (posEnd,posCell t0) <> html5IndentToken toks
-html5TreeCell (TreeN (posEnd,cell@(Cell pos _ _)) cs) =
-       html5IndentCell (posEnd,pos) <>
-       html5CellKey cell cs
+instance IsString Html5 where
+       fromString = mapM_ html5ify
 
-html5IndentCell :: (Pos,Pos) -> Html
-html5IndentCell (Pos lineLast colLast,Pos line col)
- | lineLast < line = do
-       forM_ [lineLast+1..line] $ \lnum -> do
-               H.toMarkup '\n'
-               H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
-       H.toMarkup $ Text.replicate (col - 1) " "
- | lineLast == line
- && colLast <= col = H.toMarkup $ Text.replicate (col - colLast) " "
- | otherwise = undefined
+html5 :: H.ToMarkup a => a -> Html5
+html5 = Compose . return . H.toMarkup
 
-html5CellKey :: Cell Key -> Trees (Pos,Cell Key) (Pos,Tokens) -> Html
-html5CellKey (Cell _pos _posEnd key) ts = do
-       case key of
-        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-",attrValue name]) $ do
-                       H.span ! HA.class_ "key-mark" $ H.toMarkup '<'
-                       H.span ! HA.class_ "key-name" $ H.toMarkup name
-                       html5Attrs attrs
-                       html5TreesCell ts
-       where
-       html5Key :: Text -> White -> Text -> White -> Text -> White -> H.AttributeValue -> Html
-       html5Key markBegin whmb name whn markEnd whme cl = do
-               -- html5Spaces $ colPos posEnd - (colPos pos + Text.length name + 1)
-               H.span ! HA.class_ (mconcat ["key key-",cl," key-name-",attrValue name]) $ do
-                       when (markBegin/="") $
-                               H.span ! HA.class_ "key-mark" $ H.toMarkup markBegin
-                       H.toMarkup whmb
-                       when (name/="") $
-                               H.span ! HA.class_ "key-name" $ H.toMarkup name
-                       H.toMarkup whn
-                       when (markEnd/="") $
-                               H.span ! HA.class_ "key-mark" $ H.toMarkup markEnd
-                       H.toMarkup whme
-                       H.span ! HA.class_ "key-value" $
-                               html5TreesCell ts
+-- ** Type 'State'
+data State
+ =   State
+ {   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_indent   = ""
+        , state_italic   = False
+        , state_ext_html = ".html"
+        }
+-- instance Pretty State
 
-html5IndentToken :: Tokens -> Html
-html5IndentToken toks =
-       case Seq.viewl toks of
-        EmptyL -> ""
-        Cell pos _ _ :< _ ->
-               goTokens toks `S.evalState` linePos pos
-               where
-               indent = Text.replicate (columnPos pos - 1) " "
-               go :: Cell Token -> S.State Int Html
-               go tok =
-                       case unCell tok of
-                        TokenPlain txt -> do
-                               lin <- S.get
-                               let lines = Text.splitOn "\n" txt
-                               let lnums = H.toMarkup :
-                                        [ \line -> do
-                                               H.toMarkup '\n'
-                                               H.a ! HA.id ("line-"<>attrValue lnum) $ return ()
-                                               H.toMarkup indent
-                                               H.toMarkup line
-                                        | lnum <- [lin+1..]
-                                        ]
-                               S.put (lin - 1 + L.length lines)
-                               return $ mconcat $ L.zipWith ($) lnums lines
-                        TokenTag v ->
-                               return $
-                                       H.span ! HA.class_ "tag" $ do
-                                               H.span ! HA.class_ "tag-open" $ H.toMarkup '#'
-                                               H.toMarkup v
-                        TokenEscape c -> return $ H.toMarkup ['\\',c]
-                        TokenLink lnk ->
-                               return $
-                                       H.a ! HA.href (attrValue lnk) $
-                                               H.toMarkup lnk
-                        TokenPair (PairElem name attrs) ts -> do
-                               h <- goTokens ts
-                               return $ do
-                                       let cl = mconcat ["pair-PairElem", " pair-elem-", attrValue name]
-                                       H.span ! HA.class_ cl $ do
-                                               whenMarkup o $ H.span ! HA.class_ "pair-open" $ o
-                                               whenMarkup h $ H.span ! HA.class_ "pair-content" $ h
-                                               whenMarkup c $ H.span ! HA.class_ "pair-close" $ c
+-- * Class 'Html5ify'
+class Html5ify a where
+       html5ify :: a -> Html5
+instance Html5ify () where
+       html5ify = mempty
+instance Html5ify Char where
+       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 = 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
+                       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 ()
+                       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
+               ----------------------
+                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
-                               html5name = H.span ! HA.class_ "elem-name" $ H.toMarkup name
-                               o,c :: Html
-                               (o,c) =
-                                       if Seq.null ts
-                                       then
-                                               ( "<"<>html5name<>html5Attrs attrs<>"/>"
-                                               , mempty )
-                                       else
-                                               ( "<"<>html5name<>html5Attrs attrs<>">"
-                                               , "</"<>html5name<>">" )
-                        TokenPair grp ts -> do
-                               h <- goTokens ts
-                               return $ do
-                                       let (o,c) = pairBorders grp ts
-                                       H.span ! HA.class_ (mconcat ["pair-", fromString $ show grp]) $ do
-                                               H.span ! HA.class_ "pair-open"    $ H.toMarkup o
-                                               H.span ! HA.class_ "pair-content" $ h
-                                               H.span ! HA.class_ "pair-close"   $ H.toMarkup c
-               goTokens :: Tokens -> S.State Int Html
-               goTokens ts = do
-                       ts' <- go`mapM`ts
-                       return $ foldr (<>) mempty ts'
-
-html5Attrs :: Attrs -> Html
-html5Attrs = foldMap html5Attr
-
-html5Attr :: (Text,Attr) -> Html
-html5Attr (attr_white,Attr{..}) = do
-       H.toMarkup attr_white
-       H.span ! HA.class_ "attr-name" $
-               H.toMarkup attr_name
-       H.toMarkup attr_open
-       H.span ! HA.class_ "attr-value" $
-               H.toMarkup attr_value
-       H.toMarkup attr_close
+                               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
+                       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
+                       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
+                       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
+                TokenText t -> html5ify t
+                TokenTag v ->
+                       H.span ! HA.class_ "tag" $$ do
+                               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 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