{-# Language ExistentialQuantification, ScopedTypeVariables, StandaloneDeriving,
    DeriveDataTypeable, FlexibleContexts #-}

-----------------------------------------------------------------------------
--
-- Module      :  Base.State
-- Copyright   :  Juergen Nicklisch-Franken
-- License     :  LGPL
--
-- Maintainer  :  maintainer@leksah.org
-- Stability   :  provisional
-- Portability :  portabel
--
-- | A simple state service.
-- A state has to br registered with an initial value, before it can be used.
--
-----------------------------------------------------------------------------

module Base.State (
-- * High level interface
    registerState,
    setState,
    getState,
    hasState,
    withState,
    runState,

-- * Convenience functions
    reifyState,
    reflectState,
    runInIO,
    catchState,
    forkState,

-- * Types
    TheState,
    StateRef,
    StateM,
    StateAction,
    GenState(..),

-- * Low level interface
    registerState',
) where

import Base.Selector

import Data.IORef
       (atomicModifyIORef, readIORef, writeIORef, newIORef, IORef)
import Control.Monad.Reader (ReaderT(..))
import qualified Data.Map as Map (insert, lookup, empty)
import Data.Map (Map)
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (liftM)
import Data.Maybe (fromJust, isJust)
import Control.Exception (catch, Exception)
import Control.Concurrent (forkIO)
import Prelude hiding (catch)
import Unsafe.Coerce (unsafeCoerce)

--
-- | A state is a Map from a selector to something
--
type State a = Map GenSelector a

--
-- | The special types getting lost here, but can be recovered by attaching runtime
-- type information via Typeable
--
data GenState = forall alpha . GenState alpha

--
-- | The concrete state is build from this
--
type TheState = State GenState

--
-- | A mutable reference to the IDE state
--
type StateRef = IORef TheState

--
-- | The IDE Monad
--
type StateM = ReaderT StateRef IO

--
-- | A shorthand for a reader monad for a mutable reference to the IDE state
--   which does not return a value
--
type StateAction = StateM ()

--
-- | Initial call for the state service,
--  everything has to happen now inside this monad
--
runState :: StateM a -> IO a
runState f = do
    ref :: StateRef <- newIORef Map.empty
    reflectState f ref

--
-- | Lift an IO action to an IDE action
--
reifyState :: (StateRef -> IO a) -> StateM a
reifyState = ReaderT

runInIO :: forall alpha beta. (beta -> StateM alpha) -> StateM (beta -> IO alpha)
runInIO f          =   reifyState (\ideRef -> return (\v -> reflectState (f v) ideRef))

--
-- | Do an IDE action in the IO monad
--
reflectState :: StateM a -> StateRef -> IO a
reflectState c ideR = runReaderT c ideR

catchState :: Exception e => StateM a -> (e -> StateM a) -> StateM a
catchState block handler = reifyState (\ideR -> catch (reflectState block ideR) (handler' ideR))
  where
    handler' ideR = (\ f e -> reflectState (f e) ideR) handler

forkState :: StateAction  -> StateAction
forkState block  = reifyState (\ideR -> forkIO  (reflectState block ideR) >> return ())


-- ---------------------------------------------------------------------
-- * Methods for accesing the IDE State
--

--
-- | Read an attribute of the contents
--
readStateM :: (TheState -> beta) -> StateM beta
readStateM f = do
    e <- ask
    liftIO $ liftM f (readIORef e)

--
-- | Modify the contents, without returning a value
--
modifyStateM_ :: (TheState -> TheState) -> StateM ()
modifyStateM_ f = let f' a  = (f a,()) in do
    e <- ask
    liftIO (atomicModifyIORef e f')

--
-- | Variation on modifyIDE_ that lets you return a value
--
modifyStateM :: (TheState -> (TheState,beta)) -> StateM beta
modifyStateM f = do
    e <- ask
    liftIO (atomicModifyIORef e f)

--
-- | Call a function in the IO Monad with the state and return the result
--
withStateM :: (TheState -> IO alpha) -> StateM alpha
withStateM f = do
    e <- ask
    liftIO $ f =<< readIORef e

--
-- | Gets the state
--
getStateM :: StateM(TheState)
getStateM = do
    e <- ask
    st <- liftIO $ readIORef e
    return st

--
-- | Registers a key and sets the value. Returns nothing if everything works,
-- else just an error string
--
registerState :: Selector alpha => alpha -> ValueType alpha -> StateM (Maybe String)
registerState key value = do
    hasIt <- hasState key
    if hasIt then return $ Just $ "State>>registerState: " ++
                                    "State already registered " ++ show key
             else modifyStateM_ (\st -> Map.insert (GS key) (GenState value) st) >> return Nothing

--
-- | Registers a key
--
registerState' :: Selector alpha => alpha -> GenState -> StateM (Maybe String)
registerState' key value = do
    hasIt <- hasState key
    if hasIt then return $ Just $ "State>>registerState: " ++
                                    "State already registered " ++ show key
             else modifyStateM_ (\st -> Map.insert (GS key) value st) >> return Nothing

--
-- | Set a value for a key
--
setState ::  Selector alpha => alpha  -> ValueType alpha -> StateM ()
setState key value = modifyStateM_ (\ st -> case GS key `Map.lookup` st of
                                            Nothing -> error $ "State>>setState: " ++
                                                            "State not registered " ++ show key
                                            Just _ -> Map.insert (GS key) (GenState value) st)

--
-- | Get a value for a key
--
getState :: Selector alpha => alpha  -> StateM (ValueType alpha)
getState key = readStateM (\st -> case (GS key) `Map.lookup` st of
                                Nothing -> error $ "State>>getState: " ++
                                    "State not registered " ++ show key
                                Just (GenState v) -> unsafeCoerce v)

--
-- | Is this state registered?
--
hasState :: Selector alpha => alpha -> StateM Bool
hasState sel = readStateM (\st -> case GS sel `Map.lookup` st of
                                    Nothing -> False
                                    Just _  -> True)

--
-- | Do the function with the state and set the result as new value
--
withState :: Selector alpha => alpha -> (ValueType alpha -> ValueType alpha) -> StateM ()
withState key f =
    modifyStateM_
        (\ st -> case (GS key) `Map.lookup` st of
                    Nothing -> error $ "State>>withState: " ++
                                    "State not registered " ++ show key
                    Just (GenState v) ->
                            let nv = f (unsafeCoerce v)
                            in Map.insert (GS key) (GenState nv) st)