{-# 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)
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"
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
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 " "