module Generics.Putlenses.Putlens where
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State (State,MonadState,StateT)
import qualified Control.Monad.State as State
import Data.Maybe
import qualified Control.Lens as L
import Control.Monad.Identity
import Control.Monad.Trans
import Data.Monoid
import Control.Monad.Trans.Maybe
newtype GetPut = GetPut Bool
newtype PutGet = PutGet Bool
testGetPut (GetPut gp) = gp
testPutGet (PutGet pg) = pg
instance Monoid PutGet where
mempty = PutGet False
mappend (PutGet x) (PutGet y) = PutGet (x || y)
data LensM m s v = LensM { get :: s -> v, put :: s -> v -> m s, create :: v -> m s }
type Lens s v = LensM Identity s v
simpleput :: Lens s v -> (s -> v -> s)
simpleput l s = runIdentity . put l s
simplecreate :: Lens s v -> (v -> s)
simplecreate l = runIdentity . create l
type PutM m a = ReaderT GetPut (WriterT PutGet m) a
type Get s v = s -> Maybe v
type Put m s v = Maybe s -> v -> PutM m s
type Create m s v = v -> PutM m s
data PutlensM m s v = PutlensM {
getputM :: s -> (Maybe v,Create m s v)
, createM :: Create m s v }
type PutlensMaybeM m s v = PutlensM (MaybeT m) s v
type PutlensReaderM m e s v = PutlensM (ReaderT e m) s v
type PutlensStateM m st s v = PutlensM (StateT st m) s v
type Putlens s v = PutlensM Identity s v
mapPutM :: (forall a. m a -> n a) -> PutM m a -> PutM n a
mapPutM f = mapReaderT (mapWriterT f)
mapPutlensM :: Monad m => (forall a. m a -> n a) -> PutlensM m s v -> PutlensM n s v
mapPutlensM f l = PutlensM getput' create'
where getput' s = let (v,put') = getputM l s in (v,\v' -> mapPutM f (put' v'))
create' v' = mapPutM f (createM l v')
liftPutM :: Monad m => m s -> PutM m s
liftPutM m = lift (lift m)
liftPutlensM :: (MonadTrans t,Monad m) => PutlensM m s v -> PutlensM (t m) s v
liftPutlensM = mapPutlensM lift
getM :: PutlensM m s v -> Get s v
getM l s = let (v,create) = getputM l s in v
dom :: PutlensM m s v -> (s -> Bool)
dom f = isJust . getM f
putM :: PutlensM m s v -> Put m s v
putM l Nothing v' = createM l v'
putM l (Just s) v' = let (v,create) = getputM l s in create v'
evalPutM :: Monad m => PutM m s -> GetPut -> m s
evalPutM putm e = liftM fst (runPutM putm e)
runPutM :: Monad m => PutM m s -> GetPut -> m (s,PutGet)
runPutM putm e = runWriterT (runReaderT putm e)
lens2put :: Monad m => LensM m s v -> PutlensM m s v
lens2put (LensM get put create) = PutlensM getputM' createM'
where getputM' s = (Just (get s),\v -> liftPutM $ put s v)
createM' v = liftPutM $ create v
simplelens2put :: Monad m => L.Lens' s v -> PutlensM m s v
simplelens2put l = PutlensM 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'
put2lens :: Eq v => Putlens s v -> Lens s v
put2lens = put2lensM' True True
put2quicklens :: Eq v => Putlens s v -> Lens s v
put2quicklens = put2lensM' False True
put2quicklensNoGetPut :: Eq v => Putlens s v -> Lens s v
put2quicklensNoGetPut = put2lensM' False False
put2lensNoGetPut :: Eq v => Putlens s v -> Lens s v
put2lensNoGetPut = put2lensM' True False
put2lensM :: (Monad m,Eq v) => PutlensM m s v -> LensM m s v
put2lensM = put2lensM' True True
put2quicklensM :: (Monad m,Eq v) => PutlensM m s v -> LensM m s v
put2quicklensM = put2lensM' False True
put2lensNoGetPutM :: (Monad m,Eq v) => PutlensM m s v -> LensM m s v
put2lensNoGetPutM = put2lensM' True False
put2quicklensNoGetPutM :: (Monad m,Eq v) => PutlensM m s v -> LensM m s v
put2quicklensNoGetPutM = put2lensM' False False
put2lensM' :: (Monad m,Eq v) => Bool -> Bool -> PutlensM m s v -> LensM m s v
put2lensM' checkPutGet checkGetPut l = LensM get put create
where get = liftM fst $ getput' checkPutGet checkGetPut l
put = liftM snd $ getput' checkPutGet checkGetPut l
create = create' checkPutGet l
get' :: Eq v => PutlensM m s v -> (s -> v)
get' l s = case getM l s of
Just v -> v
Nothing -> error "get fails"
put' :: (Monad m,Eq v) => Bool -> Bool -> PutlensM m s v -> (s -> v -> m s)
put' checkPutGet checkGetPut l = put (put2lensM' checkPutGet checkGetPut l)
getput' :: (Monad m,Eq v) => Bool -> Bool -> PutlensM m s v -> (s -> (v,v -> m s))
getput' checkPutGet checkGetPut l s =
let (mbv,put) = getputM l s
put' v' = do
(s',pg) <- runPutM (put v') (GetPut checkGetPut)
if checkPutGet && testPutGet pg && getM l s' /= Just v'
then fail "put2lens (unsafe casts violate PutGet)"
else return s'
v = case mbv of { Just x -> x ; otherwise -> error "get fails"}
in (v,put')
create' :: (Monad m,Eq v) => Bool -> PutlensM m s v -> (v -> m s)
create' checkPutGet l v' = do
(s',pg) <- runPutM (createM l v') (GetPut False)
if checkPutGet && testPutGet pg && getM l s' /= Just v'
then fail "put2lens (unsafe casts violate PutGet)"
else return s'
put2create :: (Monad m,Eq v) => PutlensM m s v -> PutlensM m s v
put2create l = checkGetPut $ l { getputM = getput }
where getput s = let (mbv,put) = getputM l s
in (mbv,createM l)
checkGetPut :: (Monad m,Eq v) => PutlensM m s v -> PutlensM m s v
checkGetPut l = l { getputM = getput' }
where getput' s = let (v,put) = getputM l s
put' v' = do gp <- ask
if testGetPut gp && v == Just v' then return s else put v'
in (v,put')
checkPutGet :: Monad m => PutlensM m s v -> PutlensM m s v
checkPutGet l = PutlensM getput' (create' (createM l))
where getput' s = let (v,put) = getputM l s in (v,create' put)
create' put v' = lift (tell $ PutGet True) >> put v'
offGetPut :: Monad m => PutM m s -> PutM m s
offGetPut m = withReaderT (\gp -> GetPut False) m
onPutGet :: Monad m => PutM m s -> PutM m s
onPutGet m = lift (tell $ PutGet True) >> m