SHARE
TWEET

Zipping and aligning Traversals

Zemyla Dec 12th, 2019 162 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. {-# LANGUAGE ScopedTypeVariables, RankNTypes #-}
  2.  
  3. module ZipTraversal (
  4.     FunList(..),
  5.     runFunList,
  6.     FunApp(..),
  7.     sell,
  8.     runFunApp,
  9.     zipTraversal,
  10.     alignTraversal,
  11.     zipAlignTraversal
  12.   ) where
  13.  
  14. import Control.Lens
  15. import Control.Applicative (Applicative(..))
  16. import Data.Foldable (Foldable(..))
  17. import Data.These
  18. import Data.Profunctor
  19. import Data.Profunctor.Strong (Costrong(..))
  20. import Data.Profunctor.Choice (Cochoice(..))
  21.  
  22. data FunList t b a
  23.   = Done t
  24.   | More a (FunList (b -> t) b a)
  25.  
  26. fmapFL :: forall a a' b t. (a -> a') -> FunList t b a -> FunList t b a'
  27. fmapFL f = go where
  28.  go :: forall u c. FunList u c a -> FunList u c a'
  29.   go (Done t) = Done t
  30.   go (More a fl') = More (f a) (go fl')
  31.   {-# INLINE go #-}
  32. {-# INLINE fmapFL #-}
  33.  
  34. cmapFL :: forall a a' b t. a' -> FunList t b a -> FunList t b a'
  35. cmapFL a = go where
  36.  go :: forall u c. FunList u c a -> FunList u c a'
  37.   go (Done t) = Done t
  38.   go (More _ fl') = More a (go fl')
  39.   {-# INLINE go #-}
  40. {-# INLINE cmapFL #-}
  41.  
  42. foldrFL :: forall a b t r. (a -> r -> r) -> r -> FunList t b a -> r
  43. foldrFL f z = go where
  44.   go :: forall u c. FunList u c a -> r
  45.   go (Done _) = z
  46.   go (More a fl') = f a (go fl')
  47.   {-# INLINE go #-}
  48. {-# INLINE foldrFL #-}
  49.  
  50. foldlFL' :: forall a b t r. (r -> a -> r) -> r -> FunList t b a -> r
  51. foldlFL' f = go where
  52.   go :: forall u c. r -> FunList u c a -> r
  53.   go z _ | z `seq` False = undefined
  54.   go z (Done _) = z
  55.   go z (More a fl') = go (f z a) fl'
  56.   {-# INLINE go #-}
  57. {-# INLINE foldlFL' #-}
  58.  
  59. lengthWithFL :: Int -> FunList t b a -> Int
  60. lengthWithFL n _ | n `seq` False = undefined
  61. lengthWithFL n (Done _) = n
  62. lengthWithFL n (More _ fl') = lengthWithFL (n + 1) fl'
  63. {-# INLINE lengthWithFL #-}
  64.  
  65. traverseFL :: forall f a a' b t. Applicative f => (a -> f a') -> FunList t b a -> f (FunList t b a')
  66. traverseFL f = go where
  67.  go :: forall u c. FunList u c a -> f (FunList u c a')
  68.   go (Done t) = pure (Done t)
  69.   go (More a fl') = liftA2 More (f a) (go fl')
  70.   {-# INLINE go #-}
  71. {-# INLINE traverseFL #-}
  72.  
  73. btmapFL :: forall a b b' t t'. (b' -> b) -> (t -> t') -> FunList t b a -> FunList t' b' a
  74. btmapFL fb = go where
  75.   go :: forall u u' c. (u -> u') -> FunList u b c -> FunList u' b' c
  76.   go ft (Done t) = Done (ft t)
  77.   go ft (More a fl') = More a (go (\bt b -> ft (bt (fb b))) fl')
  78.   {-# INLINE go #-}
  79. {-# INLINE btmapFL #-}
  80.  
  81. abtmapFL :: forall a a' b b' t t'. (b' -> b) -> (a -> a') -> (t -> t') -> FunList t b a -> FunList t' b' a'
  82. abtmapFL fb fa = go where
  83.  go :: forall u u'. (u -> u') -> FunList u b a -> FunList u' b' a'
  84.   go ft (Done t) = Done (ft t)
  85.   go ft (More a fl') = More (fa a) (go (\bt b -> ft (bt (fb b))) fl')
  86.   {-# INLINE go #-}
  87. {-# INLINE abtmapFL #-}
  88.  
  89. unfirstFL :: (t -> t') -> FunList t (b, c) (a, c) -> FunList t' b a
  90. unfirstFL ft (Done t) = Done (ft t)
  91. unfirstFL ft (More (a, c) fl') = More a (unfirstFL (\bt b -> ft (bt (b, c))) fl')
  92. {-# INLINE unfirstFL #-}
  93.  
  94. unsecondFL :: (t -> t') -> FunList t (c, b) (c, a) -> FunList t' b a
  95. unsecondFL ft (Done t) = Done (ft t)
  96. unsecondFL ft (More (c, a) fl') = More a (unsecondFL (\bt b -> ft (bt (c, b))) fl')
  97. {-# INLINE unsecondFL #-}
  98.  
  99. unleftFL :: (t -> t') -> FunList t (Either b c) (Either a c) -> FunList t' b a
  100. unleftFL ft (Done t) = Done (ft t)
  101. unleftFL ft (More ac fl') = case ac of
  102.  Left a  -> More a (unleftFL (\bt b -> ft (bt (Left b))) fl')
  103.   Right c -> unleftFL (\bt -> ft (bt (Right c))) fl'
  104. {-# INLINE unleftFL #-}
  105.  
  106. unrightFL :: (t -> t') -> FunList t (Either c b) (Either c a) -> FunList t' b a
  107. unrightFL ft (Done t) = Done (ft t)
  108. unrightFL ft (More ca fl') = case ca of
  109.   Left c  -> unrightFL (\bt -> ft (bt (Left c))) fl'
  110.  Right a -> More a (unrightFL (\bt b -> ft (bt (Right b))) fl')
  111. {-# INLINE unrightFL #-}
  112.  
  113. instance Functor (FunList t b) where
  114.   fmap = fmapFL
  115.   {-# INLINE fmap #-}
  116.  
  117.   (<$) = cmapFL
  118.   {-# INLINE (<$) #-}
  119.  
  120. instance Foldable (FunList t b) where
  121.   foldr = foldrFL
  122.   {-# INLINE foldr #-}
  123.  
  124.   foldl' = foldlFL'
  125.   {-# INLINE foldl' #-}
  126.  
  127.   null (Done t) = True
  128.   null (More {}) = False
  129.   {-# INLINE null #-}
  130.  
  131.   length = lengthWithFL 0
  132.   {-# INLINE length #-}
  133.  
  134. instance Traversable (FunList t b) where
  135.   traverse = traverseFL
  136.   {-# INLINE traverse #-}
  137.  
  138. instance Profunctor (FunList t) where
  139.   lmap f = \fl -> case fl of
  140.     Done t -> Done t
  141.     More a fl' -> More a (btmapFL f (. f) fl')
  142.   {-# INLINE lmap #-}
  143.  
  144.   rmap = fmapFL
  145.   {-# INLINE rmap #-}
  146.  
  147.   dimap f g = \fl -> case fl of
  148.     Done t -> Done t
  149.     More a fl' -> More (g a) (abtmapFL f g (. f) fl')
  150.   {-# INLINE dimap #-}
  151.  
  152. instance Costrong (FunList t) where
  153.   unfirst (Done t) = Done t
  154.   unfirst (More (a, c) fl') = More a (unfirstFL (\bt b -> bt (b, c)) fl')
  155.   {-# INLINE unfirst #-}
  156.  
  157.   unsecond (Done t) = Done t
  158.   unsecond (More (c, a) fl') = More a (unsecondFL (\bt b -> bt (c, b)) fl')
  159.   {-# INLINE unsecond #-}
  160.  
  161. instance Cochoice (FunList t) where
  162.   unleft (Done t) = Done t
  163.   unleft (More ac fl') = case ac of
  164.    Left a  -> More a (unleftFL (\bt b -> bt (Left b)) fl')
  165.     Right c -> unleftFL (\bt -> bt (Right c)) fl'
  166.  {-# INLINE unleft #-}
  167.  
  168.  unright (Done t) = Done t
  169.  unright (More ca fl') = case ca of
  170.     Left c  -> unrightFL (\bt -> bt (Left c)) fl'
  171.    Right a -> More a (unrightFL (\bt b -> bt (Right b)) fl')
  172.   {-# INLINE unright #-}
  173.  
  174. runFunList :: forall f a b t. Applicative f => (a -> f b) -> FunList t b a -> f t
  175. runFunList f = go where
  176.   go :: forall u. FunList u b a -> f u
  177.   go (Done t) = pure t
  178.   go (More a fl') = liftA2 (flip id) (f a) (go fl')
  179.   {-# INLINE go #-}
  180. {-# INLINE runFunList #-}
  181.  
  182. newtype FunApp a b t = FunApp { unFunApp :: forall r. (forall x. ((t -> r) -> x) -> FunList x b a) -> FunList r b a }
  183.  
  184. instance Functor (FunApp a b) where
  185.   fmap f (FunApp m) = FunApp $ \y -> m $ \c -> y $ \x -> c $ x . f
  186.   {-# INLINE fmap #-}
  187.  
  188.   a <$ FunApp m = FunApp $ \y -> m $ \c -> y $ \x -> c $ const $ x a
  189.   {-# INLINE (<$) #-}
  190.  
  191. instance Applicative (FunApp a b) where
  192.   pure t = FunApp $ \y -> y ($ t)
  193.   {-# INLINE pure #-}
  194.  
  195.   liftA2 f (FunApp ma) (FunApp mb) = FunApp $ \y -> ma $ \t -> mb $ \u -> y $ \c -> u $ \b -> t $ \a -> c (f a b)
  196.   {-# INLINE liftA2 #-}
  197.  
  198.   FunApp mf <*> FunApp ma = FunApp $ \y -> mf $ \t -> ma $ \u -> y $ \c -> u $ \a -> t $ \f -> c (f a)
  199.   {-# INLINE (<*>) #-}
  200.  
  201.   FunApp ma  *> FunApp mb = FunApp $ \y -> ma $ \t -> mb $ \u -> y $ \c -> u $ \b -> t $ const (c b)
  202.   {-# INLINE ( *>) #-}
  203.  
  204.   FunApp ma <*  FunApp mb = FunApp $ \y -> ma $ \t -> mb $ \u -> y $ \c -> u $ const (t c)
  205.   {-# INLINE (<* ) #-}
  206.  
  207. sell :: a -> FunApp a b b
  208. sell a = FunApp $ \y -> More a (y id)
  209. {-# INLINE sell #-}
  210.  
  211. runFunApp :: FunApp a b t -> FunList t b a
  212. runFunApp (FunApp m) = m (\x -> Done (x id))
  213. {-# INLINE runFunApp #-}
  214.  
  215. zipFunList :: forall f a b c t. Applicative f => ((a, b) -> f c) -> FunList t c a -> FunList t c b -> f t
  216. zipFunList f = go where
  217.   go :: forall u. FunList u c a -> FunList u c b -> f u
  218.   go (Done ta) _ = pure ta
  219.   go _ (Done tb) = pure tb
  220.   go (More a fa') (More b fb') = liftA2 (flip id) (f (a, b)) (go fa' fb')
  221.   {-# INLINE go #-}
  222. {-# INLINE zipFunList #-}
  223.  
  224. zipTraversal :: LensLike (FunApp a c) sa t a c -> LensLike (FunApp b c) sb t b c -> Traversal (sa, sb) t (a, b) c
  225. zipTraversal ta tb = go where
  226.   go f = \ (sa, sb) -> zipFunList f (runFunApp $ ta sell sa) (runFunApp $ tb sell sb)
  227.   {-# INLINE go #-}
  228. {-# INLINE zipTraversal #-}
  229.  
  230. alignFunList :: forall f a b c t. Applicative f => (These a b -> f c) -> FunList t c a -> FunList t c b -> f t
  231. alignFunList f = go where
  232.   go :: forall u. FunList u c a -> FunList u c b -> f u
  233.   go fa (Done _) = runFunList (f . This) fa
  234.   go (Done _) fb = runFunList (f . That) fb
  235.   go (More a fa') (More b fb') = liftA2 (flip id) (f (These a b)) (go fa' fb')
  236.   {-# INLINE go #-}
  237. {-# INLINE alignFunList #-}
  238.  
  239. alignTraversal :: LensLike (FunApp a c) sa t a c -> LensLike (FunApp b c) sb t b c -> Traversal (sa, sb) t (These a b) c
  240. alignTraversal ta tb = go where
  241.   go f = \ (sa, sb) -> alignFunList f (runFunApp $ ta sell sa) (runFunApp $ tb sell sb)
  242.   {-# INLINE go #-}
  243. {-# INLINE alignTraversal #-}
  244.  
  245. zipAlignFunList :: forall f a b c ta tb. Applicative f => (These a b -> f c) -> FunList ta c a -> FunList tb c b -> f (Ordering, ta, tb)
  246. zipAlignFunList f = go where
  247.   go :: forall ua ub. FunList ua c a -> FunList ub c b -> f (Ordering, ua, ub)
  248.   go (Done ta) (Done tb) = pure (EQ, ta, tb)
  249.   go (Done ta) fb = fmap ((,,) LT ta) (runFunList (f . That) fb)
  250.   go fa (Done tb) = fmap (\ta -> (GT, ta, tb)) (runFunList (f . This) fa)
  251.   go (More a fa') (More b fb') = liftA2 (\c ~(o, ta, tb) -> (o, ta c, tb c)) (f (These a b)) (go fa' fb')
  252.   {-# INLINE go #-}
  253. {-# INLINE zipAlignFunList #-}
  254.  
  255. zipAlignTraversal :: LensLike (FunApp a c) sa ta a c -> LensLike (FunApp b c) sb tb b c -> Traversal (sa, sb) (Ordering, ta, tb) (These a b) c
  256. zipAlignTraversal ta tb = go where
  257.   go f = \ (sa, sb) -> zipAlignFunList f (runFunApp $ ta sell sa) (runFunApp $ tb sell sb)
  258.   {-# INLINE go #-}
  259. {-# INLINE zipAlignTraversal #-}
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Top