{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoBangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  PDFTree.hs
-- Copyright   :  (c) Daan Leijen 2002
-- License     :  BSD-style
-- Maintainer  :  misc@NOSPAMalpheccar.org
-- Stability   :  provisional
-- Portability :  portable
--
-- An efficient implementation of maps from integer keys to values.
--
-- Customized by alpheccar for the need of the PDF library. The original is IntMap from
-- the ghc standard libraries
-----------------------------------------------------------------------------
-- #hide
module Graphics.PDF.Data.PDFTree(
   PDFTree
 , Key
 , empty
 , lookup
 , insert
 , fromList
 , fold2
 , isLeaf
 , size
 , keyOf
 ) where
 
import Prelude hiding (lookup,map,filter,foldr,foldl,null)
import Data.Bits
#if __GLASGOW_HASKELL__ >= 503
import GHC.Exts ( Word(..), Int(..), shiftRL# )
#elif __GLASGOW_HASKELL__
import Word
import GlaExts ( Word(..), Int(..), shiftRL# )
#else
import Data.Word
#endif

import Graphics.PDF.LowLevel.Types

type Nat = Word

natFromInt :: Key a -> Nat
natFromInt :: forall a. Key a -> Nat
natFromInt (PDFReference Int
i) = Int -> Nat
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i

intFromNat :: Nat -> Key a
intFromNat :: forall a. Nat -> Key a
intFromNat Nat
w = Int -> PDFReference a
forall s. Int -> PDFReference s
PDFReference (Nat -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Nat
w)

type Prefix a = PDFReference a
type Mask   a = PDFReference a
type Key a   = PDFReference a

-- | A map of integers to values @a@.
-- The total size of subtrees is tracked by each node. It is needed for the PDF Tree
data PDFTree a = Nil
               | Tip {-# UNPACK #-} !(Key a) a
               | Bin {-# UNPACK #-} !(Prefix a) {-# UNPACK #-} !(Mask a) !(PDFTree a) !(PDFTree a) 
               deriving(PDFTree a -> PDFTree a -> Bool
(PDFTree a -> PDFTree a -> Bool)
-> (PDFTree a -> PDFTree a -> Bool) -> Eq (PDFTree a)
forall a. Eq a => PDFTree a -> PDFTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => PDFTree a -> PDFTree a -> Bool
== :: PDFTree a -> PDFTree a -> Bool
$c/= :: forall a. Eq a => PDFTree a -> PDFTree a -> Bool
/= :: PDFTree a -> PDFTree a -> Bool
Eq,Int -> PDFTree a -> ShowS
[PDFTree a] -> ShowS
PDFTree a -> String
(Int -> PDFTree a -> ShowS)
-> (PDFTree a -> String)
-> ([PDFTree a] -> ShowS)
-> Show (PDFTree a)
forall a. Show a => Int -> PDFTree a -> ShowS
forall a. Show a => [PDFTree a] -> ShowS
forall a. Show a => PDFTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> PDFTree a -> ShowS
showsPrec :: Int -> PDFTree a -> ShowS
$cshow :: forall a. Show a => PDFTree a -> String
show :: PDFTree a -> String
$cshowList :: forall a. Show a => [PDFTree a] -> ShowS
showList :: [PDFTree a] -> ShowS
Show)
               
-- | The key function needed to export a Tree of PDF objects into the format defined 
-- by the PDF spec
fold2 :: Monad m => Maybe b -- ^ Parent ref
      -> (Maybe b -> PDFTree a -> PDFTree a -> m (Int,b)) -- ^ Node action
      -> (Maybe b -> Key a -> a -> m (Int,b)) -- ^ Leaf action
      -> PDFTree a -- ^ PDFTree
      -> m (Int,b) -- ^ Final action and reference of the root node
fold2 :: forall (m :: * -> *) b a.
Monad m =>
Maybe b
-> (Maybe b -> PDFTree a -> PDFTree a -> m (Int, b))
-> (Maybe b -> Key a -> a -> m (Int, b))
-> PDFTree a
-> m (Int, b)
fold2 Maybe b
_ Maybe b -> PDFTree a -> PDFTree a -> m (Int, b)
_ Maybe b -> Key a -> a -> m (Int, b)
_ PDFTree a
Nil = String -> m (Int, b)
forall a. HasCallStack => String -> a
error String
"Page tree is empty"
fold2 Maybe b
p Maybe b -> PDFTree a -> PDFTree a -> m (Int, b)
_ Maybe b -> Key a -> a -> m (Int, b)
leaf (Tip Key a
k a
a) = Maybe b -> Key a -> a -> m (Int, b)
leaf Maybe b
p Key a
k a
a
fold2 Maybe b
p Maybe b -> PDFTree a -> PDFTree a -> m (Int, b)
node Maybe b -> Key a -> a -> m (Int, b)
_ (Bin Key a
_ Key a
_ PDFTree a
l PDFTree a
r) = Maybe b -> PDFTree a -> PDFTree a -> m (Int, b)
node Maybe b
p PDFTree a
l PDFTree a
r



isLeaf :: PDFTree a -> Bool
isLeaf :: forall a. PDFTree a -> Bool
isLeaf (Tip Key a
_ a
_) = Bool
True
isLeaf PDFTree a
_ = Bool
False

keyOf :: PDFTree a -> Key a
keyOf :: forall a. PDFTree a -> Key a
keyOf (Tip Key a
k a
_) = Key a
k
keyOf PDFTree a
_ = String -> Key a
forall a. HasCallStack => String -> a
error String
"No key for a node"
  
{--------------------------------------------------------------------
  Query
--------------------------------------------------------------------}

-- | /O(n)/. Number of elements in the map.
size :: PDFTree a -> Int
size :: forall a. PDFTree a -> Int
size PDFTree a
t
  = case PDFTree a
t of
      Bin Prefix a
_ Prefix a
_ PDFTree a
l PDFTree a
r -> (PDFTree a -> Int
forall a. PDFTree a -> Int
size PDFTree a
l) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (PDFTree a -> Int
forall a. PDFTree a -> Int
size PDFTree a
r)
      Tip Prefix a
_ a
_ -> Int
1
      PDFTree a
Nil     -> Int
0

-- | /O(min(n,W))/. Lookup the value at a key in the map.
lookup :: Key a -> PDFTree a -> Maybe a
lookup :: forall a. Key a -> PDFTree a -> Maybe a
lookup Key a
k PDFTree a
t
  = let nk :: Nat
nk = Key a -> Nat
forall a. Key a -> Nat
natFromInt Key a
k  in Nat -> Maybe a -> Maybe a
forall a b. a -> b -> b
seq Nat
nk (Nat -> PDFTree a -> Maybe a
forall a. Nat -> PDFTree a -> Maybe a
lookupN Nat
nk PDFTree a
t)

lookupN :: Nat -> PDFTree a -> Maybe a
lookupN :: forall a. Nat -> PDFTree a -> Maybe a
lookupN Nat
k PDFTree a
t
  = case PDFTree a
t of
      Bin Prefix a
_ Prefix a
m PDFTree a
l PDFTree a
r 
        | Nat -> Nat -> Bool
zeroN Nat
k (Prefix a -> Nat
forall a. Key a -> Nat
natFromInt Prefix a
m) -> Nat -> PDFTree a -> Maybe a
forall a. Nat -> PDFTree a -> Maybe a
lookupN Nat
k PDFTree a
l
        | Bool
otherwise              -> Nat -> PDFTree a -> Maybe a
forall a. Nat -> PDFTree a -> Maybe a
lookupN Nat
k PDFTree a
r
      Tip Prefix a
kx a
x 
        | (Nat
k Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Prefix a -> Nat
forall a. Key a -> Nat
natFromInt Prefix a
kx)  -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
        | Bool
otherwise             -> Maybe a
forall a. Maybe a
Nothing
      PDFTree a
Nil -> Maybe a
forall a. Maybe a
Nothing
      
zeroN :: Nat -> Nat -> Bool
zeroN :: Nat -> Nat -> Bool
zeroN Nat
i Nat
m = (Nat
i Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
.&. Nat
m) Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
0

insert :: Key a -> a -> PDFTree a -> PDFTree a
insert :: forall a. Key a -> a -> PDFTree a -> PDFTree a
insert Key a
k a
x PDFTree a
t
  = case PDFTree a
t of
      Bin Key a
p Key a
m PDFTree a
l PDFTree a
r 
        | Key a -> Key a -> Key a -> Bool
forall a. Key a -> Key a -> Key a -> Bool
nomatch Key a
k Key a
p Key a
m -> Key a -> PDFTree a -> Key a -> PDFTree a -> PDFTree a
forall a.
Prefix a -> PDFTree a -> Prefix a -> PDFTree a -> PDFTree a
join Key a
k (Key a -> a -> PDFTree a
forall a. Key a -> a -> PDFTree a
Tip Key a
k a
x) Key a
p PDFTree a
t
        | Key a -> Key a -> Bool
forall a. Key a -> Key a -> Bool
zero Key a
k Key a
m      -> Key a -> Key a -> PDFTree a -> PDFTree a -> PDFTree a
forall a. Key a -> Key a -> PDFTree a -> PDFTree a -> PDFTree a
Bin Key a
p Key a
m (Key a -> a -> PDFTree a -> PDFTree a
forall a. Key a -> a -> PDFTree a -> PDFTree a
insert Key a
k a
x PDFTree a
l) PDFTree a
r
        | Bool
otherwise     -> Key a -> Key a -> PDFTree a -> PDFTree a -> PDFTree a
forall a. Key a -> Key a -> PDFTree a -> PDFTree a -> PDFTree a
Bin Key a
p Key a
m PDFTree a
l (Key a -> a -> PDFTree a -> PDFTree a
forall a. Key a -> a -> PDFTree a -> PDFTree a
insert Key a
k a
x PDFTree a
r)
      Tip Key a
ky a
_ 
        | Key a
kKey a -> Key a -> Bool
forall a. Eq a => a -> a -> Bool
==Key a
ky         -> Key a -> a -> PDFTree a
forall a. Key a -> a -> PDFTree a
Tip Key a
k a
x
        | Bool
otherwise     -> Key a -> PDFTree a -> Key a -> PDFTree a -> PDFTree a
forall a.
Prefix a -> PDFTree a -> Prefix a -> PDFTree a -> PDFTree a
join Key a
k (Key a -> a -> PDFTree a
forall a. Key a -> a -> PDFTree a
Tip Key a
k a
x) Key a
ky PDFTree a
t
      PDFTree a
Nil -> Key a -> a -> PDFTree a
forall a. Key a -> a -> PDFTree a
Tip Key a
k a
x
      
join :: Prefix a -> PDFTree a -> Prefix a -> PDFTree a -> PDFTree a
join :: forall a.
Prefix a -> PDFTree a -> Prefix a -> PDFTree a -> PDFTree a
join Prefix a
p1 PDFTree a
t1 Prefix a
p2 PDFTree a
t2
  | Prefix a -> Prefix a -> Bool
forall a. Key a -> Key a -> Bool
zero Prefix a
p1 Prefix a
m = Prefix a -> Prefix a -> PDFTree a -> PDFTree a -> PDFTree a
forall a. Key a -> Key a -> PDFTree a -> PDFTree a -> PDFTree a
Bin Prefix a
p Prefix a
m PDFTree a
t1 PDFTree a
t2
  | Bool
otherwise = Prefix a -> Prefix a -> PDFTree a -> PDFTree a -> PDFTree a
forall a. Key a -> Key a -> PDFTree a -> PDFTree a -> PDFTree a
Bin Prefix a
p Prefix a
m PDFTree a
t2 PDFTree a
t1
  where
    m :: Prefix a
m = Prefix a -> Prefix a -> Prefix a
forall a. Prefix a -> Prefix a -> Prefix a
branchMask Prefix a
p1 Prefix a
p2
    p :: Prefix a
p = Prefix a -> Prefix a -> Prefix a
forall a. Prefix a -> Prefix a -> Prefix a
mask Prefix a
p1 Prefix a
m
    
zero :: Key a -> Mask a -> Bool
zero :: forall a. Key a -> Key a -> Bool
zero Key a
i Key a
m
  = (Key a -> Nat
forall a. Key a -> Nat
natFromInt Key a
i) Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
.&. (Key a -> Nat
forall a. Key a -> Nat
natFromInt Key a
m) Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
0
  
nomatch :: Key a -> Prefix a -> Mask a -> Bool
nomatch :: forall a. Key a -> Key a -> Key a -> Bool
nomatch Prefix a
i Prefix a
p Prefix a
m
  = (Prefix a -> Prefix a -> Prefix a
forall a. Prefix a -> Prefix a -> Prefix a
mask Prefix a
i Prefix a
m) Prefix a -> Prefix a -> Bool
forall a. Eq a => a -> a -> Bool
/= Prefix a
p

mask :: Key a -> Mask a -> Prefix a
mask :: forall a. Prefix a -> Prefix a -> Prefix a
mask Key a
i Key a
m
  = Nat -> Nat -> Key a
forall a. Nat -> Nat -> Prefix a
maskW (Key a -> Nat
forall a. Key a -> Nat
natFromInt Key a
i) (Key a -> Nat
forall a. Key a -> Nat
natFromInt Key a
m)
  
{--------------------------------------------------------------------
  Big endian operations  
--------------------------------------------------------------------}
maskW :: Nat -> Nat -> Prefix a
maskW :: forall a. Nat -> Nat -> Prefix a
maskW Nat
i Nat
m
  = Nat -> Key a
forall a. Nat -> Key a
intFromNat (Nat
i Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
.&. (Nat -> Nat
forall a. Bits a => a -> a
complement (Nat
mNat -> Nat -> Nat
forall a. Num a => a -> a -> a
-Nat
1) Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
`xor` Nat
m))

branchMask :: Prefix a -> Prefix a -> Mask a
branchMask :: forall a. Prefix a -> Prefix a -> Prefix a
branchMask Prefix a
p1 Prefix a
p2
  = Nat -> Prefix a
forall a. Nat -> Key a
intFromNat (Nat -> Nat
highestBitMask (Prefix a -> Nat
forall a. Key a -> Nat
natFromInt Prefix a
p1 Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
`xor` Prefix a -> Nat
forall a. Key a -> Nat
natFromInt Prefix a
p2))
  
highestBitMask :: Nat -> Nat
highestBitMask :: Nat -> Nat
highestBitMask Nat
x
  = case (Nat
x Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
.|. Nat -> Int -> Nat
shiftRL Nat
x Int
1) of 
     Nat
x1 -> case (Nat
x1 Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
.|. Nat -> Int -> Nat
shiftRL Nat
x1 Int
2) of 
      Nat
x2 -> case (Nat
x2 Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
.|. Nat -> Int -> Nat
shiftRL Nat
x2 Int
4) of 
       Nat
x3 -> case (Nat
x3 Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
.|. Nat -> Int -> Nat
shiftRL Nat
x3 Int
8) of 
        Nat
x4 -> case (Nat
x4 Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
.|. Nat -> Int -> Nat
shiftRL Nat
x4 Int
16) of 
         Nat
x5 -> case (Nat
x5 Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
.|. Nat -> Int -> Nat
shiftRL Nat
x5 Int
32) of   -- for 64 bit platforms
          Nat
x6 -> (Nat
x6 Nat -> Nat -> Nat
forall a. Bits a => a -> a -> a
`xor` (Nat -> Int -> Nat
shiftRL Nat
x6 Int
1))
          
shiftRL :: Nat -> Int -> Nat
#if __GLASGOW_HASKELL__
{--------------------------------------------------------------------
  GHC: use unboxing to get @shiftRL@ inlined.
--------------------------------------------------------------------}
shiftRL :: Nat -> Int -> Nat
shiftRL (W# Word#
x) (I# Int#
i)
  = Word# -> Nat
W# (Word# -> Int# -> Word#
shiftRL# Word#
x Int#
i)
#else
shiftRL x i   = shiftR x i
#endif

empty :: PDFTree a
empty :: forall a. PDFTree a
empty
  = PDFTree a
forall a. PDFTree a
Nil
  
{--------------------------------------------------------------------
  Utilities 
--------------------------------------------------------------------}
foldlStrict :: (a -> t -> a) -> a -> [t] -> a
foldlStrict :: forall a t. (a -> t -> a) -> a -> [t] -> a
foldlStrict a -> t -> a
f a
z [t]
xs
  = case [t]
xs of
      []     -> a
z
      (t
x:[t]
xx) -> let z' :: a
z' = a -> t -> a
f a
z t
x in a -> a -> a
forall a b. a -> b -> b
seq a
z' ((a -> t -> a) -> a -> [t] -> a
forall a t. (a -> t -> a) -> a -> [t] -> a
foldlStrict a -> t -> a
f a
z' [t]
xx)
      
-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.
fromList :: [(Key a,a)] -> PDFTree a
fromList :: forall a. [(Key a, a)] -> PDFTree a
fromList [(Key a, a)]
xs
  = (PDFTree a -> (Key a, a) -> PDFTree a)
-> PDFTree a -> [(Key a, a)] -> PDFTree a
forall a t. (a -> t -> a) -> a -> [t] -> a
foldlStrict PDFTree a -> (Key a, a) -> PDFTree a
forall {a}. PDFTree a -> (Key a, a) -> PDFTree a
ins PDFTree a
forall a. PDFTree a
empty [(Key a, a)]
xs
  where
    ins :: PDFTree a -> (Key a, a) -> PDFTree a
ins PDFTree a
t (Key a
k,a
x)  = Key a -> a -> PDFTree a -> PDFTree a
forall a. Key a -> a -> PDFTree a -> PDFTree a
insert Key a
k a
x PDFTree a
t