module Data.Transform.Internal (
EndoList
,EndoItem
,EndoListM
,EndoMItem
,Transformation
,MonadicTransformation
,mkItem
,mkItemM
,transform
,transformM
,unsafeTransform
,unsafeTransformM
,getSubterms
,getSubterms'
,getSubtermsBy
,getSubtermsWith
) where
import Data.List
import Data.Data
import Data.Monoid
import qualified Data.Semigroup as S
import Control.Monad
import Control.Monad.Writer
import Control.Monad.State
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Exts (IsList(..))
import Unsafe.Coerce
data EndoItem where
EndoItem :: Data a => (a -> a) -> EndoItem
data EndoList where
Nil :: EndoList
Cons :: Data a => (a -> a) -> EndoList -> EndoList
data EndoMItem m where
EndoMItem :: (Monad m, Data a) => (a -> m a) -> EndoMItem m
data EndoListM m where
NilM :: EndoListM m
ConsM :: (Monad m, Data a) => (a -> m a) -> EndoListM m -> EndoListM m
mkItem :: Data a => (a -> a) -> EndoItem
mkItem = EndoItem
mkItemM :: (Monad m, Data a) => (a -> m a) -> EndoMItem m
mkItemM = EndoMItem
instance S.Semigroup EndoList where
Nil <> b = b
(Cons x l) <> b = Cons x (l S.<> b)
instance Monoid EndoList where
mempty = Nil
mappend = (S.<>)
instance IsList EndoList where
type Item EndoList = EndoItem
fromList = toEndoList
toList = unfoldr $ \case
Nil -> Nothing
Cons f l -> Just (EndoItem f, l)
instance S.Semigroup (EndoListM m) where
NilM <> b = b
(ConsM x l) <> b = ConsM x (l S.<> b)
instance Monoid (EndoListM m) where
mempty = NilM
mappend = (S.<>)
instance Monad m => IsList (EndoListM m) where
type Item (EndoListM m) = EndoMItem m
fromList = toEndoListM
toList = unfoldr $ \case
NilM -> Nothing
ConsM f l -> Just (EndoMItem f, l)
appEndoList :: Data a => EndoList -> a -> a
appEndoList Nil a = a
appEndoList (Cons f l) a = appEndoList l $ maybe a (unsafeCoerce . f) $ cast a
appEndoListM :: (Monad m, Data a) => EndoListM m -> a -> m a
appEndoListM NilM a = return a
appEndoListM (ConsM f l) a = maybe (return a) (liftM unsafeCoerce . f) (cast a) >>= appEndoListM l
class Transformation d where
mkEndoList :: d -> EndoList
toEndoList :: [d] -> EndoList
toEndoList = mconcat . map mkEndoList
class Monad m => MonadicTransformation d m | d -> m where
mkEndoListM :: d -> EndoListM m
toEndoListM :: [d] -> EndoListM m
toEndoListM = mconcat . map mkEndoListM
instance Transformation EndoList where
mkEndoList = id
toEndoList = mconcat
instance Transformation EndoItem where
mkEndoList (EndoItem f) = Cons f Nil
toEndoList = foldr (\ (EndoItem f) -> Cons f) Nil
instance Transformation a => Transformation [a] where
mkEndoList = toEndoList
instance Data a => Transformation (a -> a) where
mkEndoList f = Cons f Nil
toEndoList = foldr Cons Nil
instance Data a => Transformation (Endo a) where
mkEndoList f = Cons (appEndo f) Nil
toEndoList = foldr (Cons . appEndo) Nil
instance Monad m => MonadicTransformation (EndoListM m) m where
mkEndoListM = id
toEndoListM = mconcat
instance Monad m => MonadicTransformation (EndoMItem m) m where
mkEndoListM (EndoMItem f) = ConsM f NilM
toEndoListM = foldr (\ (EndoMItem f) -> ConsM f) NilM
instance (Monad m, Data a) => MonadicTransformation (a -> m a) m where
mkEndoListM f = ConsM f NilM
toEndoListM = foldr ConsM NilM
instance MonadicTransformation a m => MonadicTransformation [a] m where
mkEndoListM = toEndoListM
transform :: (Transformation d, Data a) => d -> a -> a
transform d a = case mkEndoList d of
f -> case getNeededTypeReps f `Set.difference` allContainedTypeReps a of
s | not (Set.null s) -> error $ "Data.DataTraverse.transform: Could not find all needed types when mapping over a value of type " ++ show (typeOf a) ++ ". Types of missing terms: " ++ show (Set.toList s)
| otherwise -> unsafeTransform' f a
transformM :: (MonadicTransformation d m, Data a) => d -> a -> m a
transformM d a = case mkEndoListM d of
f -> case getNeededTypeRepsM f `Set.difference` allContainedTypeReps a of
s | not (Set.null s) -> fail $ "Data.DataTraverse.transformM: Could not find all needed types when mapping over a value of type " ++ show (typeOf a) ++ ". Types of missing terms: " ++ show (Set.toList s)
| otherwise -> unsafeTransformM' f a
unsafeTransform :: (Transformation d, Data a) => d -> a -> a
unsafeTransform = unsafeTransform' . mkEndoList
unsafeTransformM :: (MonadicTransformation d m, Data a) => d -> a -> m a
unsafeTransformM = unsafeTransformM' . mkEndoListM
unsafeTransform' :: Data a => EndoList -> a -> a
unsafeTransform' f = appEndoList f . gmapT (unsafeTransform' f)
unsafeTransformM' :: (Monad m, Data a) => EndoListM m -> a -> m a
unsafeTransformM' f = appEndoListM f <=< gmapM (unsafeTransformM' f)
getSubterms :: (Data a, Data b, Monoid m) => (b -> m) -> a -> m
getSubterms p = getSubtermsWith (Just . p)
getSubterms' :: (Data a, Data b) => a -> [b]
getSubterms' = getSubtermsBy (const True)
getSubtermsBy :: (Data a, Data b) => (b -> Bool) -> a -> [b]
getSubtermsBy p = getSubtermsWith (\ x -> guard (p x) >> return [x])
getSubtermsWith :: (Data a, Data b, Monoid m) => (b -> Maybe m) -> a -> m
getSubtermsWith p = execWriter . transformM (\ x -> maybe (return ()) tell (p x) >> return x)
data WrappedData where
WrappedData :: Data a => a -> WrappedData
allContainedTypeReps :: Data a => a -> Set TypeRep
allContainedTypeReps a = execState (allContainedTypeReps' a) Set.empty
allContainedTypeReps' :: Data a => a -> State (Set TypeRep) ()
allContainedTypeReps' a = do
s <- get
unless (Set.member (typeOf a) s) $ do
modify (Set.insert (typeOf a))
mapM_ helper (constructEmpties `asTypeOf` [a])
where
helper :: Data a => a -> State (Set TypeRep) ()
helper x = do
let subterms = execWriter $ gmapM (\ y -> tell [WrappedData y] >> return y) x
mapM_ (\ (WrappedData y) -> allContainedTypeReps' y) subterms
constructEmpties :: Data a => [a]
constructEmpties = helper undefined
where
helper :: Data a => a -> [a]
helper a = case dataTypeOf a of
dt -> case dataTypeRep dt of
IntRep -> [fromConstr $ mkIntegralConstr dt (0 :: Integer)]
FloatRep -> [fromConstr $ mkRealConstr dt (0 :: Rational)]
CharRep -> [fromConstr $ mkCharConstr dt '\0']
AlgRep xs -> map (fromConstrB (xhead constructEmpties)) xs
NoRep -> []
xhead :: Data a => [a] -> a
xhead (x:_) = x
xhead l@[] = error $ "Data.DataTraverse.constructEmpties.xhead: Can not construct data type " ++ show (dataTypeOf $ head l)
getNeededTypeReps :: EndoList -> Set TypeRep
getNeededTypeReps Nil = Set.empty
getNeededTypeReps (Cons a l) = Set.insert (getTypeRep a Proxy) $ getNeededTypeReps l
where
getTypeRep :: Data a => (a -> a) -> Proxy a -> TypeRep
getTypeRep _ = typeRep
getNeededTypeRepsM :: EndoListM m -> Set TypeRep
getNeededTypeRepsM NilM = Set.empty
getNeededTypeRepsM (ConsM a l) = Set.insert (getTypeRep a Proxy) $ getNeededTypeRepsM l
where
getTypeRep :: Data a => (a -> m a) -> Proxy a -> TypeRep
getTypeRep _ = typeRep