module GLL.Combinators.Memoisation where

import              Data.IORef
import qualified    Data.IntMap     as IM
import System.IO.Unsafe

-- | 
-- A 'MemoTable' maps left-extent /l/ to right-extent /r/ to some results /a/
-- indicating the the substring ranging from /l/ to /r/ is derived with parse result /a/.
type MemoTable a = IM.IntMap (IM.IntMap a)

-- | An impure reference to a 'MemoTable'.
type MemoRef a   = IORef (MemoTable a)

memLookup :: (Int, Int) -> MemoTable a -> Maybe a
memLookup :: forall a. (Int, Int) -> MemoTable a -> Maybe a
memLookup (Int
l,Int
r) = Maybe a -> (IntMap a -> Maybe a) -> Maybe (IntMap a) -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe a
forall a. Maybe a
Nothing IntMap a -> Maybe a
forall {a}. IntMap a -> Maybe a
look' (Maybe (IntMap a) -> Maybe a)
-> (MemoTable a -> Maybe (IntMap a)) -> MemoTable a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> MemoTable a -> Maybe (IntMap a)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
l
 where  look' :: IntMap a -> Maybe a
look' = Maybe a -> (a -> Maybe a) -> Maybe a -> Maybe a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe a
forall a. Maybe a
Nothing a -> Maybe a
forall a. a -> Maybe a
Just (Maybe a -> Maybe a)
-> (IntMap a -> Maybe a) -> IntMap a -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
r 

memInsert :: (Int, Int) -> a -> MemoTable a -> MemoTable a
memInsert :: forall a. (Int, Int) -> a -> MemoTable a -> MemoTable a
memInsert (Int
l,Int
r) a
as = (Maybe (IntMap a) -> Maybe (IntMap a))
-> Int -> IntMap (IntMap a) -> IntMap (IntMap a)
forall a. (Maybe a -> Maybe a) -> Int -> IntMap a -> IntMap a
IM.alter Maybe (IntMap a) -> Maybe (IntMap a)
add' Int
l
 where  add' :: Maybe (IntMap a) -> Maybe (IntMap a)
add' Maybe (IntMap a)
mm = case Maybe (IntMap a)
mm of
                    Maybe (IntMap a)
Nothing -> IntMap a -> Maybe (IntMap a)
forall a. a -> Maybe a
Just (IntMap a -> Maybe (IntMap a)) -> IntMap a -> Maybe (IntMap a)
forall a b. (a -> b) -> a -> b
$ Int -> a -> IntMap a
forall a. Int -> a -> IntMap a
IM.singleton Int
r a
as
                    Just IntMap a
m  -> IntMap a -> Maybe (IntMap a)
forall a. a -> Maybe a
Just (IntMap a -> Maybe (IntMap a)) -> IntMap a -> Maybe (IntMap a)
forall a b. (a -> b) -> a -> b
$ Int -> a -> IntMap a -> IntMap a
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
r a
as IntMap a
m

-- |
-- Clears the 'MemoTable' to which the given reference refers.
memClear :: MemoRef a -> IO ()
memClear :: forall a. MemoRef a -> IO ()
memClear MemoRef a
ref = MemoRef a -> (MemoTable a -> MemoTable a) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef MemoRef a
ref (MemoTable a -> MemoTable a -> MemoTable a
forall a b. a -> b -> a
const MemoTable a
forall a. IntMap a
IM.empty)

-- | 
-- Create a reference to a fresh 'MemoTable'.
newMemoTable :: MemoRef a
newMemoTable :: forall a. MemoRef a
newMemoTable = IO (MemoRef a) -> MemoRef a
forall a. IO a -> a
unsafePerformIO (IO (MemoRef a) -> MemoRef a) -> IO (MemoRef a) -> MemoRef a
forall a b. (a -> b) -> a -> b
$ MemoTable a -> IO (MemoRef a)
forall a. a -> IO (IORef a)
newIORef MemoTable a
forall a. IntMap a
IM.empty