{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

#if __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE DeriveGeneric #-}
#endif

#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 702
{-# LANGUAGE Trustworthy #-}
#endif

#if __GLASGOW_HASKELL__ >= 706
{-# LANGUAGE PolyKinds #-}
#endif
#include "bifunctors-common.h"

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Bifunctor.Fix
-- Copyright   :  (C) 2008-2016 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  non-portable
--
-----------------------------------------------------------------------------
module Data.Bifunctor.Fix
  ( Fix(..)
  ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif

import Data.Biapplicative
import Data.Bifoldable
import Data.Bitraversable

#if __GLASGOW_HASKELL__ < 710
import Data.Foldable
import Data.Traversable
#endif

#if __GLASGOW_HASKELL__ >= 708
import Data.Typeable
#endif

#if __GLASGOW_HASKELL__ >= 702
import GHC.Generics
#endif

#if LIFTED_FUNCTOR_CLASSES
import Data.Functor.Classes
#endif

-- | Greatest fixpoint of a 'Bifunctor' (a 'Functor' over the first argument with zipping).
newtype Fix p a = In { Fix p a -> p (Fix p a) a
out :: p (Fix p a) a }
  deriving
    (
#if __GLASGOW_HASKELL__ >= 702
      (forall x. Fix p a -> Rep (Fix p a) x)
-> (forall x. Rep (Fix p a) x -> Fix p a) -> Generic (Fix p a)
forall x. Rep (Fix p a) x -> Fix p a
forall x. Fix p a -> Rep (Fix p a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (p :: * -> k -> *) (a :: k) x. Rep (Fix p a) x -> Fix p a
forall k (p :: * -> k -> *) (a :: k) x. Fix p a -> Rep (Fix p a) x
$cto :: forall k (p :: * -> k -> *) (a :: k) x. Rep (Fix p a) x -> Fix p a
$cfrom :: forall k (p :: * -> k -> *) (a :: k) x. Fix p a -> Rep (Fix p a) x
Generic
#endif
#if __GLASGOW_HASKELL__ >= 708
    , Typeable
#endif
    )

deriving instance Eq   (p (Fix p a) a) => Eq   (Fix p a)
deriving instance Ord  (p (Fix p a) a) => Ord  (Fix p a)
deriving instance Show (p (Fix p a) a) => Show (Fix p a)
deriving instance Read (p (Fix p a) a) => Read (Fix p a)

#if LIFTED_FUNCTOR_CLASSES
instance Eq2 p => Eq1 (Fix p) where
  liftEq :: (a -> b -> Bool) -> Fix p a -> Fix p b -> Bool
liftEq a -> b -> Bool
f (In p (Fix p a) a
x) (In p (Fix p b) b
y) = (Fix p a -> Fix p b -> Bool)
-> (a -> b -> Bool) -> p (Fix p a) a -> p (Fix p b) b -> Bool
forall (f :: * -> * -> *) a b c d.
Eq2 f =>
(a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
liftEq2 ((a -> b -> Bool) -> Fix p a -> Fix p b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
f) a -> b -> Bool
f p (Fix p a) a
x p (Fix p b) b
y

instance Ord2 p => Ord1 (Fix p) where
  liftCompare :: (a -> b -> Ordering) -> Fix p a -> Fix p b -> Ordering
liftCompare a -> b -> Ordering
f (In p (Fix p a) a
x) (In p (Fix p b) b
y) = (Fix p a -> Fix p b -> Ordering)
-> (a -> b -> Ordering)
-> p (Fix p a) a
-> p (Fix p b) b
-> Ordering
forall (f :: * -> * -> *) a b c d.
Ord2 f =>
(a -> b -> Ordering)
-> (c -> d -> Ordering) -> f a c -> f b d -> Ordering
liftCompare2 ((a -> b -> Ordering) -> Fix p a -> Fix p b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
f) a -> b -> Ordering
f p (Fix p a) a
x p (Fix p b) b
y

instance Read2 p => Read1 (Fix p) where
  liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Fix p a)
liftReadsPrec Int -> ReadS a
rp1 ReadS [a]
rl1 Int
p = Bool -> ReadS (Fix p a) -> ReadS (Fix p a)
forall a. Bool -> ReadS a -> ReadS a
readParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ReadS (Fix p a) -> ReadS (Fix p a))
-> ReadS (Fix p a) -> ReadS (Fix p a)
forall a b. (a -> b) -> a -> b
$ \String
s0 -> do
    (String
"In",  String
s1) <- ReadS String
lex String
s0
    (String
"{",   String
s2) <- ReadS String
lex String
s1
    (String
"out", String
s3) <- ReadS String
lex String
s2
    (p (Fix p a) a
x,     String
s4) <- (Int -> ReadS (Fix p a))
-> ReadS [Fix p a]
-> (Int -> ReadS a)
-> ReadS [a]
-> Int
-> ReadS (p (Fix p a) a)
forall (f :: * -> * -> *) a b.
Read2 f =>
(Int -> ReadS a)
-> ReadS [a]
-> (Int -> ReadS b)
-> ReadS [b]
-> Int
-> ReadS (f a b)
liftReadsPrec2 ((Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Fix p a)
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec Int -> ReadS a
rp1 ReadS [a]
rl1) ((Int -> ReadS a) -> ReadS [a] -> ReadS [Fix p a]
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadList Int -> ReadS a
rp1 ReadS [a]
rl1)
                                  Int -> ReadS a
rp1 ReadS [a]
rl1 Int
0 String
s3
    (String
"}",   String
s5) <- ReadS String
lex String
s4
    (Fix p a, String) -> [(Fix p a, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return (p (Fix p a) a -> Fix p a
forall k (p :: * -> k -> *) (a :: k). p (Fix p a) a -> Fix p a
In p (Fix p a) a
x, String
s5)

instance Show2 p => Show1 (Fix p) where
  liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Fix p a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp1 [a] -> ShowS
sl1 Int
p (In p (Fix p a) a
x) = Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"In {out = "
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Fix p a -> ShowS)
-> ([Fix p a] -> ShowS)
-> (Int -> a -> ShowS)
-> ([a] -> ShowS)
-> Int
-> p (Fix p a) a
-> ShowS
forall (f :: * -> * -> *) a b.
Show2 f =>
(Int -> a -> ShowS)
-> ([a] -> ShowS)
-> (Int -> b -> ShowS)
-> ([b] -> ShowS)
-> Int
-> f a b
-> ShowS
liftShowsPrec2 ((Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Fix p a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp1 [a] -> ShowS
sl1) ((Int -> a -> ShowS) -> ([a] -> ShowS) -> [Fix p a] -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> [f a] -> ShowS
liftShowList Int -> a -> ShowS
sp1 [a] -> ShowS
sl1)
                     Int -> a -> ShowS
sp1 [a] -> ShowS
sl1 Int
0 p (Fix p a) a
x
    ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'
#endif

instance Bifunctor p => Functor (Fix p) where
  fmap :: (a -> b) -> Fix p a -> Fix p b
fmap a -> b
f (In p (Fix p a) a
p) = p (Fix p b) b -> Fix p b
forall k (p :: * -> k -> *) (a :: k). p (Fix p a) a -> Fix p a
In ((Fix p a -> Fix p b) -> (a -> b) -> p (Fix p a) a -> p (Fix p b) b
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ((a -> b) -> Fix p a -> Fix p b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) a -> b
f p (Fix p a) a
p)
  {-# INLINE fmap #-}

instance Biapplicative p => Applicative (Fix p) where
  pure :: a -> Fix p a
pure a
a = p (Fix p a) a -> Fix p a
forall k (p :: * -> k -> *) (a :: k). p (Fix p a) a -> Fix p a
In (Fix p a -> a -> p (Fix p a) a
forall (p :: * -> * -> *) a b. Biapplicative p => a -> b -> p a b
bipure (a -> Fix p a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) a
a)
  {-# INLINE pure #-}
  In p (Fix p (a -> b)) (a -> b)
p <*> :: Fix p (a -> b) -> Fix p a -> Fix p b
<*> In p (Fix p a) a
q = p (Fix p b) b -> Fix p b
forall k (p :: * -> k -> *) (a :: k). p (Fix p a) a -> Fix p a
In ((Fix p (a -> b) -> Fix p a -> Fix p b)
-> ((a -> b) -> a -> b)
-> p (Fix p (a -> b)) (a -> b)
-> p (Fix p a) a
-> p (Fix p b) b
forall (p :: * -> * -> *) a b c d e f.
Biapplicative p =>
(a -> b -> c) -> (d -> e -> f) -> p a d -> p b e -> p c f
biliftA2 Fix p (a -> b) -> Fix p a -> Fix p b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($) p (Fix p (a -> b)) (a -> b)
p p (Fix p a) a
q)
  {-# INLINE (<*>) #-}

instance Bifoldable p => Foldable (Fix p) where
  foldMap :: (a -> m) -> Fix p a -> m
foldMap a -> m
f (In p (Fix p a) a
p) = (Fix p a -> m) -> (a -> m) -> p (Fix p a) a -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap ((a -> m) -> Fix p a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) a -> m
f p (Fix p a) a
p
  {-# INLINE foldMap #-}

instance Bitraversable p => Traversable (Fix p) where
  traverse :: (a -> f b) -> Fix p a -> f (Fix p b)
traverse a -> f b
f (In p (Fix p a) a
p) = p (Fix p b) b -> Fix p b
forall k (p :: * -> k -> *) (a :: k). p (Fix p a) a -> Fix p a
In (p (Fix p b) b -> Fix p b) -> f (p (Fix p b) b) -> f (Fix p b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Fix p a -> f (Fix p b))
-> (a -> f b) -> p (Fix p a) a -> f (p (Fix p b) b)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse ((a -> f b) -> Fix p a -> f (Fix p b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) a -> f b
f p (Fix p a) a
p
  {-# INLINE traverse #-}