XML: generalize Sourced type parameter where possible

diff --git a/Language/Symantic/RNC/Sym.hs b/Language/Symantic/RNC/Sym.hs
index 0449686c39e7d126466e8fb5667ed4d4fb2a93f9..6b672cdf72a4050e9107f075700e7ce670a9fa20 100644 (file)
--- a/Language/Symantic/RNC/Sym.hs
+++ b/Language/Symantic/RNC/Sym.hs
@@ -7,7 +7,6 @@ module Language.Symantic.RNC.Sym
  ) where
 
 import Control.Applicative (Applicative(..), Alternative(..))
-import Control.Monad (Monad(..))
 import Data.Eq (Eq)
 import Data.Function ((.), id)
 import Data.Functor (Functor(..), (<$>))

diff --git a/Language/Symantic/RNC/Validate.hs b/Language/Symantic/RNC/Validate.hs
index 6d4009ef42926649c4088fd3523787eef1b267f5..502fb5af3c6bd2b16adf428dd820ee3966472789 100644 (file)
--- a/Language/Symantic/RNC/Validate.hs
+++ b/Language/Symantic/RNC/Validate.hs
@@ -32,8 +32,8 @@ import qualified Language.Symantic.XML as XML
 import qualified Language.Symantic.RNC.Sym as RNC
 
 validateXML ::
- Ord e => P.Parsec e XMLs a -> XMLs ->
- Either (P.ParseErrorBundle XMLs e) a
+ Ord e => P.Parsec e (XMLs src) a -> XMLs src ->
+ Either (P.ParseErrorBundle (XMLs src) e) a
 validateXML p stateInput =
        snd $
        P.runParser' p P.State
@@ -49,7 +49,7 @@ validateXML p stateInput =
 p_satisfyMaybe :: P.MonadParsec e s m => (P.Token s -> Maybe a) -> m a
 p_satisfyMaybe = (`P.token` Set.empty)
 
-instance Ord e => RNC.Sym_RNC (P.Parsec e XMLs) where
+instance (Ord err, Ord src, XML.NoSource src) => RNC.Sym_RNC (P.Parsec err (XMLs src)) where
        {-
        none = P.label "none" $ P.eof
        -}
@@ -134,7 +134,7 @@ instance Ord e => RNC.Sym_RNC (P.Parsec e XMLs) where
        try      = P.try
        fail     = P.label "fail" $ P.failure Nothing mempty
 
-instance Ord e => RNC.Sym_Permutation (P.ParsecT e XMLs m) where
+instance (Ord err, Ord src) => RNC.Sym_Permutation (P.ParsecT err (XMLs src) m) where
        runPermutation (P value parser) = optional parser >>= f
                where
                -- NOTE: copy Control.Applicative.Permutations.runPermutation
@@ -149,7 +149,7 @@ instance Ord e => RNC.Sym_Permutation (P.ParsecT e XMLs m) where
 -- so that the 'P.TrivialError' has an unexpected token
 -- which is an 'XML.Node' containing a 'XML.FileSource' useful when reporting errors.
 data Permutation m a = P (Maybe a) (m (Permutation m a))
-type instance RNC.Permutation (P.ParsecT e XMLs m) = Permutation (P.ParsecT e XMLs m)
+type instance RNC.Permutation (P.ParsecT err (XMLs src) m) = Permutation (P.ParsecT err (XMLs src) m)
 instance Functor m => Functor (Permutation m) where
        fmap f (P v p) = P (f <$> v) (fmap f <$> p)
 instance Alternative m => Applicative (Permutation m) where
@@ -159,7 +159,7 @@ instance Alternative m => Applicative (Permutation m) where
                lhsAlt = (<*> rhs) <$> v
                rhsAlt = (lhs <*>) <$> w
 
-instance Ord e => RNC.Sym_Rule (P.ParsecT e XMLs m) where
+instance (Ord err, Ord src) => RNC.Sym_Rule (P.ParsecT err (XMLs src) m) where
        -- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
        rule _n = id
        arg _n = pure ()

diff --git a/Language/Symantic/XML.hs b/Language/Symantic/XML.hs
index b52d85da0e302804f5482ed0067a57dba436b7bf..7c50200cb3ba876354a5771a0ec8e52fcb71c86f 100644 (file)
--- a/Language/Symantic/XML.hs
+++ b/Language/Symantic/XML.hs
@@ -1,11 +1,6 @@
 module Language.Symantic.XML
  ( module Language.Symantic.XML.Document
  , module Language.Symantic.XML.Parser
- , Offset
- , LineColumn(..)
- , FileRange(..)
- , NoSource(..)
- , Sourced(..)
  , readXML
  , readFile
  , writeXML

diff --git a/Language/Symantic/XML/Document.hs b/Language/Symantic/XML/Document.hs
index e124a4b5b7061a3e03df58bb147f2cf05b4012a5..f12e1923397d702c2ea70f0acfdb8113b8da0542 100644 (file)
--- a/Language/Symantic/XML/Document.hs
+++ b/Language/Symantic/XML/Document.hs
@@ -14,7 +14,7 @@ module Language.Symantic.XML.Document
  , TS.tree0
  ) where
 
-import Control.Applicative (Applicative(..), Alternative(..))
+import Control.Applicative (Alternative(..))
 import Data.Bool
 import Data.Char (Char)
 import Data.Default.Class (Default(..))
@@ -32,7 +32,7 @@ import Data.Semigroup (Semigroup(..))
 import Data.Sequence (Seq)
 import Data.String (String, IsString(..))
 import GHC.Generics (Generic)
-import Prelude ((+), (-), error, fromIntegral)
+import Prelude ((+), error)
 import System.IO (FilePath)
 import Text.Show (Show(..), showsPrec, showChar, showParen, showString)
 import qualified Data.Char.Properties.XMLCharProps as XC
@@ -40,16 +40,15 @@ import qualified Data.HashMap.Strict as HM
 import qualified Data.HashSet as HS
 import qualified Data.List as List
 import qualified Data.Sequence as Seq
-import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.TreeSeq.Strict as TS
 
 -- * Type 'XML'
-type XML  = TS.Tree (Sourced (FileSource Offset) Node)
-type XMLs = Seq XML
+type XML src = TS.Tree (Sourced src Node)
+type XMLs src = Seq (XML src)
 
 -- | Unify two 'XMLs', merging border 'NodeText's if any.
-union :: XMLs -> XMLs -> XMLs
+union :: Semigroup (Sourced src EscapedText) => XMLs src -> XMLs src -> XMLs src
 union x y =
        case (Seq.viewr x, Seq.viewl y) of
         (xs Seq.:> x0, y0 Seq.:< ys) ->
@@ -63,7 +62,9 @@ union x y =
         (Seq.EmptyR, _) -> y
         (_, Seq.EmptyL) -> x
 
-unions :: Foldable f => f XMLs -> XMLs
+unions ::
+ Semigroup (Sourced src EscapedText) =>
+ Foldable f => f (XMLs src) -> XMLs src
 unions = foldl' union mempty
 
 pattern Tree0 :: a -> TS.Tree a

diff --git a/Language/Symantic/XML/Parser.hs b/Language/Symantic/XML/Parser.hs
index 1390cfdc3ba0c3c23b7c3cd368d62451fadd161a..3a3c0b4e572a2edacf64490850dc43ed1d3da152 100644 (file)
--- a/Language/Symantic/XML/Parser.hs
+++ b/Language/Symantic/XML/Parser.hs
@@ -17,7 +17,6 @@ import Data.Monoid (Monoid(..))
 import Data.Ord (Ord(..))
 import Data.Semigroup (Semigroup(..))
 import Data.Sequence (ViewL(..))
-import Data.String (String)
 import Prelude (error)
 import Text.Show (Show(..))
 import qualified Data.List as List
@@ -36,9 +35,9 @@ isIgnoredNode = \case
  XML.NodeCDATA{}   -> True
  _ -> False
 
-instance P.Stream XMLs where
-       type Token  XMLs = XML
-       type Tokens XMLs = XMLs
+instance Ord src => P.Stream (XMLs src) where
+       type Token  (XMLs src) = XML src
+       type Tokens (XMLs src) = XMLs src
        take1_ s =
                case Seq.viewl s of
                 EmptyL -> Nothing
@@ -63,24 +62,20 @@ instance P.Stream XMLs where
        reachOffsetNoLine = error "[BUG] P.Stream XMLs: reachOffsetNoLine is not helpful, please use annotated source locations"
        showTokens _s toks = List.intercalate ", " $ toList $ showTree <$> toks
                where
-               showTree :: XML -> String
-               showTree (XML.Tree a _ts) =
-                       showCell a $ \case
+               showTree (XML.Tree (XML.Sourced _src a) _ts) =
+                       case a of
                         XML.NodeElem n     -> "element "<>show n<>""
                         XML.NodeAttr n     -> "attribute "<>show n<>""
                         XML.NodeText _t    -> "text"
                         XML.NodeComment _c -> "comment"
                         XML.NodePI n _t    -> "processing-instruction "<>show n<>""
                         XML.NodeCDATA _t   -> "cdata"
-               
-               showCell (XML.Sourced path@(XML.FileRange{XML.fileRange_file} NonEmpty.:| _) a) f =
-                       if null fileRange_file
-                       then f a
-                       else f a <> foldMap (\p -> "\n in "<>show p) path
 
 -- | @subParser p xs@ returns a parser parsing @xs@ entirely with @p@,
 -- updating 'P.stateOffset' and re-raising any exception.
-subParser :: Ord err => P.Parsec err XMLs a -> XMLs -> P.Parsec err XMLs a
+subParser ::
+ Ord err => Ord src =>
+ P.Parsec err (XMLs src) a -> XMLs src -> P.Parsec err (XMLs src) a
 subParser p xs = do
        st <- P.getParserState
        let (st', res) = P.runParser' (p <* P.eof) st

diff --git a/Language/Symantic/XML/Read.hs b/Language/Symantic/XML/Read.hs
index 60b24f6601bc2d96bcdf2642c35c88b1fc732050..ae57551c8760f67e8f56f83f8d96ed611062b2ba 100644 (file)
--- a/Language/Symantic/XML/Read.hs
+++ b/Language/Symantic/XML/Read.hs
@@ -48,7 +48,7 @@ import qualified System.IO.Error as IO
 import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as P
 
-import Language.Symantic.XML.Document
+import Language.Symantic.XML.Document hiding (XML, XMLs)
 import Language.Symantic.XML.Read.Parser
 
 readXML :: FilePath -> TL.Text -> Either (P.ParseErrorBundle TL.Text Error) XMLs

diff --git a/Language/Symantic/XML/Read/Parser.hs b/Language/Symantic/XML/Read/Parser.hs
index ed4dbbbe911a1f2771383ba87d7075bc10afa2ff..0971b5be1279bfd9ee3cfe80c62f35c207845e58 100644 (file)
--- a/Language/Symantic/XML/Read/Parser.hs
+++ b/Language/Symantic/XML/Read/Parser.hs
@@ -27,7 +27,13 @@ import qualified Data.Text.Lazy as TL
 import qualified Text.Megaparsec as P
 import qualified Text.Megaparsec.Char as P
 
-import Language.Symantic.XML.Document
+import Language.Symantic.XML.Document hiding (XML, XMLs)
+import qualified Language.Symantic.XML.Document as XML
+
+-- | Specify |XML.XML|'s 'src' type parameter for parsing.
+type XML  = XML.XML  (FileSource Offset)
+-- | Specify |XML.XMLs|'s 'src' type parameter for parsing.
+type XMLs = XML.XMLs (FileSource Offset)
 
 -- * Type 'Parser'
 -- | Convenient alias.

diff --git a/Language/Symantic/XML/Write.hs b/Language/Symantic/XML/Write.hs
index dc1e23ef36565dff6cf333e7753e164c28e7296f..d708d8eb3985ccdd4c356e44ec505b7513d0a4f9 100644 (file)
--- a/Language/Symantic/XML/Write.hs
+++ b/Language/Symantic/XML/Write.hs
@@ -30,10 +30,10 @@ import qualified Data.Text.Lazy.Encoding as TL
 
 import Language.Symantic.XML.Document as XML
 
-writeXML :: XMLs -> TL.Text
+writeXML :: NoSource src => XMLs src -> TL.Text
 writeXML xs = TLB.toLazyText $ write xs `R.runReader` def
 
-writeXMLIndented :: TL.Text -> XMLs -> TL.Text
+writeXMLIndented :: NoSource src => TL.Text -> XMLs src -> TL.Text
 writeXMLIndented ind xs =
        TLB.toLazyText $
        write xs `R.runReader` def
@@ -104,7 +104,7 @@ class Writeable a where
        write :: a -> Write
 instance Writeable NCName where
        write = return . TLB.fromLazyText . unNCName
-instance Writeable XMLs where
+instance NoSource src => Writeable (XMLs src) where
        write xs = do
                ro <- R.ask
                if TL.null (reader_indent_delta ro)
@@ -119,7 +119,7 @@ instance Writeable XMLs where
                                         EscapedPlain t -> TL.all Char.isSpace t
                                         _ -> False) et
                                 _ -> True
-instance Writeable XML where
+instance NoSource src => Writeable (XML src) where
        write (Tree (Sourced _src nod) xs) = do
                ro <- R.ask
                case nod of
@@ -260,7 +260,7 @@ buildAttrValue (EscapedText et) = (`foldMap` et) $ \case
        | c == '\"' -> "&quot;"
        | otherwise -> build c
 
-removeSpaces :: XMLs -> XMLs
+removeSpaces :: XMLs src -> XMLs src
 removeSpaces xs =
        if (`all` xs) $ \case
         Tree (Sourced _ (NodeText (EscapedText et))) _ts ->