]> Git — Sourcephile - doclang.git/blob - Hdoc/DTC/Read/TCT.hs
Rename Language -> Hdoc.
[doclang.git] / Hdoc / DTC / Read / TCT.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE TypeFamilies #-}
6 {-# LANGUAGE ViewPatterns #-}
7 {-# OPTIONS_GHC -fno-warn-orphans #-}
8 -- | Read DTC from TCT.
9 module Hdoc.DTC.Read.TCT where
10
11 import Control.Applicative (Applicative(..))
12 import Control.Monad (Monad(..))
13 import Data.Bool
14 import Data.Default.Class (Default(..))
15 import Data.Either (Either(..))
16 import Data.Eq (Eq(..))
17 import Data.Foldable (Foldable(..))
18 import Data.Function (($), (.), const, id)
19 import Data.Functor ((<$>), (<$))
20 import Data.Int (Int)
21 import Data.List.NonEmpty (NonEmpty(..))
22 import Data.Maybe (Maybe(..), maybe)
23 import Data.Monoid (Monoid(..), First(..))
24 import Data.Ord (Ord(..))
25 import Data.Proxy (Proxy(..))
26 import Data.Semigroup (Semigroup(..))
27 import Data.Sequence (ViewL(..), (|>))
28 import Data.String (String)
29 import Data.Tuple (snd)
30 import Prelude (Num(..))
31 import Text.Read (readMaybe)
32 import Text.Show (Show(..))
33 import qualified Control.Monad.Trans.State as S
34 import qualified Data.List as List
35 import qualified Data.Map.Strict as Map
36 import qualified Data.Sequence as Seq
37 import qualified Data.Set as Set
38 import qualified Data.Text.Lazy as TL
39 import qualified Text.Megaparsec as P
40 import qualified Text.Megaparsec.Perm as P
41
42 import Hdoc.TCT hiding (Parser, ErrorRead)
43 import Hdoc.XML
44 import qualified Hdoc.DTC.Document as DTC
45 import qualified Hdoc.DTC.Sym as DTC
46 import qualified Hdoc.RNC.Sym as RNC
47
48 -- * Type 'State'
49 type State = DTC.Pos
50
51 -- * Type 'Parser'
52 -- type Parser = P.Parsec ErrorRead XMLs
53 type Parser = S.StateT State (P.Parsec ErrorRead XMLs)
54
55 instance RNC.Sym_Rule Parser where
56 -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
57 rule _n = id
58 instance RNC.Sym_RNC Parser where
59 none = P.label "none" $ P.eof
60 fail = P.label "fail" $ P.failure Nothing mempty
61 any = P.label "any" $ p_satisfyMaybe $ const $ Just ()
62 anyElem p = P.label "anyElem" $ do
63 (n,ts) <- P.token check $ Just expected
64 parserXMLs (p n) ts
65 where
66 expected = Tree (cell0 $ XmlElem "*") mempty
67 check (Tree (unCell -> XmlElem e) ts) = Right (e,ts)
68 check t = Left
69 ( Just $ P.Tokens $ pure t
70 , Set.singleton $ P.Tokens $ pure expected )
71 element n p = do
72 ts <- P.token check $ Just expected
73 pos <- S.get
74 let nameOrFigureName
75 | n == "figure"
76 -- NOTE: special case renaming the current DTC.Pos
77 -- using the @type attribute to have positions like this:
78 -- section1.Quote1
79 -- section1.Example1
80 -- section1.Quote2
81 -- instead of:
82 -- section1.figure1
83 -- section1.figure2
84 -- section1.figure3
85 , Just ty <- getFirst $ (`foldMap` ts) $ \case
86 Tree0 (unCell -> XmlAttr "type" ty) -> First $ Just ty
87 _ -> First Nothing
88 = xmlLocalName $ ty
89 | otherwise = n
90 let anc name = maybe 1 (+1) $ Map.lookup name $ DTC.posPrecedingsSiblings pos
91 S.put pos
92 { DTC.posAncestors = DTC.posAncestors pos |> (n,anc n)
93 , DTC.posAncestorsWithFigureNames =
94 DTC.posAncestorsWithFigureNames pos |>
95 (nameOrFigureName,anc nameOrFigureName)
96 , DTC.posPrecedingsSiblings = mempty
97 }
98 res <- parserXMLs p ts
99 S.put pos
100 { DTC.posPrecedingsSiblings=
101 (if n /= nameOrFigureName
102 then Map.insertWith (\_new old -> old + 1) nameOrFigureName 1
103 else id) $
104 Map.insertWith (\_new old -> old + 1) n 1 $
105 DTC.posPrecedingsSiblings pos
106 }
107 return res
108 where
109 expected = Tree (cell0 $ XmlElem n) mempty
110 check (Tree (unCell -> XmlElem e) ts) | e == n = Right ts
111 check t = Left
112 ( Just $ P.Tokens $ pure t
113 , Set.singleton $ P.Tokens $ pure expected )
114 attribute n p = do
115 v <- P.token check $ Just expected
116 parserXMLs p v
117 where
118 expected = Tree0 (cell0 $ XmlAttr n "")
119 check (Tree0 (Cell sp (XmlAttr k v))) | k == n =
120 Right $ Seq.singleton $ Tree0 $ Cell sp $ XmlText v
121 check t = Left
122 ( Just $ P.Tokens $ pure t
123 , Set.singleton $ P.Tokens $ pure expected )
124 comment = do
125 s <- P.getInput
126 case Seq.viewl s of
127 Tree0 (unCell -> XmlComment c) :< ts -> do
128 P.setInput ts
129 c <$ fixPos
130 t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
131 EmptyL -> P.failure Nothing ex
132 where
133 ex = Set.singleton $ P.Tokens $ pure expected
134 expected = Tree0 (cell0 $ XmlComment "")
135 text = do
136 P.token check (Just expected)
137 <* fixPos
138 where
139 expected = Tree0 (cell0 $ XmlText "")
140 check (Tree0 (unCell -> XmlText t)) = Right t
141 check t = Left
142 ( Just $ P.Tokens $ pure t
143 , Set.singleton $ P.Tokens $ pure expected )
144 int = RNC.rule "int" $ RNC.text >>= \t ->
145 case readMaybe (TL.unpack t) of
146 Just i -> return i
147 Nothing -> P.fancyFailure $
148 Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Int t
149 nat = RNC.rule "nat" $ RNC.int >>= \i ->
150 if i >= 0
151 then return $ Nat i
152 else P.fancyFailure $ Set.singleton $
153 P.ErrorCustom $ ErrorRead_Not_Nat i
154 nat1 = RNC.rule "nat1" $ RNC.int >>= \i ->
155 if i > 0
156 then return $ Nat1 i
157 else P.fancyFailure $ Set.singleton $
158 P.ErrorCustom $ ErrorRead_Not_Nat1 i
159 (<|>) = (P.<|>)
160 many = P.many
161 some = P.some
162 optional = P.optional
163 option = P.option
164 choice = P.choice
165 try = P.try
166 type instance RNC.Perm Parser = P.PermParser XMLs Parser
167 instance RNC.Sym_Interleaved Parser where
168 interleaved = P.makePermParser
169 (<$$>) = (P.<$$>)
170 (<||>) = (P.<||>)
171 (<$?>) = (P.<$?>)
172 (<|?>) = (P.<|?>)
173 f <$*> a = f P.<$?> ([],P.some a)
174 f <|*> a = f P.<|?> ([],P.some a)
175 instance DTC.Sym_DTC Parser where
176 position = S.get
177
178 readDTC ::
179 DTC.Sym_DTC Parser =>
180 XMLs ->
181 Either (P.ParseError (P.Token XMLs) ErrorRead) DTC.Document
182 readDTC = parseXMLs def (P.initialPos "") DTC.document
183
184 parseXMLs ::
185 DTC.Sym_DTC Parser =>
186 State ->
187 P.SourcePos -> Parser a -> XMLs ->
188 Either (P.ParseError (P.Token XMLs) ErrorRead) a
189 parseXMLs st pos p i =
190 snd $
191 P.runParser' ((`S.evalStateT` st) $ p <* RNC.none)
192 P.State
193 { P.stateInput = i
194 , P.statePos = pure $
195 case Seq.viewl i of
196 Tree (Cell (Span{span_begin=bp}:|_) _) _ :< _ ->
197 P.SourcePos "" -- FIXME: put a FilePath
198 (P.mkPos $ pos_line bp)
199 (P.mkPos $ pos_column bp)
200 EmptyL -> pos
201 , P.stateTabWidth = P.pos1
202 , P.stateTokensProcessed = 0
203 }
204
205 -- | @parserXMLs st pos p xs@ returns a 'Parser' parsing @xs@ with @p@ from state @st@.
206 parserXMLs ::
207 DTC.Sym_DTC Parser =>
208 Parser a -> XMLs -> Parser a
209 parserXMLs p xs = do
210 pos <- P.getPosition
211 st <- S.get
212 case parseXMLs st pos p xs of
213 Left (P.TrivialError (posErr:|_) un ex) -> do
214 P.setPosition posErr
215 P.failure un ex
216 Left (P.FancyError (posErr:|_) errs) -> do
217 P.setPosition posErr
218 P.fancyFailure errs
219 Right a -> a <$ fixPos
220
221 -- | Adjust the current 'P.SourcePos'
222 -- to be the begining of the following-sibling 'XML' node
223 -- so that on error 'P.toHints' keeps expected 'P.Token's in the list,
224 -- and thus makes useful error messages.
225 --
226 -- This is needed because the end of a 'Cell'
227 -- is not necessarily the begin of the next 'Cell'.
228 fixPos :: Parser ()
229 fixPos = do
230 P.State
231 { P.stateInput = inp
232 , P.statePos = pos :| _
233 } <- P.getParserState
234 case Seq.viewl inp of
235 EmptyL -> return ()
236 t :< _ -> P.setPosition $
237 P.positionAt1 (Proxy::Proxy XMLs) pos t
238
239 instance P.Stream XMLs where
240 type Token XMLs = XML
241 type Tokens XMLs = XMLs
242 take1_ s =
243 case Seq.viewl s of
244 Tree (unCell -> XmlComment{}) _ :< ts -> P.take1_ ts
245 t:<ts -> Just (t,ts)
246 EmptyL -> Nothing
247 positionAt1 _s pos (Tree (Cell (Span{span_begin=Pos l c}:|_) _n) _ts) =
248 P.SourcePos (P.sourceName pos) (P.mkPos l) (P.mkPos c)
249 positionAtN s pos ts =
250 case Seq.viewl ts of
251 t :< _ -> P.positionAt1 s pos t
252 EmptyL -> pos
253 advance1 _s _indent pos (Tree (Cell (Span{span_end=Pos l c}:|_) _n) _ts) =
254 -- WARNING: the end of a 'Cell' is not necessarily
255 -- the beginning of the next 'Cell'.
256 P.SourcePos (P.sourceName pos) (P.mkPos l) (P.mkPos c)
257 advanceN s = foldl' . P.advance1 s
258 takeN_ n s | n <= 0 = Just (mempty, s)
259 | null s = Nothing
260 | otherwise = Just (Seq.splitAt n s) -- FIXME: handle XmlComment and XmlInclude
261 tokensToChunk _s = Seq.fromList
262 chunkToTokens _s = toList
263 chunkLength _s = Seq.length
264 takeWhile_ = Seq.spanl
265 instance P.ShowToken XML where
266 showTokens toks = List.intercalate ", " $ toList $ showTree <$> toks
267 where
268 showTree :: XML -> String
269 showTree (Tree a _ts) =
270 showCell a $ \case
271 XmlElem n -> "<"<>show n<>">"
272 XmlAttr n _v -> show n<>"="
273 XmlText _t -> "text"
274 XmlComment _c -> "comment"
275
276 showCell (Cell path@(Span{span_file} :| _) a) f =
277 if null span_file
278 then f a
279 else f a <> foldMap (\p -> "\n in "<>show p) path
280
281 -- ** Type 'ErrorRead'
282 data ErrorRead
283 = ErrorRead_EndOfInput
284 | ErrorRead_Not_Int TL.Text
285 | ErrorRead_Not_Nat Int
286 | ErrorRead_Not_Nat1 Int
287 -- | ErrorRead_Unexpected P.sourcePos XML
288 deriving (Eq,Ord,Show)
289 instance P.ShowErrorComponent ErrorRead where
290 showErrorComponent = show