Add basic support for HeaderDotSlash including.

diff --git a/Language/DTC/Write/HTML5.hs b/Language/DTC/Write/HTML5.hs
index 83c0534055e17d6664090b17d363107c45a96f6d..eb87c8451a748ab21665db0051f84e85aa71a786 100644 (file)
--- a/Language/DTC/Write/HTML5.hs
+++ b/Language/DTC/Write/HTML5.hs
@@ -103,6 +103,9 @@ html5Head State{..} Head{DTC.about=About{..}} body = do
                forM_ links $ \Link{rel, href} ->
                        H.link ! HA.rel (attrify rel)
                               ! HA.href (attrify href)
+               forM_ url $ \href ->
+                       H.link ! HA.rel "self"
+                              ! HA.href (attrify href)
                H.meta ! HA.name "generator"
                       ! HA.content "https://hackage.haskell.org/package/hdoc"
                unless (null tags) $

diff --git a/Language/TCT/Read.hs b/Language/TCT/Read.hs
index 09577fe08797bc893d4ebc9c762e0962ca890179..e3082d466218d106a11f2af2e198894f1065249a 100644 (file)
--- a/Language/TCT/Read.hs
+++ b/Language/TCT/Read.hs
@@ -6,16 +6,26 @@ module Language.TCT.Read
  ) where
 
 import Control.Applicative (Applicative(..))
+import Control.Arrow (left)
 import Control.Monad (Monad(..), join)
+import Data.Bool
 import Data.Either (Either(..))
-import Data.Foldable (Foldable(..))
+import Data.Eq (Eq)
 import Data.Function (($), (.))
 import Data.Functor ((<$>))
+import Data.Ord (Ord(..))
+import Data.Set (Set)
 import Data.Traversable (Traversable(..))
 import Data.TreeSeq.Strict (Tree(..), Trees)
 import Data.Void (Void)
-import System.IO (FilePath)
+import System.FilePath ((</>))
+import System.IO (FilePath, IO)
+import Text.Show (Show(..), showParen, showString, showChar)
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Set as Set
 import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TL
+import qualified System.FilePath as FilePath
 import qualified Text.Megaparsec as P
 
 import Language.TCT.Debug
@@ -33,7 +43,7 @@ readTCT ::
  FilePath -> TL.Text ->
  Either ErrorRead (Trees (Cell Node))
 readTCT inp txt = do
-       trs <- P.runParser (p_Trees <* P.eof) inp txt
+       trs <- left ErrorReadParser $ P.runParser (p_Trees <* P.eof) inp txt
        join <$> traverse (go $ NodeHeader HeaderDash)
         (debug0 "readTCT" trs)
        where
@@ -48,9 +58,7 @@ readTCT inp txt = do
                         NodeHeader HeaderBar{}      -> Right $ pure t
                         NodeHeader HeaderEqual{}    -> Right $ pure t
                         NodeHeader HeaderDashDash{} -> Right $ pure t
-                        _ -> do
-                               toks <- parseTokens <$> parseLexemes inp (Cell bn en n)
-                               Right $ toks
+                        _ -> left ErrorReadParser $ parseTokens <$> parseLexemes inp (Cell bn en n)
                 _ -> pure . Tree c . join <$> traverse (go nod') ts
                        where
                        -- NOTE: skip parent 'Node's whose semantic does not change 'NodeText'
@@ -58,5 +66,63 @@ readTCT inp txt = do
                         NodePara -> parent
                         _ -> nod
 
+readFile :: FilePath -> IO TL.Text
+readFile fp = TL.decodeUtf8 <$> BSL.readFile fp
+
+readTCTrec :: FilePath -> IO (Either ErrorRead (Trees (Cell Node)))
+readTCTrec = goFile Set.empty (NodeHeader HeaderDash)
+       where
+       goFile :: Set FilePath -> Node -> FilePath -> IO (Either ErrorRead (Trees (Cell Node)))
+       goFile inputFiles parentNode inpFile
+        | Set.member inpFileNorm inputFiles =
+               return $ Left $ ErrorReadIncludeLoop inpFileNorm
+        | otherwise = do
+               inpText <- readFile inpFileNorm
+               case P.runParser (p_Trees <* P.eof) inpFileNorm inpText of
+                Left err -> return $ Left $ ErrorReadParser err
+                Right trees ->
+                       (join <$>) . sequence <$>
+                       traverse
+                        (goTree (Set.insert inpFileNorm inputFiles) parentNode)
+                        (debug0 "readTCTrec" trees)
+               where
+               inpFileNorm = FilePath.normalise inpFile
+               goTree :: Set FilePath -> Node -> Tree (Cell Node) -> IO (Either ErrorRead (Trees (Cell Node)))
+               goTree inpFiles parNode t@(Tree c@(Cell bn en nod) ts) =
+                       case nod of
+                        NodeLower{} -> return $ Right $ pure t
+                        -- NOTE: preserve NodeText ""
+                        NodeText n | TL.null n -> return $ Right $ pure t
+                        NodeText n ->
+                               case parNode of
+                                NodeHeader HeaderBar{}      -> return $ Right $ pure t
+                                NodeHeader HeaderEqual{}    -> return $ Right $ pure t
+                                NodeHeader HeaderDashDash{} -> return $ Right $ pure t
+                                _ ->
+                                       return $ left ErrorReadParser $
+                                       parseTokens <$> parseLexemes inpFileNorm (Cell bn en n)
+                        NodeHeader (HeaderDotSlash incFile) ->
+                               goFile inpFiles parNode $
+                               FilePath.takeDirectory inpFileNorm </> incFile
+                        _ ->
+                               (pure . Tree c . join <$>) .
+                               sequence <$> traverse (goTree inpFiles nod') ts
+                               where
+                               -- NOTE: skip parent 'Node's whose semantic does not change 'NodeText'
+                               nod' = case nod of
+                                NodePara -> parNode
+                                _ -> nod
+
 -- * Type 'ErrorRead'
-type ErrorRead = P.ParseError (P.Token TL.Text) (P.ErrorFancy Void)
+data ErrorRead
+ =   ErrorReadParser (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void))
+ |   ErrorReadIncludeLoop FilePath
+ deriving (Eq)
+instance Show ErrorRead where
+       showsPrec p = \case
+        ErrorReadParser e ->
+               showParen (p >= 10) $
+               showString (P.parseErrorPretty e)
+        ErrorReadIncludeLoop file ->
+               showString "ErrorReadIncludeLoop" .
+               showChar ' ' . showsPrec 10 file

diff --git a/Language/TCT/Read/Cell.hs b/Language/TCT/Read/Cell.hs
index 602d7ce3f2372d048feaf12ff6e2c088824a4591..46f83fb153158c3003c7defa42037876d7d82120 100644 (file)
--- a/Language/TCT/Read/Cell.hs
+++ b/Language/TCT/Read/Cell.hs
@@ -50,6 +50,9 @@ p_satisfyMaybe f = check `P.token` Nothing
                 Just a  -> Right a
                 Nothing -> Left (Just $ P.Tokens $ c:|[], Set.empty)
 
+p_SourceFile :: Parser e s FilePath
+p_SourceFile = P.sourceName <$> P.getPosition
+
 p_Position :: Parser e s Pos
 p_Position = (<$> P.getPosition) $ \p ->
        Pos

diff --git a/Language/TCT/Write/HTML5.hs b/Language/TCT/Write/HTML5.hs
index 90b87e051d8459bc8632d80acc7f32cea1a43e3b..8631224e64a06b5d5a3a1e5c1197b874be924ff3 100644 (file)
--- a/Language/TCT/Write/HTML5.hs
+++ b/Language/TCT/Write/HTML5.hs
@@ -77,15 +77,17 @@ html5 = Compose . return . H.toMarkup
 -- ** Type 'State'
 data State
  =   State
- {   state_pos           :: Pos
- ,   state_indent        :: Html5
- ,   state_italic        :: Bool
+ {   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_pos      = pos1
+        , state_indent   = ""
+        , state_italic   = False
+        , state_ext_html = ".html"
         }
 -- instance Pretty State
 
@@ -167,7 +169,6 @@ instance Html5ify Root where
                         HeaderColon n wh -> html5Header "" "" n wh ":" "" "colon"
                         HeaderEqual n wh -> html5Header "" "" n wh "=" "" "equal"
                         HeaderDot   n    -> html5Header "" "" n "" "." "" "dot"
-                        HeaderDotSlash n -> html5Header "./" "" (fromString n) "" "" "" "dotslash"
                         HeaderDash       -> html5Header "" "" "" "" "-" " " "dash"
                         HeaderDashDash   -> html5Header "" "" "" "" "--" " " "dashdash"
                         HeaderBrackets n -> html5Header "[" "" n "" "]" "" "dashdash"
@@ -192,6 +193,15 @@ instance Html5ify Root where
                                h 6 = H.h6
                                h n | n > 6 = H.span ! HA.class_ ("h h"<>attrify n)
                                h _ = undefined
+                        HeaderDotSlash n -> 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 file = "./"<>n
                        where
                        html5Head :: Name -> White -> Name -> White -> TL.Text -> White -> H.AttributeValue -> Html5
                        html5Head markBegin whmb name whn markEnd whme cl = do