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
data Lens s v = Lens { get :: s -> v, put :: s -> v -> s }
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
data Putlens st e s v = Putlens {
getputM :: s -> (Maybe v,Create st e s v)
, createM :: Create st e s v }
type Putlens' s v = Putlens () s s v
getM :: Putlens st e s v -> Get s v
getM l s = let (v,create) = getputM l s in v
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'
evalPutM :: PutM e st s -> (e,Bool) -> (st,Bool) -> s
evalPutM m e st = evalSt (runReaderT m e) st
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)
withPutM :: (st -> e -> a) -> PutM e st a
withPutM f = do (st,testPutGet) <- readSt
(e,testGetPut) <- ask
return (f st e)
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'
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')