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