]> Git — Sourcephile - doclang.git/blob - Language/TCT/Read.hs
Fix href= in <toc>.
[doclang.git] / Language / TCT / Read.hs
1 module Language.TCT.Read
2 ( module Language.TCT.Read.Cell
3 , module Language.TCT.Read.Elem
4 , module Language.TCT.Read.Token
5 , module Language.TCT.Read.Tree
6 , module Language.TCT.Read
7 ) where
8
9 import Control.Applicative (Applicative(..))
10 import Control.Arrow (left)
11 import Control.Monad (Monad(..), join, (=<<))
12 import Data.Bool
13 import Data.Either (Either(..))
14 import Data.Eq (Eq(..))
15 import Data.Foldable (Foldable(..), any)
16 import Data.Function (($), (.))
17 import Data.Functor ((<$>))
18 import Data.Functor.Compose (Compose(..))
19 import Data.List.NonEmpty (NonEmpty(..))
20 import Data.Semigroup (Semigroup(..))
21 import Data.Traversable (Traversable(..))
22 import Data.TreeSeq.Strict (Tree(..), Trees)
23 import Data.Void (Void)
24 import System.FilePath ((</>))
25 import System.IO (FilePath, IO)
26 import Text.Show (Show(..), showString)
27 import qualified Control.Monad.Trans.Reader as R
28 import qualified Data.ByteString.Lazy as BSL
29 import qualified Data.Text.Lazy as TL
30 import qualified Data.Text.Lazy.Encoding as TL
31 import qualified System.Directory as Directory
32 import qualified System.FilePath as FilePath
33 import qualified System.IO.Error as IO
34 import qualified Text.Megaparsec as P
35
36 import Language.TCT.Debug
37 import Language.TCT.Tree
38 import Language.TCT.Cell
39 import Language.TCT.Read.Cell
40 import Language.TCT.Read.Elem
41 import Language.TCT.Read.Tree
42 import Language.TCT.Read.Token
43
44 -- | Parsing is done in two phases:
45 --
46 -- 1. indentation-sensitive parsing on 'TL.Text'
47 -- 2. Pair-sensitive parsing on some 'NodeText's resulting of 1.
48 readTCT :: FilePath -> IO (Either ErrorRead (Trees (Cell Node)))
49 readTCT inp = do
50 inpFileCanon <-
51 Directory.makeRelativeToCurrentDirectory =<<
52 Directory.canonicalizePath inp
53 goFile (NodeHeader HeaderDash) $
54 Span inpFileCanon pos1 pos1:|[]
55 where
56 goFile :: Node -> NonEmpty Span -> IO (Either ErrorRead (Trees (Cell Node)))
57 goFile parentNode spans@(Span{span_file=inpFile}:|inpPath)
58 | any (\Span{span_file} -> span_file == inpFile) inpPath =
59 return $ Left $ ErrorReadIncludeLoop spans
60 | otherwise = do
61 readFile inpFile >>= \case
62 Left err -> return $ Left $ ErrorReadIO spans err
63 Right inpText ->
64 case (`R.runReader` inpPath) $ P.runParserT (p_Trees <* P.eof) inpFile inpText of
65 Left err -> return $ Left $ ErrorReadParser err
66 Right trees ->
67 (join <$>) . sequence <$>
68 traverse
69 (goTree parentNode)
70 (debug0 "readTCTWithIncludes" trees)
71 goTree :: Node -> Tree (Cell Node) -> IO (Either ErrorRead (Trees (Cell Node)))
72 goTree parNode t@(Tree c@(Cell ss@(Span{span_file}:|_sn) nod) ts) =
73 case nod of
74 NodeLower{} -> return $ Right $ pure t
75 -- NOTE: preserve NodeText ""
76 NodeText n | TL.null n -> return $ Right $ pure t
77 NodeText n ->
78 case parNode of
79 NodeHeader HeaderBar{} -> return $ Right $ pure t
80 NodeHeader HeaderEqual{} -> return $ Right $ pure t
81 NodeHeader HeaderDashDash{} -> return $ Right $ pure t
82 _ ->
83 return $ left ErrorReadParser $
84 parseTokens <$> parseLexemes (Cell ss n)
85 NodeHeader (HeaderDotSlash incFile) -> do
86 incFileCanon <-
87 Directory.makeRelativeToCurrentDirectory =<<
88 Directory.canonicalizePath
89 (FilePath.takeDirectory span_file </> incFile)
90 ((pure . Tree c <$>) <$>) $
91 -- NOTE: preserve HeaderDotSlash to avoid Seq.spanl
92 -- to merge nodes accross files, when writing XML
93 goFile parNode $ Span incFileCanon pos1 pos1 :| toList ss
94 _ ->
95 (pure . Tree c . join <$>) .
96 sequence <$> traverse (goTree nod') ts
97 where
98 -- NOTE: skip parent 'Node's whose semantic does not change 'NodeText'
99 nod' = case nod of
100 NodePara -> parNode
101 _ -> nod
102
103 readFile :: FilePath -> IO (Either IO.IOError TL.Text)
104 readFile fp =
105 (Right . TL.decodeUtf8 <$> BSL.readFile fp)
106 `IO.catchIOError` \e ->
107 if IO.isAlreadyInUseError e
108 || IO.isDoesNotExistError e
109 || IO.isPermissionError e
110 then return $ Left e
111 else IO.ioError e
112
113 -- | Useful when producing only an exact source file rendition.
114 readTCTWithoutIncludes ::
115 FilePath -> TL.Text ->
116 Either ErrorRead (Trees (Cell Node))
117 readTCTWithoutIncludes inp txt = do
118 trs <-
119 left ErrorReadParser $
120 (`R.runReader` []) $
121 P.runParserT (p_Trees <* P.eof) inp txt
122 join <$> traverse (go $ NodeHeader HeaderDash)
123 (debug0 "readTCT" trs)
124 where
125 go :: Node -> Tree (Cell Node) -> Either ErrorRead (Trees (Cell Node))
126 go parent t@(Tree c@(Cell ssn nod) ts) =
127 case nod of
128 NodeLower{} -> Right $ pure t
129 -- NOTE: preserve NodeText ""
130 NodeText n | TL.null n -> Right $ pure t
131 NodeText n ->
132 case parent of
133 NodeHeader HeaderBar{} -> Right $ pure t
134 NodeHeader HeaderEqual{} -> Right $ pure t
135 NodeHeader HeaderDashDash{} -> Right $ pure t
136 _ -> left ErrorReadParser $ parseTokens <$> parseLexemes (Cell ssn n)
137 _ -> pure . Tree c . join <$> traverse (go nod') ts
138 where
139 -- NOTE: skip parent 'Node's whose semantic does not change 'NodeText'
140 nod' = case nod of
141 NodePara -> parent
142 _ -> nod
143
144 dependencies :: Trees (Cell Node) -> [FilePath]
145 dependencies = foldr f [] . Compose
146 where
147 f (Cell _ss n) acc =
148 case n of
149 NodeHeader (HeaderDotSlash file) -> file:acc
150 _ -> acc
151
152 -- * Type 'ErrorRead'
153 data ErrorRead
154 = ErrorReadParser (P.ParseError (P.Token TL.Text) (P.ErrorFancy Void))
155 | ErrorReadIncludeLoop Spans
156 | ErrorReadIO Spans IO.IOError
157 deriving (Eq)
158 instance Show ErrorRead where
159 showsPrec _p = \case
160 ErrorReadParser e ->
161 showString (P.parseErrorPretty e)
162 ErrorReadIncludeLoop (Span{..}:|spans) ->
163 showString "ErrorReadIncludeLoop" .
164 showString "\n " . showString span_file .
165 showString (foldMap (\s -> "\n included by "<>show s) spans)
166 ErrorReadIO (_:|spans) err ->
167 showString "ErrorReadIO" .
168 showString "\n " . showsPrec 10 err .
169 showString (foldMap (\s -> "\n in "<>show s) spans)