Language/DTC/Read/TCT.hs

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