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