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.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(..), fromMaybe, 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.Text (Text)
  30 import Data.Tuple (snd)
  31 import Prelude (Num(..))
  32 import Text.Read (readMaybe)
  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.Sequence as Seq
  38 import qualified Data.Set as Set
  39 import qualified Data.Text as Text
  40 import qualified Text.Megaparsec as P
  41 import qualified Text.Megaparsec.Perm as P
  42
  43 import Language.TCT hiding (Parser)
  44 import Language.XML
  45 import qualified Language.DTC.Document as DTC
  46 import qualified Language.DTC.Sym as DTC
  47 import qualified Language.RNC.Sym as RNC
  48
  49 -- * Type 'State'
  50 type State = XmlPos
  51
  52 -- * Type 'Parser'
  53 -- type Parser = P.Parsec Error XMLs
  54 type Parser = S.StateT State (P.Parsec Error XMLs)
  55
  56 instance RNC.Sym_Rule Parser where
  57         -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
  58         rule _n = id
  59 instance RNC.Sym_RNC Parser where
  60         none = P.label "none" $ P.eof
  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 = TreeN (cell0 "") mempty
  67                 check (TreeN (unCell -> n) ts) = Right (n,ts)
  68                 check t = Left
  69                  ( Just $ P.Tokens $ pure t
  70                  , Set.singleton $ P.Tokens $ pure expected )
  71         position = S.get
  72         element n p = do
  73                 ts <- P.token check $ Just expected
  74                 xp <- S.get
  75                 let name
  76                         | n == "figure"
  77                         -- NOTE: special case renaming the current XmlPos
  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 a = maybe 1 (+1) $ Map.lookup name $ xmlPosPrecedingsSiblings xp
  92                 S.put xp
  93                  { xmlPosAncestors          = (name,a):xmlPosAncestors xp
  94                  , xmlPosPrecedingsSiblings = mempty
  95                  }
  96                 parserXMLs p ts <* S.put xp
  97                  { xmlPosPrecedingsSiblings=
  98                         Map.insertWith (\_new old -> old + 1) name 1 $
  99                                 xmlPosPrecedingsSiblings xp
 100                  }
 101                 where
 102                 expected = TreeN (cell0 n) mempty
 103                 check (TreeN (unCell -> e) ts) | e == n = Right ts
 104                 check t = Left
 105                  ( Just $ P.Tokens $ pure t
 106                  , Set.singleton $ P.Tokens $ pure expected )
 107         attribute n p = do
 108                 v <- P.token check $ Just expected
 109                 parserXMLs p v
 110                 where
 111                 expected = Tree0 (cell0 $ XmlAttr n "")
 112                 check (TreeN (unCell -> e) ts) | e == n = Right ts
 113                 check (Tree0 (Cell bp ep (XmlAttr k v))) | k == n =
 114                         Right $ Seq.singleton $ Tree0 $ Cell bp ep $ XmlText v
 115                 check t = Left
 116                  ( Just $ P.Tokens $ pure t
 117                  , Set.singleton $ P.Tokens $ pure expected )
 118         comment = do
 119                 s <- P.getInput
 120                 case Seq.viewl s of
 121                  Tree0 (unCell -> XmlComment c) :< ts -> do
 122                         P.setInput ts
 123                         c <$ fixPos
 124                  t :< _ts -> P.failure (Just $ P.Tokens $ pure t) ex
 125                  EmptyL -> P.failure Nothing ex
 126                 where
 127                 ex = Set.singleton $ P.Tokens $ pure expected
 128                 expected = Tree0 (cell0 $ XmlComment "")
 129         text = do
 130                 P.token check (Just expected)
 131                  <* fixPos
 132                 where
 133                 expected = Tree0 (cell0 $ XmlText "")
 134                 check (Tree0 (unCell -> XmlText t)) = Right t
 135                 check t = Left
 136                  ( Just $ P.Tokens $ pure t
 137                  , Set.singleton $ P.Tokens $ pure expected )
 138         int = RNC.rule "int" $ RNC.text >>= \t ->
 139                 case readMaybe (Text.unpack t) of
 140                  Just i -> return i
 141                  Nothing -> P.fancyFailure $
 142                         Set.singleton $ P.ErrorCustom $ Error_Not_Int t
 143         nat = RNC.rule "nat" $ RNC.int >>= \i ->
 144                 if i >= 0
 145                 then return $ Nat i
 146                 else P.fancyFailure $ Set.singleton $
 147                         P.ErrorCustom $ Error_Not_Nat i
 148         nat1 = RNC.rule "nat1" $ RNC.int >>= \i ->
 149                 if i > 0
 150                 then return $ Nat1 i
 151                 else P.fancyFailure $ Set.singleton $
 152                         P.ErrorCustom $ Error_Not_Nat1 i
 153         (<|>)    = (P.<|>)
 154         many     = P.many
 155         some     = P.some
 156         optional = P.optional
 157         option   = P.option
 158         choice   = P.choice
 159         try      = P.try
 160 type instance RNC.Perm Parser = P.PermParser XMLs Parser
 161 instance RNC.Sym_Interleaved Parser where
 162         interleaved = P.makePermParser
 163         (<$$>) = (P.<$$>)
 164         (<||>) = (P.<||>)
 165         (<$?>) = (P.<$?>)
 166         (<|?>) = (P.<|?>)
 167         f <$*> a = f P.<$?> ([],P.some a)
 168         f <|*> a = f P.<|?> ([],P.some a)
 169 instance DTC.Sym_DTC Parser
 170
 171 readDTC ::
 172  DTC.Sym_DTC Parser =>
 173  XMLs ->
 174  Either (P.ParseError (P.Token XMLs) Error) DTC.Document
 175 readDTC =
 176         parseXMLs
 177          XmlPos { xmlPosAncestors = []
 178                 , xmlPosPrecedingsSiblings = mempty
 179                 }
 180          (P.initialPos "")
 181          DTC.document
 182
 183 parseXMLs ::
 184  DTC.Sym_DTC Parser =>
 185  State ->
 186  P.SourcePos -> Parser a -> XMLs ->
 187  Either (P.ParseError (P.Token XMLs) Error) a
 188 parseXMLs st pos p i =
 189         snd $
 190         P.runParser' ((`S.evalStateT` st) $ p <* RNC.none)
 191          P.State
 192                  { P.stateInput = i
 193                  , P.statePos = pure $
 194                         case Seq.viewl i of
 195                          Tree0 c   :< _ -> sourcePosCell c
 196                          TreeN c _ :< _ -> sourcePosCell c
 197                          _ -> pos
 198                  , P.stateTabWidth = P.pos1
 199                  , P.stateTokensProcessed = 0
 200                  }
 201
 202 -- | @parserXMLs st pos p xs@ returns a 'Parser' parsing @xs@ with @p@ from state @st@.
 203 parserXMLs ::
 204  DTC.Sym_DTC Parser =>
 205  Parser a -> XMLs -> Parser a
 206 parserXMLs p xs = do
 207         pos <- P.getPosition
 208         st <- S.get
 209         case parseXMLs st pos p xs of
 210          Left (P.TrivialError (posErr:|_) un ex) -> do
 211                 P.setPosition posErr
 212                 P.failure un ex
 213          Left (P.FancyError (posErr:|_) errs) -> do
 214                 P.setPosition posErr
 215                 P.fancyFailure errs
 216          Right a -> a <$ fixPos
 217
 218 -- | Adjust the current 'P.SourcePos'
 219 -- to be the begining of the following-sibling 'XML' node
 220 -- so that on error 'P.toHints' keeps expected 'P.Token's in the list,
 221 -- and thus makes useful error messages.
 222 --
 223 -- This is needed because the end of a 'Cell'
 224 -- is not necessarily the begin of the next 'Cell'.
 225 fixPos :: Parser ()
 226 fixPos = do
 227         P.State
 228          { P.stateInput = inp
 229          , P.statePos   = pos :| _
 230          } <- P.getParserState
 231         case Seq.viewl inp of
 232          EmptyL -> return ()
 233          t :< _ -> P.setPosition $
 234                 P.positionAt1 (Proxy::Proxy XMLs) pos t
 235
 236 sourcePosCell :: Cell a -> P.SourcePos
 237 sourcePosCell c =
 238         P.SourcePos ""
 239          (P.mkPos $ lineCell c)
 240          (P.mkPos $ columnCell c)
 241
 242 sourcePos :: Pos -> Maybe P.SourcePos
 243 sourcePos (Pos l c) | l>0 && c>0 = Just $ P.SourcePos "" (P.mkPos l) (P.mkPos c)
 244 sourcePos _ = Nothing
 245
 246 instance P.Stream XMLs where
 247         type Token  XMLs = XML
 248         type Tokens XMLs = XMLs
 249         take1_ s =
 250                 case Seq.viewl s of
 251                  Tree0 (unCell -> XmlComment{}) :< ts -> P.take1_ ts
 252                  t:<ts  -> Just (t,ts)
 253                  EmptyL -> Nothing
 254         positionAt1 _s pos t =
 255                 fromMaybe pos $ sourcePos $
 256                 case t of
 257                  TreeN c _ -> posCell c
 258                  Tree0 c   -> posCell c
 259         positionAtN s pos ts =
 260                 case Seq.viewl ts of
 261                  t :< _ -> P.positionAt1 s pos t
 262                  _ -> pos
 263         advance1 _s _indent pos t =
 264                 -- WARNING: the end of a 'Cell' is not necessarily
 265                 -- the beginning of the next 'Cell'.
 266                 fromMaybe pos $ sourcePos $
 267                 case t of
 268                  TreeN c _ -> posEndCell c
 269                  Tree0 c   -> posEndCell c
 270         advanceN s = foldl' . P.advance1 s
 271         takeN_ n s
 272          | n <= 0    = Just (mempty, s)
 273          | null s    = Nothing
 274          | otherwise = Just (Seq.splitAt n s) -- FIXME: handle XmlComment
 275         tokensToChunk _s = Seq.fromList
 276         chunkToTokens _s = toList
 277         chunkLength _s   = Seq.length
 278         takeWhile_       = Seq.spanl
 279 instance P.ShowToken XML where
 280         showTokens toks = List.intercalate ", " $ toList $ showTree <$> toks
 281                 where
 282                 showTree :: XML -> String
 283                 showTree = \case
 284                  Tree0 c     -> showCell c showXmlLeaf
 285                  TreeN c _ts -> showCell c showXmlName
 286
 287                 showCell (Cell (Pos 0 0) (Pos 0 0) a) f = f a
 288                 showCell (Cell bp ep a) f = f a<>" at "<>show bp<>"-"<>show ep
 289
 290                 showXmlLeaf = \case
 291                  XmlAttr n _v  -> show n<>"="
 292                  XmlText _t    -> "text"
 293                  XmlComment _c -> "comment"
 294                 showXmlName n = "<"<>show n<>">"
 295
 296 -- ** Type 'Error'
 297 data Error
 298  =   Error_EndOfInput
 299  |   Error_Not_Int Text
 300  |   Error_Not_Nat Int
 301  |   Error_Not_Nat1 Int
 302  -- |   Error_Unexpected P.sourcePos XML
 303  deriving (Eq,Ord,Show)
 304 instance P.ShowErrorComponent Error where
 305         showErrorComponent = show