Language/DTC/Read/TCT.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 {-# LANGUAGE ViewPatterns #-}
   8 {-# OPTIONS_GHC -fno-warn-orphans #-}
   9 -- | Read DTC from TCT.
  10 module Language.DTC.Read.TCT where
  11
  12 import Control.Applicative (Applicative(..))
  13 import Control.Monad (Monad(..))
  14 import Data.Bool
  15 import Data.Default.Class (Default(..))
  16 import Data.Either (Either(..))
  17 import Data.Eq (Eq(..))
  18 import Data.Foldable (Foldable(..))
  19 import Data.Function (($), (.), const, id)
  20 import Data.Functor ((<$>), (<$))
  21 import Data.Int (Int)
  22 import Data.List.NonEmpty (NonEmpty(..))
  23 import Data.Maybe (Maybe(..), fromMaybe, maybe)
  24 import Data.Monoid (Monoid(..), First(..))
  25 import Data.Ord (Ord(..))
  26 import Data.Proxy (Proxy(..))
  27 import Data.Semigroup (Semigroup(..))
  28 import Data.Sequence (ViewL(..), (|>))
  29 import Data.String (String)
  30 import Data.Text (Text)
  31 import Data.Tuple (snd)
  32 import Prelude (Num(..))
  33 import Text.Read (readMaybe)
  34 import Text.Show (Show(..))
  35 import qualified Control.Monad.Trans.State as S
  36 import qualified Data.List as List
  37 import qualified Data.Map.Strict as Map
  38 import qualified Data.Sequence as Seq
  39 import qualified Data.Set as Set
  40 import qualified Data.Text as Text
  41 import qualified Text.Megaparsec as P
  42 import qualified Text.Megaparsec.Perm as P
  43
  44 import Language.TCT hiding (Parser)
  45 import Language.XML
  46 import qualified Language.DTC.Document as DTC
  47 import qualified Language.DTC.Sym as DTC
  48 import qualified Language.RNC.Sym as RNC
  49
  50 -- * Type 'State'
  51 type State = DTC.Pos
  52
  53 -- * Type 'Parser'
  54 -- type Parser = P.Parsec Error XMLs
  55 type Parser = S.StateT State (P.Parsec Error XMLs)
  56
  57 instance RNC.Sym_Rule Parser where
  58         -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
  59         rule _n = id
  60 instance RNC.Sym_RNC Parser where
  61         none = P.label "none" $ P.eof
  62         any  = P.label "any" $ p_satisfyMaybe $ const $ Just ()
  63         anyElem p = P.label "anyElem" $ do
  64                 (n,ts) <- P.token check $ Just expected
  65                 parserXMLs (p n) ts
  66                 where
  67                 expected = TreeN (cell0 "") mempty
  68                 check (TreeN (unCell -> n) ts) = Right (n,ts)
  69                 check t = Left
  70                  ( Just $ P.Tokens $ pure t
  71                  , Set.singleton $ P.Tokens $ pure expected )
  72         element n p = do
  73                 ts <- P.token check $ Just expected
  74                 xp <- S.get
  75                 let nameOrFigureName
  76                         | n == "figure"
  77                         -- NOTE: special case renaming the current DTC.Pos
  78                         -- using the @type attribute to have positions like this:
  79                         --   section1.Quote1
  80                         --   section1.Example1
  81                         --   section1.Quote2
  82                         -- instead of:
  83                         --   section1.figure1
  84                         --   section1.figure2
  85                         --   section1.figure3
  86                         , Just ty <- getFirst $ (`foldMap` ts) $ \case
  87                          Tree0 (unCell -> XmlAttr "type" ty) -> First $ Just ty
  88                          _ -> First Nothing
  89                         = xmlLocalName $ ty
  90                         | otherwise = n
  91                 let anc name = maybe 1 (+1) $ Map.lookup name $ DTC.posPrecedingsSiblings xp
  92                 S.put xp
  93                  { DTC.posAncestors = DTC.posAncestors xp |> (n,anc n)
  94                  , DTC.posAncestorsWithFigureNames =
  95                         DTC.posAncestorsWithFigureNames xp |>
  96                         (nameOrFigureName,anc nameOrFigureName)
  97                  , DTC.posPrecedingsSiblings = mempty
  98                  }
  99                 parserXMLs p ts <* S.put xp
 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 xp
 106                  }
 107                 where
 108                 expected = TreeN (cell0 n) mempty
 109                 check (TreeN (unCell -> e) ts) | e == n = Right ts
 110                 check t = Left
 111                  ( Just $ P.Tokens $ pure t
 112                  , Set.singleton $ P.Tokens $ pure expected )
 113         attribute n p = do
 114                 v <- P.token check $ Just expected
 115                 parserXMLs p v
 116                 where
 117                 expected = Tree0 (cell0 $ XmlAttr n "")
 118                 check (TreeN (unCell -> e) ts) | e == n = Right ts
 119                 check (Tree0 (Cell bp ep (XmlAttr k v))) | k == n =
 120                         Right $ Seq.singleton $ Tree0 $ Cell bp ep $ 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 (Text.unpack t) of
 146                  Just i -> return i
 147                  Nothing -> P.fancyFailure $
 148                         Set.singleton $ P.ErrorCustom $ Error_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 $ Error_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 $ Error_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) Error) 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) Error) 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                          Tree0 c   :< _ -> sourcePosCell c
 197                          TreeN c _ :< _ -> sourcePosCell c
 198                          _ -> pos
 199                  , P.stateTabWidth = P.pos1
 200                  , P.stateTokensProcessed = 0
 201                  }
 202
 203 -- | @parserXMLs st pos p xs@ returns a 'Parser' parsing @xs@ with @p@ from state @st@.
 204 parserXMLs ::
 205  DTC.Sym_DTC Parser =>
 206  Parser a -> XMLs -> Parser a
 207 parserXMLs p xs = do
 208         pos <- P.getPosition
 209         st <- S.get
 210         case parseXMLs st pos p xs of
 211          Left (P.TrivialError (posErr:|_) un ex) -> do
 212                 P.setPosition posErr
 213                 P.failure un ex
 214          Left (P.FancyError (posErr:|_) errs) -> do
 215                 P.setPosition posErr
 216                 P.fancyFailure errs
 217          Right a -> a <$ fixPos
 218
 219 -- | Adjust the current 'P.SourcePos'
 220 -- to be the begining of the following-sibling 'XML' node
 221 -- so that on error 'P.toHints' keeps expected 'P.Token's in the list,
 222 -- and thus makes useful error messages.
 223 --
 224 -- This is needed because the end of a 'Cell'
 225 -- is not necessarily the begin of the next 'Cell'.
 226 fixPos :: Parser ()
 227 fixPos = do
 228         P.State
 229          { P.stateInput = inp
 230          , P.statePos   = pos :| _
 231          } <- P.getParserState
 232         case Seq.viewl inp of
 233          EmptyL -> return ()
 234          t :< _ -> P.setPosition $
 235                 P.positionAt1 (Proxy::Proxy XMLs) pos t
 236
 237 sourcePosCell :: Cell a -> P.SourcePos
 238 sourcePosCell c =
 239         P.SourcePos ""
 240          (P.mkPos $ lineCell c)
 241          (P.mkPos $ columnCell c)
 242
 243 sourcePos :: Pos -> Maybe P.SourcePos
 244 sourcePos (Pos l c) | l>0 && c>0 = Just $ P.SourcePos "" (P.mkPos l) (P.mkPos c)
 245 sourcePos _ = Nothing
 246
 247 instance P.Stream XMLs where
 248         type Token  XMLs = XML
 249         type Tokens XMLs = XMLs
 250         take1_ s =
 251                 case Seq.viewl s of
 252                  Tree0 (unCell -> XmlComment{}) :< ts -> P.take1_ ts
 253                  t:<ts  -> Just (t,ts)
 254                  EmptyL -> Nothing
 255         positionAt1 _s pos t =
 256                 fromMaybe pos $ sourcePos $
 257                 case t of
 258                  TreeN c _ -> posCell c
 259                  Tree0 c   -> posCell c
 260         positionAtN s pos ts =
 261                 case Seq.viewl ts of
 262                  t :< _ -> P.positionAt1 s pos t
 263                  _ -> pos
 264         advance1 _s _indent pos t =
 265                 -- WARNING: the end of a 'Cell' is not necessarily
 266                 -- the beginning of the next 'Cell'.
 267                 fromMaybe pos $ sourcePos $
 268                 case t of
 269                  TreeN c _ -> posEndCell c
 270                  Tree0 c   -> posEndCell c
 271         advanceN s = foldl' . P.advance1 s
 272         takeN_ n s
 273          | n <= 0    = Just (mempty, s)
 274          | null s    = Nothing
 275          | otherwise = Just (Seq.splitAt n s) -- FIXME: handle XmlComment
 276         tokensToChunk _s = Seq.fromList
 277         chunkToTokens _s = toList
 278         chunkLength _s   = Seq.length
 279         takeWhile_       = Seq.spanl
 280 instance P.ShowToken XML where
 281         showTokens toks = List.intercalate ", " $ toList $ showTree <$> toks
 282                 where
 283                 showTree :: XML -> String
 284                 showTree = \case
 285                  Tree0 c     -> showCell c showXmlLeaf
 286                  TreeN c _ts -> showCell c showXmlName
 287
 288                 showCell (Cell (Pos 0 0) (Pos 0 0) a) f = f a
 289                 showCell (Cell bp ep a) f = f a<>" at "<>show bp<>"-"<>show ep
 290
 291                 showXmlLeaf = \case
 292                  XmlAttr n _v  -> show n<>"="
 293                  XmlText _t    -> "text"
 294                  XmlComment _c -> "comment"
 295                 showXmlName n = "<"<>show n<>">"
 296
 297 -- ** Type 'Error'
 298 data Error
 299  =   Error_EndOfInput
 300  |   Error_Not_Int Text
 301  |   Error_Not_Nat Int
 302  |   Error_Not_Nat1 Int
 303  -- |   Error_Unexpected P.sourcePos XML
 304  deriving (Eq,Ord,Show)
 305 instance P.ShowErrorComponent Error where
 306         showErrorComponent = show