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