module Data.Pointed where

import Control.Arrow
import Control.Applicative
import Control.Concurrent.STM
import Data.Default
import Data.Monoid as Monoid
import Data.Semigroup as Semigroup
import Data.Functor.Identity
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Tree (Tree(..))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Functor.Constant
import qualified Data.Functor.Product as Functor
import Data.Functor.Compose
import Control.Monad.Trans.Cont
import Control.Monad.Trans.Error
import Control.Monad.Trans.List
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Identity
import Data.List.NonEmpty
import qualified Control.Monad.Trans.RWS.Lazy as Lazy
import qualified Control.Monad.Trans.RWS.Strict as Strict
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import qualified Control.Monad.Trans.Writer.Strict as Strict
import qualified Control.Monad.Trans.State.Lazy as Lazy
import qualified Control.Monad.Trans.State.Strict as Strict
import Data.Semigroupoid.Static

class Pointed p where
  point :: a -> p a

instance Pointed [] where
  point a = [a]

instance Pointed Maybe where
  point = Just

instance Pointed (Either a) where
  point = Right
  
instance Pointed IO where
  point = return

instance Pointed STM where
  point = return

instance Pointed Tree where
  point a = Node a []

instance Pointed NonEmpty where
  point a = a :| [] 

instance Pointed ZipList where
  point = pure

instance Pointed Identity where
  point = Identity

instance Pointed ((->)e) where
  point = const

instance Default e => Pointed ((,)e) where
  point = (,) def

instance Monad m => Pointed (WrappedMonad m) where
  point = WrapMonad . return 

instance Default m => Pointed (Const m) where
  point _ = Const def

instance Arrow a => Pointed (WrappedArrow a b) where
  point = pure

instance Pointed Dual where
  point = Dual

instance Pointed Endo where
  point = Endo . const

instance Pointed Sum where
  point = Sum

instance Pointed Monoid.Product where
  point = Monoid.Product

instance Pointed Monoid.First where
  point = Monoid.First . Just

instance Pointed Monoid.Last where
  point = Monoid.Last . Just

instance Pointed Semigroup.First where
  point = Semigroup.First

instance Pointed Semigroup.Last where
  point = Semigroup.Last

instance Pointed Semigroup.Max where
  point = Semigroup.Max

instance Pointed Semigroup.Min where
  point = Semigroup.Min

instance Pointed Seq where
  point = Seq.singleton

instance Pointed Set where
  point = Set.singleton

instance (Pointed p, Pointed q) => Pointed (Compose p q) where
  point = Compose . point . point

instance (Pointed p, Pointed q) => Pointed (Functor.Product p q) where
  point a = Functor.Pair (point a) (point a)

instance Default m => Pointed (Constant m) where 
  point _ = Constant def

instance Pointed (ContT r m) where
  point a = ContT ($ a)

instance Pointed m => Pointed (ErrorT e m) where
  point = ErrorT . point . Right

instance Pointed m => Pointed (IdentityT m) where
  point = IdentityT . point

instance Pointed m => Pointed (ListT m) where
  point = ListT . point . point

instance Pointed m => Pointed (MaybeT m) where
  point = MaybeT . point . point

instance (Default w, Pointed m) => Pointed (Lazy.RWST r w s m) where
  point a = Lazy.RWST $ \_ s -> point (a, s, def)

instance (Default w, Pointed m) => Pointed (Strict.RWST r w s m) where
  point a = Strict.RWST $ \_ s -> point (a, s, def)

instance (Default w, Pointed m) => Pointed (Lazy.WriterT w m) where
  point a = Lazy.WriterT $ point (a, def)

instance (Default w, Pointed m) => Pointed (Strict.WriterT w m) where
  point a = Strict.WriterT $ point (a, def)

instance Pointed m => Pointed (Lazy.StateT s m) where
  point a = Lazy.StateT $ \s -> point (a, s) 

instance Pointed m => Pointed (Strict.StateT s m) where
  point a = Strict.StateT $ \s -> point (a, s)

instance Pointed m => Pointed (Static m a) where
  point = Static . point . const