1{-# LANGUAGE CPP #-} 2{-# LANGUAGE GADTs #-} 3{-# LANGUAGE Rank2Types #-} 4{-# LANGUAGE FlexibleInstances #-} 5{-# LANGUAGE ScopedTypeVariables #-} 6{-# LANGUAGE UndecidableInstances #-} 7{-# LANGUAGE TypeFamilies #-} 8{-# LANGUAGE MultiParamTypeClasses #-} 9#if __GLASGOW_HASKELL__ >= 707 10{-# LANGUAGE RoleAnnotations #-} 11#endif 12----------------------------------------------------------------------------- 13-- | 14-- Module : Control.Lens.Internal.Magma 15-- Copyright : (C) 2012-2016 Edward Kmett 16-- License : BSD-style (see the file LICENSE) 17-- Maintainer : Edward Kmett <ekmett@gmail.com> 18-- Stability : experimental 19-- Portability : non-portable 20-- 21---------------------------------------------------------------------------- 22module Control.Lens.Internal.Magma 23 ( 24 -- * Magma 25 Magma(..) 26 , runMagma 27 -- * Molten 28 , Molten(..) 29 -- * Mafic 30 , Mafic(..) 31 , runMafic 32 -- * TakingWhile 33 , TakingWhile(..) 34 , runTakingWhile 35 ) where 36 37import Prelude () 38 39import Control.Comonad 40import Control.Lens.Internal.Bazaar 41import Control.Lens.Internal.Context 42import Control.Lens.Internal.Indexed 43import Control.Lens.Internal.Prelude 44import Data.Functor.Apply 45 46------------------------------------------------------------------------------ 47-- Magma 48------------------------------------------------------------------------------ 49 50-- | This provides a way to peek at the internal structure of a 51-- 'Control.Lens.Traversal.Traversal' or 'Control.Lens.Traversal.IndexedTraversal' 52data Magma i t b a where 53 MagmaAp :: Magma i (x -> y) b a -> Magma i x b a -> Magma i y b a 54 MagmaPure :: x -> Magma i x b a 55 MagmaFmap :: (x -> y) -> Magma i x b a -> Magma i y b a 56 Magma :: i -> a -> Magma i b b a 57 58#if __GLASGOW_HASKELL__ >= 707 59-- note the 3rd argument infers as phantom, but that would be unsound 60type role Magma representational nominal nominal nominal 61#endif 62 63instance Functor (Magma i t b) where 64 fmap f (MagmaAp x y) = MagmaAp (fmap f x) (fmap f y) 65 fmap _ (MagmaPure x) = MagmaPure x 66 fmap f (MagmaFmap xy x) = MagmaFmap xy (fmap f x) 67 fmap f (Magma i a) = Magma i (f a) 68 69instance Foldable (Magma i t b) where 70 foldMap f (MagmaAp x y) = foldMap f x `mappend` foldMap f y 71 foldMap _ MagmaPure{} = mempty 72 foldMap f (MagmaFmap _ x) = foldMap f x 73 foldMap f (Magma _ a) = f a 74 75instance Traversable (Magma i t b) where 76 traverse f (MagmaAp x y) = MagmaAp <$> traverse f x <*> traverse f y 77 traverse _ (MagmaPure x) = pure (MagmaPure x) 78 traverse f (MagmaFmap xy x) = MagmaFmap xy <$> traverse f x 79 traverse f (Magma i a) = Magma i <$> f a 80 81instance (Show i, Show a) => Show (Magma i t b a) where 82 showsPrec d (MagmaAp x y) = showParen (d > 4) $ 83 showsPrec 4 x . showString " <*> " . showsPrec 5 y 84 showsPrec d (MagmaPure _) = showParen (d > 10) $ 85 showString "pure .." 86 showsPrec d (MagmaFmap _ x) = showParen (d > 4) $ 87 showString ".. <$> " . showsPrec 5 x 88 showsPrec d (Magma i a) = showParen (d > 10) $ 89 showString "Magma " . showsPrec 11 i . showChar ' ' . showsPrec 11 a 90 91-- | Run a 'Magma' where all the individual leaves have been converted to the 92-- expected type 93runMagma :: Magma i t a a -> t 94runMagma (MagmaAp l r) = runMagma l (runMagma r) 95runMagma (MagmaFmap f r) = f (runMagma r) 96runMagma (MagmaPure x) = x 97runMagma (Magma _ a) = a 98 99------------------------------------------------------------------------------ 100-- Molten 101------------------------------------------------------------------------------ 102 103-- | This is a a non-reassociating initially encoded version of 'Bazaar'. 104newtype Molten i a b t = Molten { runMolten :: Magma i t b a } 105 106instance Functor (Molten i a b) where 107 fmap f (Molten xs) = Molten (MagmaFmap f xs) 108 {-# INLINE fmap #-} 109 110instance Apply (Molten i a b) where 111 (<.>) = (<*>) 112 {-# INLINE (<.>) #-} 113 114instance Applicative (Molten i a b) where 115 pure = Molten #. MagmaPure 116 {-# INLINE pure #-} 117 Molten xs <*> Molten ys = Molten (MagmaAp xs ys) 118 {-# INLINE (<*>) #-} 119 120instance Sellable (Indexed i) (Molten i) where 121 sell = Indexed (\i -> Molten #. Magma i) 122 {-# INLINE sell #-} 123 124instance Bizarre (Indexed i) (Molten i) where 125 bazaar f (Molten (MagmaAp x y)) = bazaar f (Molten x) <*> bazaar f (Molten y) 126 bazaar f (Molten (MagmaFmap g x)) = g <$> bazaar f (Molten x) 127 bazaar _ (Molten (MagmaPure x)) = pure x 128 bazaar f (Molten (Magma i a)) = indexed f i a 129 130instance IndexedFunctor (Molten i) where 131 ifmap f (Molten xs) = Molten (MagmaFmap f xs) 132 {-# INLINE ifmap #-} 133 134instance IndexedComonad (Molten i) where 135 iextract (Molten (MagmaAp x y)) = iextract (Molten x) (iextract (Molten y)) 136 iextract (Molten (MagmaFmap f y)) = f (iextract (Molten y)) 137 iextract (Molten (MagmaPure x)) = x 138 iextract (Molten (Magma _ a)) = a 139 140 iduplicate (Molten (Magma i a)) = Molten #. Magma i <$> Molten (Magma i a) 141 iduplicate (Molten (MagmaPure x)) = pure (pure x) 142 iduplicate (Molten (MagmaFmap f y)) = iextend (fmap f) (Molten y) 143 iduplicate (Molten (MagmaAp x y)) = iextend (<*>) (Molten x) <*> iduplicate (Molten y) 144 145 iextend k (Molten (Magma i a)) = (k .# Molten) . Magma i <$> Molten (Magma i a) 146 iextend k (Molten (MagmaPure x)) = pure (k (pure x)) 147 iextend k (Molten (MagmaFmap f y)) = iextend (k . fmap f) (Molten y) 148 iextend k (Molten (MagmaAp x y)) = iextend (\x' y' -> k $ x' <*> y') (Molten x) <*> iduplicate (Molten y) 149 150instance a ~ b => Comonad (Molten i a b) where 151 extract = iextract 152 {-# INLINE extract #-} 153 extend = iextend 154 {-# INLINE extend #-} 155 duplicate = iduplicate 156 {-# INLINE duplicate #-} 157 158------------------------------------------------------------------------------ 159-- Mafic 160------------------------------------------------------------------------------ 161 162-- | This is used to generate an indexed magma from an unindexed source 163-- 164-- By constructing it this way we avoid infinite reassociations in sums where possible. 165data Mafic a b t = Mafic Int (Int -> Magma Int t b a) 166 167-- | Generate a 'Magma' using from a prefix sum. 168runMafic :: Mafic a b t -> Magma Int t b a 169runMafic (Mafic _ k) = k 0 170 171instance Functor (Mafic a b) where 172 fmap f (Mafic w k) = Mafic w (MagmaFmap f . k) 173 {-# INLINE fmap #-} 174 175instance Apply (Mafic a b) where 176 Mafic wf mf <.> ~(Mafic wa ma) = Mafic (wf + wa) $ \o -> MagmaAp (mf o) (ma (o + wf)) 177 {-# INLINE (<.>) #-} 178 179instance Applicative (Mafic a b) where 180 pure a = Mafic 0 $ \_ -> MagmaPure a 181 {-# INLINE pure #-} 182 Mafic wf mf <*> ~(Mafic wa ma) = Mafic (wf + wa) $ \o -> MagmaAp (mf o) (ma (o + wf)) 183 {-# INLINE (<*>) #-} 184 185instance Sellable (->) Mafic where 186 sell a = Mafic 1 $ \ i -> Magma i a 187 {-# INLINE sell #-} 188 189instance Bizarre (Indexed Int) Mafic where 190 bazaar (pafb :: Indexed Int a (f b)) (Mafic _ k) = go (k 0) where 191 go :: Magma Int t b a -> f t 192 go (MagmaAp x y) = go x <*> go y 193 go (MagmaFmap f x) = f <$> go x 194 go (MagmaPure x) = pure x 195 go (Magma i a) = indexed pafb (i :: Int) a 196 {-# INLINE bazaar #-} 197 198instance IndexedFunctor Mafic where 199 ifmap f (Mafic w k) = Mafic w (MagmaFmap f . k) 200 {-# INLINE ifmap #-} 201 202------------------------------------------------------------------------------ 203-- TakingWhile 204------------------------------------------------------------------------------ 205 206-- | This is used to generate an indexed magma from an unindexed source 207-- 208-- By constructing it this way we avoid infinite reassociations where possible. 209-- 210-- In @'TakingWhile' p g a b t@, @g@ has a @nominal@ role to avoid exposing an illegal _|_ via 'Contravariant', 211-- while the remaining arguments are degraded to a @nominal@ role by the invariants of 'Magma' 212data TakingWhile p (g :: * -> *) a b t = TakingWhile Bool t (Bool -> Magma () t b (Corep p a)) 213#if __GLASGOW_HASKELL__ >= 707 214type role TakingWhile nominal nominal nominal nominal nominal 215#endif 216 217-- | Generate a 'Magma' with leaves only while the predicate holds from left to right. 218runTakingWhile :: TakingWhile p f a b t -> Magma () t b (Corep p a) 219runTakingWhile (TakingWhile _ _ k) = k True 220 221instance Functor (TakingWhile p f a b) where 222 fmap f (TakingWhile w t k) = let ft = f t in TakingWhile w ft $ \b -> if b then MagmaFmap f (k b) else MagmaPure ft 223 {-# INLINE fmap #-} 224 225instance Apply (TakingWhile p f a b) where 226 TakingWhile wf tf mf <.> ~(TakingWhile wa ta ma) = TakingWhile (wf && wa) (tf ta) $ \o -> 227 if o then MagmaAp (mf True) (ma wf) else MagmaPure (tf ta) 228 {-# INLINE (<.>) #-} 229 230instance Applicative (TakingWhile p f a b) where 231 pure a = TakingWhile True a $ \_ -> MagmaPure a 232 {-# INLINE pure #-} 233 TakingWhile wf tf mf <*> ~(TakingWhile wa ta ma) = TakingWhile (wf && wa) (tf ta) $ \o -> 234 if o then MagmaAp (mf True) (ma wf) else MagmaPure (tf ta) 235 {-# INLINE (<*>) #-} 236 237instance Corepresentable p => Bizarre p (TakingWhile p g) where 238 bazaar (pafb :: p a (f b)) ~(TakingWhile _ _ k) = go (k True) where 239 go :: Magma () t b (Corep p a) -> f t 240 go (MagmaAp x y) = go x <*> go y 241 go (MagmaFmap f x) = f <$> go x 242 go (MagmaPure x) = pure x 243 go (Magma _ wa) = cosieve pafb wa 244 {-# INLINE bazaar #-} 245 246-- This constraint is unused intentionally, it protects TakingWhile 247instance Contravariant f => Contravariant (TakingWhile p f a b) where 248 contramap _ = (<$) (error "contramap: TakingWhile") 249 {-# INLINE contramap #-} 250 251instance IndexedFunctor (TakingWhile p f) where 252 ifmap = fmap 253 {-# INLINE ifmap #-} 254