1{-# LANGUAGE CPP #-} 2{-# LANGUAGE Rank2Types #-} 3{-# LANGUAGE GADTs #-} 4{-# LANGUAGE ScopedTypeVariables #-} 5#if __GLASGOW_HASKELL__ >= 707 6{-# LANGUAGE DeriveDataTypeable #-} 7{-# LANGUAGE Safe #-} 8#else 9-- Manual Typeable instances 10{-# LANGUAGE Trustworthy #-} 11#endif 12#include "free-common.h" 13 14----------------------------------------------------------------------------- 15-- | 16-- Module : Control.Alternative.Free 17-- Copyright : (C) 2012 Edward Kmett 18-- License : BSD-style (see the file LICENSE) 19-- 20-- Maintainer : Edward Kmett <ekmett@gmail.com> 21-- Stability : provisional 22-- Portability : GADTs, Rank2Types 23-- 24-- Left distributive 'Alternative' functors for free, based on a design 25-- by Stijn van Drongelen. 26---------------------------------------------------------------------------- 27module Control.Alternative.Free 28 ( Alt(..) 29 , AltF(..) 30 , runAlt 31 , liftAlt 32 , hoistAlt 33 ) where 34 35import Control.Applicative 36import Data.Functor.Apply 37import Data.Functor.Alt ((<!>)) 38import qualified Data.Functor.Alt as Alt 39import Data.Typeable 40 41#if !(MIN_VERSION_base(4,11,0)) 42import Data.Semigroup 43#endif 44 45infixl 3 `Ap` 46 47data AltF f a where 48 Ap :: f a -> Alt f (a -> b) -> AltF f b 49 Pure :: a -> AltF f a 50#if __GLASGOW_HASKELL__ >= 707 51 deriving Typeable 52#endif 53 54newtype Alt f a = Alt { alternatives :: [AltF f a] } 55#if __GLASGOW_HASKELL__ >= 707 56 deriving Typeable 57#endif 58 59instance Functor (AltF f) where 60 fmap f (Pure a) = Pure $ f a 61 fmap f (Ap x g) = x `Ap` fmap (f .) g 62 63instance Functor (Alt f) where 64 fmap f (Alt xs) = Alt $ map (fmap f) xs 65 66instance Applicative (AltF f) where 67 pure = Pure 68 {-# INLINE pure #-} 69 (Pure f) <*> y = fmap f y -- fmap 70 y <*> (Pure a) = fmap ($ a) y -- interchange 71 (Ap a f) <*> b = a `Ap` (flip <$> f <*> (Alt [b])) 72 {-# INLINE (<*>) #-} 73 74instance Applicative (Alt f) where 75 pure a = Alt [pure a] 76 {-# INLINE pure #-} 77 78 (Alt xs) <*> ys = Alt (xs >>= alternatives . (`ap'` ys)) 79 where 80 ap' :: AltF f (a -> b) -> Alt f a -> Alt f b 81 82 Pure f `ap'` u = fmap f u 83 (u `Ap` f) `ap'` v = Alt [u `Ap` (flip <$> f) <*> v] 84 {-# INLINE (<*>) #-} 85 86liftAltF :: f a -> AltF f a 87liftAltF x = x `Ap` pure id 88{-# INLINE liftAltF #-} 89 90-- | A version of 'lift' that can be used with any @f@. 91liftAlt :: f a -> Alt f a 92liftAlt = Alt . (:[]) . liftAltF 93{-# INLINE liftAlt #-} 94 95-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Alt' f@ to @g@. 96runAlt :: forall f g a. Alternative g => (forall x. f x -> g x) -> Alt f a -> g a 97runAlt u xs0 = go xs0 where 98 99 go :: Alt f b -> g b 100 go (Alt xs) = foldr (\r a -> (go2 r) <|> a) empty xs 101 102 go2 :: AltF f b -> g b 103 go2 (Pure a) = pure a 104 go2 (Ap x f) = flip id <$> u x <*> go f 105{-# INLINABLE runAlt #-} 106 107instance Apply (Alt f) where 108 (<.>) = (<*>) 109 {-# INLINE (<.>) #-} 110 111instance Alt.Alt (Alt f) where 112 (<!>) = (<|>) 113 {-# INLINE (<!>) #-} 114 115instance Alternative (Alt f) where 116 empty = Alt [] 117 {-# INLINE empty #-} 118 Alt as <|> Alt bs = Alt (as ++ bs) 119 {-# INLINE (<|>) #-} 120 121instance Semigroup (Alt f a) where 122 (<>) = (<|>) 123 {-# INLINE (<>) #-} 124 125instance Monoid (Alt f a) where 126 mempty = empty 127 {-# INLINE mempty #-} 128 mappend = (<>) 129 {-# INLINE mappend #-} 130 mconcat as = Alt (as >>= alternatives) 131 {-# INLINE mconcat #-} 132 133hoistAltF :: (forall a. f a -> g a) -> AltF f b -> AltF g b 134hoistAltF _ (Pure a) = Pure a 135hoistAltF f (Ap x y) = Ap (f x) (hoistAlt f y) 136{-# INLINE hoistAltF #-} 137 138-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Alt f@ to @Alt g@. 139hoistAlt :: (forall a. f a -> g a) -> Alt f b -> Alt g b 140hoistAlt f (Alt as) = Alt (map (hoistAltF f) as) 141{-# INLINE hoistAlt #-} 142 143#if __GLASGOW_HASKELL__ < 707 144instance Typeable1 f => Typeable1 (Alt f) where 145 typeOf1 t = mkTyConApp altTyCon [typeOf1 (f t)] where 146 f :: Alt f a -> f a 147 f = undefined 148 149instance Typeable1 f => Typeable1 (AltF f) where 150 typeOf1 t = mkTyConApp altFTyCon [typeOf1 (f t)] where 151 f :: AltF f a -> f a 152 f = undefined 153 154altTyCon, altFTyCon :: TyCon 155#if __GLASGOW_HASKELL__ < 704 156altTyCon = mkTyCon "Control.Alternative.Free.Alt" 157altFTyCon = mkTyCon "Control.Alternative.Free.AltF" 158#else 159altTyCon = mkTyCon3 "free" "Control.Alternative.Free" "Alt" 160altFTyCon = mkTyCon3 "free" "Control.Alternative.Free" "AltF" 161#endif 162{-# NOINLINE altTyCon #-} 163{-# NOINLINE altFTyCon #-} 164#endif 165