{-| A tradgey has befallen us.
  Newtypes, something intended to be a zero-cost abstraction is having a cost.
  May the phantoms save us.
-}


{-# LANGUAGE AllowAmbiguousTypes        #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeOperators              #-}
#ifdef Typed
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
#endif


module Data.Spooky (
    Spooky
  -- * Ghostly relation
  , type (👻)(..)
  -- * Coercion
  , traumatize, terrify
  -- * Standard toolchain
  , mapSpooky, applySpooky, bindSpooky, hoistSpooky
  -- * Lift arguments
  , liftSpooky, liftSpooky2, liftSpooky3, liftSpooky4, liftSpooky5
  ) where


import           Data.Kind
#ifdef Typed
import           GHC.Generics
#endif


{-| Spooky is either a newtype over @s@, or a type alias of @s@ depending on the cabal flag -untyped.
    @a@ is always a phantom type. The haddock is somewhat misleading here, as it's compiled typed
    and therefore reflects the newtyped representation below.
-}
#ifdef Typed
newtype Spooky (s :: Type) (a :: Type) = Spooky s
  deriving newtype (Eq, Ord, Show, Read, Enum, Bounded)
  deriving stock Generic
#else
type Spooky (s :: Type) (a :: Type) = s
#endif


{-| The class of semantic types that can be converted to and from Spooky.
  Typically these methods are defined in terms of @terrify@ and @traumatize@
-}
class s 👻 a where
  {-# MINIMAL unSpooky, toSpooky #-}
  -- | Convert @s@ to @a@
  unSpooky :: Spooky s a -> a
  -- | Convert @a@ to @s@
  toSpooky :: a -> Spooky s a


-- | Scooby pulled the mask off and it was farmer @s@ the whole time.
terrify :: Spooky s a -> s
#ifdef Typed
terrify (Spooky s) = s
#else
terrify = id
#endif
{-# INLINE terrify #-}


-- | Now @s@ masquerades around like it was converted from @a@.
-- This function should be considered regrettable, and perhaps
-- only used in the definition of a 👻 instance. This function
-- breaks any guarentee that we had, that @a@ is semantic for @s@.
-- Use with care.
traumatize :: s -> Spooky s a
#ifdef Typed
traumatize = Spooky
#else
traumatize = id
#endif
{-# INLINE traumatize #-}


-- | Spooky is a Functor, but we cannot make a type class instance for it
-- because type aliases cannot be curried in Haskell
mapSpooky :: (s 👻 a, s 👻 b) => (a -> b) -> Spooky s a -> Spooky s b
mapSpooky f = toSpooky . f . unSpooky
{-# INLINE mapSpooky #-}


-- | Applicative operation for Spooky
applySpooky :: forall s a b. (s 👻 (a -> b), s 👻 a, s 👻 b) => Spooky s (a -> b) -> Spooky s a -> Spooky s b
applySpooky sf = toSpooky . (unSpooky sf :: a -> b) . unSpooky
{-# INLINE applySpooky #-}


-- | Monadic operation for Spooky
bindSpooky :: s 👻 a => Spooky s a -> (a -> Spooky s b) -> Spooky s b
bindSpooky sa f = f $ unSpooky sa
{-# INLINE bindSpooky #-}


-- | When the villian actually does change
hoistSpooky :: (s -> s') -> Spooky s a -> Spooky s' a
hoistSpooky f = traumatize . f . terrify
{-# INLINE hoistSpooky #-}


-- | Lift the argument of a function into Spooky
liftSpooky :: s 👻 a => (a -> b) -> Spooky s a -> b
liftSpooky f = f . unSpooky
{-# INLINE liftSpooky #-}


liftSpooky2
  :: (s 👻 a, s 👻 b)
  => (a -> b -> c) -> Spooky s a -> Spooky s b -> c
liftSpooky2 f a b = f (unSpooky a) (unSpooky b)
{-# INLINE liftSpooky2 #-}


liftSpooky3
  :: (s 👻 a, s 👻 b, s 👻 c)
  => (a -> b -> c -> d) -> Spooky s a -> Spooky s b -> Spooky s c -> d
liftSpooky3 f a b c = f (unSpooky a) (unSpooky b) (unSpooky c)
{-# INLINE liftSpooky3 #-}


liftSpooky4
  :: (s 👻 a, s 👻 b, s 👻 c, s 👻 d)
  => (a -> b -> c -> d -> e) -> Spooky s a -> Spooky s b -> Spooky s c -> Spooky s d -> e
liftSpooky4 f a b c d = f (unSpooky a) (unSpooky b) (unSpooky c) (unSpooky d)
{-# INLINE liftSpooky4 #-}


liftSpooky5
  :: (s 👻 a, s 👻 b, s 👻 c, s 👻 d, s 👻 e)
  => (a -> b -> c -> d -> e -> f) -> Spooky s a -> Spooky s b -> Spooky s c -> Spooky s d -> Spooky s e -> f
liftSpooky5 f a b c d e = f (unSpooky a) (unSpooky b) (unSpooky c) (unSpooky d) (unSpooky e)
{-# INLINE liftSpooky5 #-}