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.Ratio ((%))
  27 import Data.Semigroup (Semigroup(..))
  28 import Data.Sequence (ViewL(..), (|>))
  29 import Data.String (String)
  30 import Data.Tuple (fst, snd)
  31 import Prelude (succ)
  32 import Text.Read (readMaybe, Read(..))
  33 import Text.Show (Show(..))
  34 import qualified Control.Monad.Trans.State as S
  35 import qualified Data.List as List
  36 import qualified Data.Map.Strict as Map
  37 import qualified Data.Ratio as Ratio
  38 import qualified Data.Sequence as Seq
  39 import qualified Data.Set as Set
  40 import qualified Data.Text.Lazy as TL
  41 import qualified GHC.Read as Read (expectP)
  42 import qualified Text.Megaparsec as P
  43 import qualified Text.Megaparsec.Perm as P
  44 import qualified Text.Read as Read
  45
  46 import Hdoc.TCT hiding (Parser, ErrorRead)
  47 import Hdoc.XML
  48 import qualified Hdoc.DTC.Document as DTC
  49 import qualified Hdoc.DTC.Sym as DTC
  50 import qualified Hdoc.RNC.Sym as RNC
  51
  52 -- * Type 'State'
  53 type State = DTC.Pos
  54
  55 -- * Type 'Parser'
  56 -- type Parser = P.Parsec ErrorRead XMLs
  57 type Parser = S.StateT State (P.Parsec ErrorRead XMLs)
  58
  59 instance RNC.Sym_Rule Parser where
  60         -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
  61         rule _n = id
  62 instance RNC.Sym_RNC Parser where
  63         none = P.label "none" $ P.eof
  64         fail = P.label "fail" $ P.failure Nothing mempty
  65         any  = P.label "any" $ p_satisfyMaybe $ const $ Just ()
  66         anyElem p = P.label "anyElem" $ do
  67                 (n,ts) <- P.token check $ Just expected
  68                 parser (p n) ts
  69                 where
  70                 expected = Tree (cell0 $ XmlElem "*") mempty
  71                 check (Tree (unCell -> XmlElem e) ts) = Right (e,ts)
  72                 check t = Left
  73                  ( Just $ P.Tokens $ pure t
  74                  , Set.singleton $ P.Tokens $ pure expected )
  75         element n p = do
  76                 ts <- P.token check $ Just expected
  77                 let mayNameOrFigureName
  78                         | n == "aside" = Nothing
  79                         -- NOTE: skip aside.
  80                         | n == "figure"
  81                         -- NOTE: special case renaming the current DTC.Pos
  82                         -- using the @type attribute to have positions like this:
  83                         --   section1.Quote1
  84                         --   section1.Example1
  85                         --   section1.Quote2
  86                         -- instead of:
  87                         --   section1.figure1
  88                         --   section1.figure2
  89                         --   section1.figure3
  90                         , Just ty <- getFirst $ (`foldMap` ts) $ \case
  91                          Tree0 (unCell -> XmlAttr "type" ty) -> First $ Just ty
  92                          _ -> First Nothing
  93                         = Just $ xmlLocalName $ ty
  94                         | otherwise = Just n
  95                 case mayNameOrFigureName of
  96                  Nothing -> parser p ts
  97                  Just nameOrFigureName -> do
  98                         pos <- S.get
  99                         let incrPrecedingSibling name =
 100                                 maybe 1 succ $
 101                                 Map.lookup name $
 102                                 DTC.pos_PrecedingSiblings pos
 103                         S.put pos -- NOTE: in children, push current name incremented on ancestors
 104                                   -- and reset preceding siblings.
 105                          { DTC.pos_PrecedingSiblings = mempty
 106                          , DTC.pos_Ancestors = DTC.pos_Ancestors pos |> (n, incrPrecedingSibling n)
 107                          , DTC.pos_AncestorsWithFigureNames =
 108                                 DTC.pos_AncestorsWithFigureNames pos |>
 109                                 ( nameOrFigureName
 110                                 , incrPrecedingSibling nameOrFigureName )
 111                          }
 112                         res <- parser p ts
 113                         S.put pos -- NOTE: after current, increment current name
 114                                   -- and reset ancestors.
 115                          { DTC.pos_PrecedingSiblings =
 116                                 (if n == nameOrFigureName then id
 117                                 else Map.insertWith (const succ) nameOrFigureName 1) $
 118                                 Map.insertWith (const succ) n 1 $
 119                                 DTC.pos_PrecedingSiblings pos
 120                          }
 121                         return res
 122                 where
 123                 expected = Tree (cell0 $ XmlElem n) mempty
 124                 check (Tree (unCell -> XmlElem e) ts) | e == n = Right ts
 125                 check t = Left
 126                  ( Just $ P.Tokens $ pure t
 127                  , Set.singleton $ P.Tokens $ pure expected )
 128         attribute n p = do
 129                 v <- P.token check $ Just expected
 130                 parser p v
 131                 where
 132                 expected = Tree0 (cell0 $ XmlAttr n "")
 133                 check (Tree0 (Cell sp (XmlAttr k v))) | k == n =
 134                         Right $ Seq.singleton $ Tree0 $ Cell sp $ XmlText v
 135                 check t = Left
 136                  ( Just $ P.Tokens $ pure t
 137                  , Set.singleton $ P.Tokens $ pure expected )
 138         comment = do
 139                 s <- P.getInput
 140                 case Seq.viewl s of
 141                  Tree0 (unCell -> XmlComment c) :< ts -> do
 142                         P.setInput ts
 143                         c <$ setPosOnNextNode
 144                  t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
 145                  EmptyL -> P.failure Nothing ex
 146                 where
 147                 ex = Set.singleton $ P.Tokens $ pure expected
 148                 expected = Tree0 (cell0 $ XmlComment "")
 149         text = do
 150                 P.token check (Just expected)
 151                  <* setPosOnNextNode
 152                 where
 153                 expected = Tree0 (cell0 $ XmlText "")
 154                 check (Tree0 (unCell -> XmlText t)) = Right t
 155                 check t = Left
 156                  ( Just $ P.Tokens $ pure t
 157                  , Set.singleton $ P.Tokens $ pure expected )
 158         int = RNC.rule "int" $ RNC.text >>= \t ->
 159                 case readMaybe (TL.unpack t) of
 160                  Just i -> return i
 161                  Nothing -> P.fancyFailure $
 162                         Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Int t
 163         rational = RNC.rule "rational" $ RNC.text >>= \t ->
 164                 case readMaybe (TL.unpack t) of
 165                  Just (Rational i) | 0 <= i -> return i
 166                                    | otherwise -> P.fancyFailure $
 167                         Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Positive t
 168                  Nothing -> P.fancyFailure $
 169                         Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Rational t
 170         rationalPositive = RNC.rule "rationalPositive" $ RNC.text >>= \t ->
 171                 case readMaybe (TL.unpack t) of
 172                  Just (Rational i) | 0 <= i -> return i
 173                                    | otherwise -> P.fancyFailure $
 174                         Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Positive t
 175                  Nothing -> P.fancyFailure $
 176                         Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Rational t
 177         nat = RNC.rule "nat" $ RNC.int >>= \i ->
 178                 if i >= 0
 179                 then return $ Nat i
 180                 else P.fancyFailure $ Set.singleton $
 181                         P.ErrorCustom $ ErrorRead_Not_Nat i
 182         nat1 = RNC.rule "nat1" $ RNC.int >>= \i ->
 183                 if i > 0
 184                 then return $ Nat1 i
 185                 else P.fancyFailure $ Set.singleton $
 186                         P.ErrorCustom $ ErrorRead_Not_Nat1 i
 187         (<|>)    = (P.<|>)
 188         many     = P.many
 189         some     = P.some
 190         optional = P.optional
 191         option   = P.option
 192         choice   = P.choice
 193         try      = P.try
 194 type instance RNC.Perm Parser = P.PermParser XMLs Parser
 195 instance RNC.Sym_Interleaved Parser where
 196         interleaved = P.makePermParser
 197         (<$$>) = (P.<$$>)
 198         (<||>) = (P.<||>)
 199         (<$?>) = (P.<$?>)
 200         (<|?>) = (P.<|?>)
 201         f <$*> a = f P.<$?> ([],P.some a)
 202         f <|*> a = f P.<|?> ([],P.some a)
 203 instance DTC.Sym_DTC Parser where
 204         position = S.get
 205
 206 readDTC ::
 207  DTC.Sym_DTC Parser =>
 208  XMLs ->
 209  Either (P.ParseError (P.Token XMLs) ErrorRead) DTC.Document
 210 readDTC = (fst <$>) . runParser def (P.initialPos "") DTC.document
 211
 212 -- | @runParser st pos p xs@ runs a 'Parser' @p@ to parse @xs@ entirely,
 213 -- using state @st@ from position @pos@.
 214 runParser ::
 215  DTC.Sym_DTC Parser =>
 216  State ->
 217  P.SourcePos -> Parser a -> XMLs ->
 218  Either (P.ParseError (P.Token XMLs) ErrorRead) (a, State)
 219 runParser st pos p inp =
 220         let p' = S.runStateT (p <* RNC.none) st in
 221         snd $
 222         P.runParser' p'
 223          P.State
 224                  { P.stateInput = inp
 225                  , P.statePos = pure $
 226                         case Seq.viewl inp of
 227                          Tree (Cell (Span{span_begin=bp, span_file}:|_) _) _ :< _ ->
 228                                 P.SourcePos span_file
 229                                  (P.mkPos $ pos_line bp)
 230                                  (P.mkPos $ pos_column bp)
 231                          EmptyL -> pos
 232                  , P.stateTabWidth = P.pos1
 233                  , P.stateTokensProcessed = 0
 234                  }
 235
 236 -- | @parser p xs@ returns a 'Parser' parsing @xs@ with @p@,
 237 -- applying 'setPosOnNextNode' in case of success.
 238 parser ::
 239  DTC.Sym_DTC Parser =>
 240  Parser a -> XMLs -> Parser a
 241 parser p xs = do
 242         st  <- S.get
 243         pos <- P.getPosition
 244         case runParser st pos p xs of
 245          Left (P.TrivialError (posErr:|_) un ex) -> do
 246                 -- NOTE: just re-raising exception.
 247                 -- S.put st
 248                 P.setPosition posErr
 249                 P.failure un ex
 250          Left (P.FancyError (posErr:|_) errs) -> do
 251                 -- NOTE: just re-raising exception.
 252                 -- S.put st
 253                 P.setPosition posErr
 254                 P.fancyFailure errs
 255          Right (a, st') -> do
 256                 S.put st'
 257                 a <$ setPosOnNextNode
 258
 259 -- | Adjust the current 'P.SourcePos'
 260 -- to be the begining of the following-sibling 'XML' node
 261 -- so that on error 'P.toHints' keeps expected 'P.Token's in the list,
 262 -- and thus makes useful error messages.
 263 --
 264 -- This is needed because the end of a 'Cell'
 265 -- is not necessarily the begin of the next 'Cell'.
 266 setPosOnNextNode :: Parser ()
 267 setPosOnNextNode = do
 268         P.State
 269          { P.stateInput = inp
 270          , P.statePos   = pos :| _
 271          } <- P.getParserState
 272         case Seq.viewl inp of
 273          EmptyL -> return ()
 274          t :< _ -> P.setPosition $ P.positionAt1 (Proxy::Proxy XMLs) pos t
 275
 276 instance P.Stream XMLs where
 277         type Token  XMLs = XML
 278         type Tokens XMLs = XMLs
 279         take1_ s =
 280                 case Seq.viewl s of
 281                  Tree (unCell -> XmlComment{}) _ :< ts -> P.take1_ ts
 282                  t:<ts  -> Just (t,ts)
 283                  EmptyL -> Nothing
 284         positionAt1 _s pos (Tree (Cell (Span{span_begin=Pos l c}:|_) _n) _ts) =
 285                 P.SourcePos (P.sourceName pos) (P.mkPos l) (P.mkPos c)
 286         positionAtN s pos ts =
 287                 case Seq.viewl ts of
 288                  t :< _ -> P.positionAt1 s pos t
 289                  EmptyL -> pos
 290         advance1 _s _indent pos (Tree (Cell (Span{span_end=Pos l c}:|_) _n) _ts) =
 291                 -- WARNING: the end of a 'Cell' is not necessarily
 292                 -- the beginning of the next 'Cell'.
 293                 P.SourcePos (P.sourceName pos) (P.mkPos l) (P.mkPos c)
 294         advanceN s = foldl' . P.advance1 s
 295         takeN_ n s | n <= 0    = Just (mempty, s)
 296                    | null s    = Nothing
 297                    | otherwise = Just (Seq.splitAt n s) -- FIXME: handle XmlComment and XmlInclude
 298         tokensToChunk _s = Seq.fromList
 299         chunkToTokens _s = toList
 300         chunkLength _s   = Seq.length
 301         takeWhile_       = Seq.spanl
 302 instance P.ShowToken XML where
 303         showTokens toks = List.intercalate ", " $ toList $ showTree <$> toks
 304                 where
 305                 showTree :: XML -> String
 306                 showTree (Tree a _ts) =
 307                         showCell a $ \case
 308                          XmlElem n     -> "<"<>show n<>">"
 309                          XmlAttr n _v  -> show n<>"="
 310                          XmlText _t    -> "text"
 311                          XmlComment _c -> "comment"
 312
 313                 showCell (Cell path@(Span{span_file} :| _) a) f =
 314                         if null span_file
 315                         then f a
 316                         else f a <> foldMap (\p -> "\n in "<>show p) path
 317
 318 -- ** Type 'ErrorRead'
 319 data ErrorRead
 320  =   ErrorRead_EndOfInput
 321  |   ErrorRead_Not_Int TL.Text
 322  |   ErrorRead_Not_Nat Int
 323  |   ErrorRead_Not_Nat1 Int
 324  |   ErrorRead_Not_Rational TL.Text
 325  |   ErrorRead_Not_Positive TL.Text
 326  -- |   ErrorRead_Unexpected P.sourcePos XML
 327  deriving (Eq,Ord,Show)
 328 instance P.ShowErrorComponent ErrorRead where
 329         showErrorComponent = show
 330
 331 -- ** Type 'Rational'
 332 -- | Wrapper to change the 'Read' instance.
 333 newtype Rational = Rational Ratio.Rational
 334 instance Read Rational where
 335         readPrec = do
 336                 x <- Read.step readPrec
 337                 Read.expectP (Read.Symbol "/")
 338                 y <- Read.step readPrec
 339                 return $ Rational (x % y)