{-# OPTIONS_GHC -fglasgow-exts #-}
module StormData where

-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup
-- This file is part of Fenfire.
-- 
-- Fenfire is free software; you can redistribute it and/or modify it under
-- the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
-- 
-- Fenfire is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
-- Public License for more details.
-- 
-- You should have received a copy of the GNU General
-- Public License along with Fenfire; if not, write to the Free
-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
-- MA  02111-1307  USA

import Storm
import Fenfire.RDF
import Fenfire.Utils
import qualified Fenfire.Raptor as Raptor

import Control.Monad hiding (join)

import Data.Binary (Binary)
import qualified Data.Binary as Binary
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as Lazy

import System.IO.Unsafe (unsafePerformIO)

data (FromRDF a, ToRDF a) => StormRef a = StormRef Node
-- possible system for the future:
-- UnreadStormRef Node | ReadStormRef Node a | UnserializedStormRef a

instance FromRDF (StormRef a) where
    fromRDF _ n = return $ StormRef n

instance ToRDF (StormRef a) where
    toRDF (StormRef n) = return n
  
bURI :: BlockId -> String
bURI (BlockId bid) = "blk:/" ++ bid
  
bIRI :: BlockId -> Node
bIRI bid = IRI $ bURI bid

bID :: Node -> BlockId
bID (IRI ('b':'l':'k':':':'/':s)) = BlockId $ takeWhile (/= '#') s
bID node = error $ "Not a block IRI: " ++ show node
                                        
getNode :: StormMonad m => Node -> m ByteString
getNode = getBlock . bID
                
getGraph :: StormMonad m => Node -> m Graph
getGraph n = do bytes <- getNode n
                let (ts, nss) = unsafePerformIO $ 
                        Raptor.bytesToTriples "turtle" bytes (iriStr n)
                return $ raptorToGraph ts nss (iriStr n)
                
getData :: (FromRDF a, StormMonad m) => Node -> m a
getData n = do g <- getGraph n; Right x <- return $ fromRDF g n
               return x
                
readStormRef :: (FromRDF a, ToRDF a, StormMonad m) => StormRef a -> m a
readStormRef (StormRef n) = getData n

showGraph :: Graph -> ByteString
showGraph g = let (ts,nss) = graphToRaptor g; uri = iriStr $ defaultGraph g
               in unsafePerformIO $ Raptor.triplesToBytes ts nss uri
                 
addGraph :: StormMonad m => Graph -> m Node
addGraph g = liftM bIRI $ addBlock (showGraph g)

addData :: (ToRDF a, StormMonad m) => a -> m Node
addData value = do let (node, g) = runToRDF (IRI "new:block") $ toRDF value
                   node' <- addGraph g
                   return $ changeBaseURI "new:block" (iriStr node') node

newStormRef :: (FromRDF a, ToRDF a, StormMonad m) => a -> m (StormRef a)
newStormRef = liftM StormRef . addData

modifyStormRef :: (FromRDF a, ToRDF a, StormMonad m) =>
                  EndoM m a -> EndoM m (StormRef a)
modifyStormRef f r = readStormRef r >>= f >>= newStormRef


----------------------------------------------------------------------------
-- Binary data
----------------------------------------------------------------------------

data Binary a => BinRef a = BinRef { refId :: BlockId }   deriving (Eq,Ord)

getBinary :: (Binary a, StormMonad m) => BlockId -> m a
getBinary bid = liftM (Binary.decode . Lazy.pack . ByteString.unpack) $
                getBlock bid
                
readBinRef :: (Binary a, StormMonad m) => BinRef a -> m a
readBinRef (BinRef bid) = getBinary bid

addBinary :: (Binary a, StormMonad m) => a -> m BlockId
addBinary = addBlock . ByteString.pack . Lazy.unpack . Binary.encode

newBinRef :: (Binary a, StormMonad m) => a -> m (BinRef a)
newBinRef = liftM BinRef . addBinary

modifyBinRef :: (Binary a, StormMonad m) => EndoM m a -> EndoM m (BinRef a)
modifyBinRef f r = readBinRef r >>= f >>= newBinRef


----------------------------------------------------------------------------
-- Data structures: StormMap (hash-balanced search tree)
----------------------------------------------------------------------------

-- Definition: The *degree* of a storm block is the number of leading zeros
-- in the block id.

-- A StormMap is a binary search tree mapping (keys serializable as)
-- storm blocks to (values serialziable as) storm blocks.

-- The root of a subtree contains the key/value mapping whose key
-- has the highest degree in this subtree. If there is more than one key
-- with the same degree, the root contains the one whose block id is smallest.

-- This gives us a probabilistically balanced tree whose shape is determined
-- by the set of key/value mappings. This data structure is essentially due to
-- Pugh and Teitelbaum, "Incremental computation via function caching," 1989.

type StormMap k v = Maybe (BinRef (Tree k v))
data Tree     k v = Tree (StormMap k v) (BinRef k) (BinRef v) (StormMap k v)

degree :: BinRef a -> Int
degree = error "StormData.degree: not implemented"

instance Binary (Tree k v) where -- XXX

search :: (Binary k, Binary v, StormMonad m) =>
          BinRef k -> StormMap k v -> m (Maybe v)
search _ Nothing = return Nothing
search x (Just ref) = readBinRef ref >>= f where
    f (Tree l k v r) | x < k  = search x l
                     | x == k = liftM Just (readBinRef v)
                     | x > k  = search x r
                     
-- Changes to the tree are done through two internal functions: split and join.
-- 'split k t' returns a pair of subtrees: one containing the mappings
-- whose keys are smaller than 'k' and one containing the mappings whose keys
-- are larger. 'join s t' joins s and t under the assumption that
-- all elements of s are smaller than all elements of t.

split :: (Binary k, Binary v, StormMonad m) =>
         BinRef k -> StormMap k v -> m (StormMap k v, StormMap k v)
split _ Nothing = return (Nothing, Nothing)
split x (Just ref) = readBinRef ref >>= f where
    f (Tree l k v r) | x < k  = do (ll,lr) <- split x l
                                   t <- newBinRef (Tree lr k v r)
                                   return (ll, Just t)
                     | x == k = return (l, r)
                     | x > k  = do (rl,rr) <- split x r
                                   t <- newBinRef (Tree l k v rl)
                                   return (Just t, rr)

join :: (Binary k, Binary v, StormMonad m) =>
        StormMap k v -> StormMap k v -> m (StormMap k v)
join l Nothing = return l
join Nothing r = return r
join (Just x) (Just y) = do x' <- readBinRef x; y' <- readBinRef y; f x' y'
    where f (Tree lx kx vx rx) (Tree ly ky vy ry)
              | degree kx < degree ky = do ly' <- join (Just x) ly
                                           t <- newBinRef (Tree ly' ky vy ry)
                                           return (Just t)
              | otherwise             = do rx' <- join rx (Just y)
                                           t <- newBinRef (Tree lx kx vx rx')
                                           return (Just t)

-- With the heavy lifting done, the rest is simple.

insert :: (Binary k, Binary v, StormMonad m) =>
          BinRef k -> BinRef v -> StormMap k v -> m (StormMap k v)
insert k v m = do (l,r) <- split k m
                  t <- newBinRef (Tree Nothing k v Nothing)
                  t' <- join (Just t) r
                  join l t'

remove :: (Binary k, Binary v, StormMonad m) =>
          BinRef k -> StormMap k v -> m (StormMap k v)
remove k m = do (l,r) <- split k m
                join l r


----------------------------------------------------------------------------
-- Data structures: Append-only log
----------------------------------------------------------------------------

data Binary a => Pair a = Pair (BinRef a) (BinRef a)

instance Binary (Pair a) where -- XXX

data Binary a => Log a = Empty 
                       | Zero (BinRef (Log (Pair a)))
                       | One (BinRef a) (BinRef (Log (Pair a)))

instance Binary (Log a) where -- XXX

first :: (Binary a, StormMonad m) => Pair a -> m a
first (Pair r _) = readBinRef r

second :: (Binary a, StormMonad m) => Pair a -> m a
second (Pair _ r) = readBinRef r

appendLog :: (Binary a, StormMonad m) => a -> Log a -> m (Log a)
appendLog x Empty       = do rx <- newBinRef x; re <- newBinRef Empty
                             return (One rx re)
appendLog x (Zero rs)   = do rx <- newBinRef x
                             return (One rx rs)
appendLog x (One ry rs) = do rx <- newBinRef x
                             rs' <- modifyBinRef (appendLog $ Pair rx ry) rs
                             return (Zero rs')

data MList m a = MNil | MCons a (m (MList m a))

infixr 5 .++.

(.++.) :: Monad m => m (MList m a) -> m (MList m a) -> m (MList m a)
m1 .++. m2 = do l1 <- m1
                case l1 of MNil -> m2
                           MCons x xs -> return $ MCons x (xs .++. m2)
                           
mtake :: Monad m => Int -> MList m a -> m [a]
mtake 0 _ = return []
mtake _ MNil = return []
mtake n (MCons x mxs) = liftM (x:) (mxs >>= mtake (n-1))

readLog :: (Binary a, StormMonad m) => Log a -> m (MList m a)
readLog log = withLog (\x l -> return (MCons x l)) log (return MNil) where
    withPair :: (Binary a, StormMonad m) => 
                (a -> Endo (m (MList m b))) -> Pair a -> Endo (m (MList m b))
    withPair f (Pair rx ry) ml = 
        do x <- readBinRef rx; f x $ do y <- readBinRef ry; f y ml

    withLog :: (Binary a, StormMonad m) =>
               (a -> Endo (m (MList m b))) -> Log a -> Endo (m (MList m b))
    withLog f Empty ml = ml
    withLog f (Zero rs) ml = do s <- readBinRef rs; withLog (withPair f) s ml
    withLog f (One rx rs) ml = do s <- readBinRef rs; withLog (withPair f) s $
                                      do x <- readBinRef rx; f x ml