-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.Putlenses.Putlens
-- Copyright   :  (C) 2013 Hugo Pacheco
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Hugo Pacheco <hpacheco@nii.ac.jp>
-- Stability   :  provisional
--
-- General framework for put-based lenses.
--
-- A well-behaved putlens is expected to satisfy two properties:
-- GetPut: |Just v = get l s => s = runPutM (put (Just s) v) e st|
-- PutGet: |s' = runPutM (put s v') e st => Just v' = get s'|
-- 
--
--
----------------------------------------------------------------------------

module Generics.Putlenses.Putlens where

import Control.Monad.State.Lazy (State,MonadState)
import qualified Control.Monad.State.Lazy as ST
import Control.Monad.Reader
import Data.Maybe
import qualified Control.Lens as L

evalSt :: State s a -> s -> a
evalSt = ST.evalState

readSt :: MonadState s m => m s
readSt = ST.get

writeSt :: MonadState s m => s -> m ()
writeSt = ST.put

runSt :: State s a -> s -> (a,s)
runSt = ST.runState

-- | Interface for normal lenses
data Lens s v = Lens { get :: s -> v, put :: s -> v -> s }

-- | Monad for put-based lenses
-- includes an environment, state, and boolean tags that our system will use to ensure GetPut and PutGet
type PutM e st a = ReaderT (e,Bool) (State (st,Bool)) a

type Get s v = s -> Maybe v
type Put st e s v = Maybe s -> v -> PutM e st s
type Create st e s v = v -> PutM e st s

-- | Framework for put-based lenses
data Putlens st e s v = Putlens {
    getputM :: s -> (Maybe v,Create st e s v)
  , createM :: Create st e s v }
-- tupled framework for efficiency

type Putlens' s v = Putlens () s s v

-- | Forward |get| function
getM :: Putlens st e s v -> Get s v
getM l s = let (v,create) = getputM l s in v

-- | Backward |put| function
putM :: Putlens st e s v -> Put st e s v
putM l Nothing v' = createM l v'
putM l (Just s) v' = let (v,create) = getputM l s in create v'

-- | Runs a putlens for a particular environment and state
evalPutM :: PutM e st s -> (e,Bool) -> (st,Bool) -> s
evalPutM m e st = evalSt (runReaderT m e) st

-- Runs a putlens fo a particular environment and state, returning also the TestPutGet flag
runPutM :: PutM e st s -> (e,Bool) -> (st,Bool) -> (s,Bool)
runPutM m e st = let (s,(_,testPutGet)) = runSt (runReaderT m e) st in (s,testPutGet)

-- | Computes a value of type |a| using the current state and environment
withPutM :: (st -> e -> a) -> PutM e st a
withPutM f = do (st,testPutGet) <- readSt
                (e,testGetPut) <- ask
                return (f st e)

-- Converts a simple lens of the Haskell lens package into a putlens
simplelens2put :: L.Lens' s v -> Putlens st e s v
simplelens2put l = Putlens getput' create'
    where get' s = L.view l s
          put' s v' =  return $ L.set l v' s
          getput' s = (Just (get' s),put' s)
          create' v' = put' (error "simplelens2put: no original source") v'

-- | Converts a putlens to a normal lens.
-- Initializes the environment as the original source, the state as empty, the GetPut tag as True and the PutGet tag as False
put2lens :: Eq v => Putlens' s v -> Lens s v
put2lens l = Lens get' put'
	where get' = fst . getput' l
	      put' = snd . getput' l
	
get' :: Eq v => Putlens' s v -> (s -> v)
get' l = get (put2lens l)

put' :: Eq v => Putlens' s v -> (s -> v -> s)
put' l = put (put2lens l)

getput' :: Eq v => Putlens' s v -> (s -> (v,v -> s))
getput' l s = let (mbv,put) = getputM l s
                  put' v' = let (s',testPutGet) = runPutM (put v') (s,True) ((),False)
                            in if testPutGet && getM l s' /= Just v' then error "put2lens (unsafe casts violate PutGet)" else s'
                  v = case mbv of { Just x -> x ; otherwise -> error "get fails"}
              in (v,put')