module Text.Xml.Tiny.Internal
(
Node(..), Attribute(..)
, ParseDetails(..), AttributeParseDetails(..)
, Slice(..)
, fromOpen, fromOpenClose, fromIndexPtr
, empty
, start, end
, take, drop, null
, vector, render, toList
, SrcLoc(..), Error(..), ErrorType(..)
) where
import Control.Exception
import Data.ByteString.Char8 (ByteString)
import Data.ByteString.Internal (ByteString(..))
import Data.List (genericTake)
import Data.Vector.Storable (Vector, (!))
import qualified Data.Vector.Storable as V
import Data.Word
import GHC.Stack hiding (SrcLoc)
import Foreign.ForeignPtr (ForeignPtr)
import Foreign
import Prelude hiding (length, null, take, drop)
import Text.Printf
import Config
data Slice =
Slice { offset, length :: !Int32 }
deriving (Eq,Ord,Show)
sInt :: Int
sInt = sizeOf(0::Int32)
instance Storable Slice where
sizeOf _ = sInt * 2
alignment _ = alignment (0 :: Int64)
peek p = Slice <$> peekByteOff p 0 <*> peekByteOff p sInt
poke p Slice{..} = pokeByteOff p 0 offset >> pokeByteOff p sInt length
empty :: Slice
empty = Slice 0 0
fromOpen:: Config => Integral a => a -> Slice
fromOpen o = Slice (fromIntegral o) 0
fromOpenClose :: Config => (Integral a1, Integral a) => a -> a1 -> Slice
fromOpenClose (fromIntegral->open) (fromIntegral->close) = Slice open (closeopen)
null :: Config => Slice -> Bool
null (Slice _ l) = l == 0
take :: Config => Integral a => a -> Slice -> Slice
take !(fromIntegral -> i) (Slice o l) = assert (l>=i) $ Slice o i
drop :: Config => Integral t => t -> Slice -> Slice
drop !(fromIntegral -> i) (Slice o l) = assert (l>=i || error(printf "drop %d (Slice %d %d)" i o l)) $ Slice (o+i) (li)
start :: Config => Slice -> Int32
start = offset
end :: Config => Slice -> Int32
end (Slice o l) = o + l
toList :: Config => Slice -> [Int]
toList (Slice o l) = genericTake l [ fromIntegral o ..]
fromIndexPtr :: Config => Slice -> ForeignPtr Word8 -> ByteString
fromIndexPtr (Slice o l) fptr = PS fptr (fromIntegral o) (fromIntegral l)
render :: Config => Slice -> ByteString -> ByteString
render(Slice o l) _ | trace (printf "Render slice %d %d" o l) False = undefined
render(Slice o l) _ | assert (o >= 0 && l >= 0) False = undefined
render(Slice o l) (PS fptr _ _) = PS fptr (fromIntegral o) (fromIntegral l)
vector :: Config => Storable a => Slice -> Vector a -> [a]
vector s v = [ v ! i
| i <- toList s
, assert (i < V.length v) True ]
data Node =
Node{ attributesV :: !(Vector AttributeParseDetails)
, nodesV :: !(Vector ParseDetails)
, source :: !ByteString
, slices :: !ParseDetails
}
data Attribute = Attribute { attributeName, attributeValue :: !ByteString } deriving (Eq, Show)
data ParseDetails =
ParseDetails
{ name :: !Slice
, inner :: !Slice
, outer :: !Slice
, attributes :: !Slice
, nodeContents :: !Slice
}
| ProtoParseDetails { name, attributes :: !Slice, innerStart, outerStart :: !Int32 }
deriving (Show)
instance Storable ParseDetails where
sizeOf _ = sizeOf empty * 5
alignment _ = alignment(0::Int)
poke !q (ParseDetails a b c d e) = let p = castPtr q in pokeElemOff p 0 a >> pokeElemOff p 1 b >> pokeElemOff p 2 c >> pokeElemOff p 3 d >> pokeElemOff p 4 e
poke !q (ProtoParseDetails (Slice no nl) (Slice ao al) i o) = do
let !p = castPtr q
pokeElemOff p 0 no
pokeElemOff p 1 (0::Int32)
pokeElemOff p 2 nl
pokeElemOff p 3 ao
pokeElemOff p 4 al
pokeElemOff p 5 i
pokeElemOff p 6 o
peek q = do
let !p = castPtr q
!header <- peekElemOff p 1
if header == (0::Int32)
then protoNode <$> peekElemOff p 0 <*> peekElemOff p 2 <*> peekElemOff p 3 <*> peekElemOff p 4 <*> peekElemOff p 5 <*> peekElemOff p 6
else let !p = castPtr q in ParseDetails <$> peekElemOff p 0 <*> peekElemOff p 1 <*> peekElemOff p 2 <*> peekElemOff p 3 <*> peekElemOff p 4
where
protoNode no nl ao al = ProtoParseDetails (Slice no nl) (Slice ao al)
data AttributeParseDetails =
AttributeParseDetails
{ nameA :: !Slice,
value :: !Slice
}
deriving (Eq, Show)
instance Storable AttributeParseDetails where
sizeOf _ = sizeOf empty * 2
alignment _ = alignment (0 :: Int)
peek !q = do
let !p = castPtr q :: Ptr Slice
!a <- peekElemOff p 0
!b <- peekElemOff p 1
return (AttributeParseDetails a b)
poke !q (AttributeParseDetails a b)= do
let !p = castPtr q :: Ptr Slice
pokeElemOff p 0 a
pokeElemOff p 1 b
newtype SrcLoc = SrcLoc Int deriving Show
data Error = Error ErrorType CallStack
data ErrorType =
UnterminatedComment SrcLoc
| UnterminatedTag String SrcLoc
| ClosingTagMismatch String SrcLoc
| JunkAtTheEnd Slice SrcLoc
| UnexpectedEndOfStream
| BadAttributeForm SrcLoc
| BadTagForm SrcLoc
| UnfinishedComment SrcLoc
| Garbage SrcLoc
| InvalidNullName SrcLoc
deriving Show
#if __GLASGOW_HASKELL__ < 800
prettyCallStack = show
#endif
instance Exception Error
instance Show Error where
show (Error etype cs) = show etype ++ prettyCallStack cs