{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, TypeFamilies,
             FunctionalDependencies, ScopedTypeVariables, FlexibleContexts #-}

module Graphics.Rendering.Ombra.Internal.Resource (
        ResMap,
        ResStatus(..),
        Resource(..),
        newResMap,
        addResource,
        getResource,
        getResource',
        checkResource,
        removeResource,
        unloader
) where

import Control.Monad.Base
import Control.Monad.Trans.Control
import qualified Data.HashTable.IO as H
import Data.Hashable
import System.Mem.Weak

data ResMap r = ResMap (H.LinearHashTable Int (Either String r)) 

data ResStatus r = Loaded r
                 | Unloaded
                 | Error String

class (Eq i, Applicative m, MonadBaseControl IO m, Hashable i) =>
        Resource i r m where
        loadResource :: i -> m (Either String r)
        unloadResource :: Maybe i -> r -> m ()

newResMap :: MonadBase IO m => m (ResMap r)
newResMap = ResMap <$> liftBase H.new

addResource :: Resource i r m => i -> ResMap r -> m ()
addResource i m = () <$ getResource i m

checkResource :: Resource i r m
              => i
              -> ResMap r
              -> m (ResStatus r)
checkResource i = checkResource' (Just i) $ hash i

checkResource' :: Resource i r m
               => Maybe i
               -> Int
               -> ResMap r
               -> m (ResStatus r)
checkResource' _ i (ResMap map) = do m <- liftBase $ H.lookup map i
                                     return $ case m of
                                                   Just (Right r) -> Loaded r
                                                   Just (Left e) -> Error e
                                                   Nothing -> Unloaded


getResource :: Resource i r m => i -> ResMap r -> m (Either String r)
getResource i = getResource' (Just i) i

getResource' :: Resource i r m => Maybe k -> i -> ResMap r -> m (Either String r)
getResource' mk (i :: i) rmap@(ResMap map) =
        do status <- checkResource i rmap
           case status of
                   Unloaded ->
                        do r <- loadResource i

                           liftBase $
                                   case r of
                                        Left s -> H.insert map ihash $ Left s
                                        Right r -> H.insert map ihash $ Right r

                           case mk of
                                Just k -> liftBaseDiscard (addFinalizer k) $
                                        removeResource' (Nothing :: Maybe i)
                                                        ihash rmap
                                Nothing -> return ()

                           meRes <- liftBase . H.lookup map $ ihash
                           return $ case meRes of
                                         Just eRes -> eRes
                                         Nothing -> Left "Resource finalized"
                   Error s -> return $ Left s
                   Loaded r -> return $ Right r
        where ihash = hash i

-- reloadResource

removeResource :: Resource i r m => i -> ResMap r -> m ()
removeResource i = removeResource' (Just i) $ hash i

removeResource' :: Resource i r m => Maybe i -> Int -> ResMap r -> m ()
removeResource' mi i rmap@(ResMap map) = 
        do status <- checkResource' mi i rmap
           case status of
                Loaded r -> unloadResource mi r
                _ -> return ()
           liftBase $ H.delete map i

unloader :: (Resource i r m, MonadBaseControl IO m) => k -> Maybe i -> r -> m ()
unloader k i r = liftBaseDiscard (addFinalizer k) $ unloadResource i r

instance Functor ResStatus where
        fmap f (Loaded r) = Loaded (f r)
        fmap _ Unloaded = Unloaded
        fmap _ (Error s) = Error s