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