{-# LANGUAGE AllowAmbiguousTypes  #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE IncoherentInstances  #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-}

{- |
  This code is taken from https://stackoverflow.com/questions/28003135/is-it-possible-to-encode-a-generic-lift-function-in-haskell

  to allow a generic lift operation over an 'Applicative' context
  So if you have a function: @Int -> Text -> IO Int@, it can be lifted to have all of its parameters
    in 'IO':

  >  f :: Int -> Text -> IO Int
  >
  >  lifted :: IO Int -> IO Text -> IO Int
  >  lifted = to @IO f

-}
module Data.Registry.Lift where

import           Protolude hiding (Nat)

-- | Typeclass for lifting pure functions to effectful arguments and results
class Applicative f => ApplyVariadic f a b where
  applyVariadic :: f a -> b

instance (Applicative f, b ~ f a) => ApplyVariadic f a b where
  applyVariadic :: f a -> b
applyVariadic = f a -> b
forall a. a -> a
identity

instance (Monad f, b ~ f a) => ApplyVariadic f (f a) b where
  applyVariadic :: f (f a) -> b
applyVariadic = f (f a) -> b
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join

instance (Applicative f, ApplyVariadic f a' b', b ~ (f a -> b')) => ApplyVariadic f (a -> a') b where
  applyVariadic :: f (a -> a') -> b
applyVariadic f (a -> a')
f f a
fa = f a' -> b'
forall (f :: * -> *) a b. ApplyVariadic f a b => f a -> b
applyVariadic (f (a -> a')
f f (a -> a') -> f a -> f a'
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
fa)

-- | Lift a pure function to effectful arguments and results
allTo :: forall f a b. ApplyVariadic f a b => a -> b
allTo :: a -> b
allTo a
a = (f a -> b
forall (f :: * -> *) a b. ApplyVariadic f a b => f a -> b
applyVariadic :: f a -> b) (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)

-- | Typeclass for lifting impure functions to effectful arguments and results
class Monad f => ApplyVariadic1 f a b where
  applyVariadic1 :: f a -> b

instance (Monad f, b ~ f a) => ApplyVariadic1 f (f a) b where
  applyVariadic1 :: f (f a) -> b
applyVariadic1 = f (f a) -> b
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join

instance (Monad f, ApplyVariadic1 f a' b', b ~ (f a -> b')) => ApplyVariadic1 f (a -> a') b where
  applyVariadic1 :: f (a -> a') -> b
applyVariadic1 f (a -> a')
f f a
fa = f a' -> b'
forall (f :: * -> *) a b. ApplyVariadic1 f a b => f a -> b
applyVariadic1 (f (a -> a')
f f (a -> a') -> f a -> f a'
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
fa)

-- | Lift an effectful function to effectful arguments and results
argsTo :: forall f a b . ApplyVariadic1 f a b => a -> b
argsTo :: a -> b
argsTo a
a = (f a -> b
forall (f :: * -> *) a b. ApplyVariadic1 f a b => f a -> b
applyVariadic1 :: f a -> b) (a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a)

-- | Typeclass for lifting a function with a result of type m b into a function
--   with a result of type n b
class ApplyVariadic2 f g a b where
  applyVariadic2 :: (forall x . f x -> g x) -> a -> b

instance (b ~ g a) => ApplyVariadic2 f g (f a) b where
  applyVariadic2 :: (forall x. f x -> g x) -> f a -> b
applyVariadic2 forall x. f x -> g x
natfg = f a -> b
forall x. f x -> g x
natfg

instance (ApplyVariadic2 f g a' b', b ~ (a -> b')) => ApplyVariadic2 f g (a -> a') b where
  applyVariadic2 :: (forall x. f x -> g x) -> (a -> a') -> b
applyVariadic2 forall x. f x -> g x
natfg a -> a'
f a
a = (forall x. f x -> g x) -> a' -> b'
forall (f :: * -> *) (g :: * -> *) a b.
ApplyVariadic2 f g a b =>
(forall x. f x -> g x) -> a -> b
applyVariadic2 forall x. f x -> g x
natfg (a -> a'
f a
a)

-- | Lift a function returning an effectful result to a function returning another effectful result
outTo :: forall g f a b . ApplyVariadic2 f g a b => (forall x . f x -> g x) -> a -> b
outTo :: (forall x. f x -> g x) -> a -> b
outTo forall x. f x -> g x
natfg = (forall x. f x -> g x) -> a -> b
forall (f :: * -> *) (g :: * -> *) a b.
ApplyVariadic2 f g a b =>
(forall x. f x -> g x) -> a -> b
applyVariadic2 forall x. f x -> g x
natfg :: a -> b

-- *  Tagging

-- | The output of some constructors can be "tagged" with a string to indicate how a given
--   value was built.
newtype Tag (s :: Symbol) a = Tag { Tag s a -> a
unTag :: a } deriving (Tag s a -> Tag s a -> Bool
(Tag s a -> Tag s a -> Bool)
-> (Tag s a -> Tag s a -> Bool) -> Eq (Tag s a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (s :: Symbol) a. Eq a => Tag s a -> Tag s a -> Bool
/= :: Tag s a -> Tag s a -> Bool
$c/= :: forall (s :: Symbol) a. Eq a => Tag s a -> Tag s a -> Bool
== :: Tag s a -> Tag s a -> Bool
$c== :: forall (s :: Symbol) a. Eq a => Tag s a -> Tag s a -> Bool
Eq, Int -> Tag s a -> ShowS
[Tag s a] -> ShowS
Tag s a -> String
(Int -> Tag s a -> ShowS)
-> (Tag s a -> String) -> ([Tag s a] -> ShowS) -> Show (Tag s a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Symbol) a. Show a => Int -> Tag s a -> ShowS
forall (s :: Symbol) a. Show a => [Tag s a] -> ShowS
forall (s :: Symbol) a. Show a => Tag s a -> String
showList :: [Tag s a] -> ShowS
$cshowList :: forall (s :: Symbol) a. Show a => [Tag s a] -> ShowS
show :: Tag s a -> String
$cshow :: forall (s :: Symbol) a. Show a => Tag s a -> String
showsPrec :: Int -> Tag s a -> ShowS
$cshowsPrec :: forall (s :: Symbol) a. Show a => Int -> Tag s a -> ShowS
Show)

instance Functor (Tag s) where
  fmap :: (a -> b) -> Tag s a -> Tag s b
fmap a -> b
f (Tag a
a) = b -> Tag s b
forall (s :: Symbol) a. a -> Tag s a
Tag @s (a -> b
f a
a)

instance Applicative (Tag s) where
  pure :: a -> Tag s a
pure = a -> Tag s a
forall (s :: Symbol) a. a -> Tag s a
Tag
  Tag a -> b
f <*> :: Tag s (a -> b) -> Tag s a -> Tag s b
<*> Tag a
a = b -> Tag s b
forall (s :: Symbol) a. a -> Tag s a
Tag @s (a -> b
f a
a)

-- | Tag a given constructor f with a string s. The 'applyLast' function only applies the tag to the output
--   type of the constructor. For example
--   data Salary = Fixed Int | Variable Int Double
--   tag @"Variable" Variable :: Int -> Double -> Tag "Variable" Salary
tag :: forall (s :: Symbol) fun . (CNumArgs (CountArgs fun) fun) => fun -> Apply (Tag s) (CountArgs fun) fun
tag :: fun -> Apply (Tag s) (CountArgs fun) fun
tag = forall fun.
(Applicative (Tag s), CNumArgs (CountArgs fun) fun) =>
fun -> Apply (Tag s) (CountArgs fun) fun
forall (f :: * -> *) fun.
(Applicative f, CNumArgs (CountArgs fun) fun) =>
fun -> Apply f (CountArgs fun) fun
applyLast @(Tag s)

-- | ApplyLast typeclass provided by @neongreen
--   It uses an auxiliary typeclass to count the arguments of a function
data Nat = Z | S Nat

data NumArgs :: Nat -> Type -> Type where
  NAZ :: NumArgs Z a
  NAS :: NumArgs n b -> NumArgs (S n) (a -> b)

type family CountArgs (f :: Type) :: Nat where
  CountArgs (a -> b) = S (CountArgs b)
  CountArgs result = Z

class CNumArgs (numArgs :: Nat) (arrows :: Type) where
  getNA :: NumArgs numArgs arrows

instance CNumArgs Z a where
  getNA :: NumArgs 'Z a
getNA = NumArgs 'Z a
forall a. NumArgs 'Z a
NAZ

instance CNumArgs n b => CNumArgs (S n) (a -> b) where
  getNA :: NumArgs ('S n) (a -> b)
getNA = NumArgs n b -> NumArgs ('S n) (a -> b)
forall (n :: Nat) b a. NumArgs n b -> NumArgs ('S n) (a -> b)
NAS NumArgs n b
forall (numArgs :: Nat) arrows.
CNumArgs numArgs arrows =>
NumArgs numArgs arrows
getNA

type family Apply (f :: Type -> Type) (n :: Nat) (arrows :: Type) :: Type where
  Apply f (S n) (a -> b) = a -> Apply f n b
  Apply f Z a = f a

applyLast :: forall f fun . (Applicative f, CNumArgs (CountArgs fun) fun) => fun -> Apply f (CountArgs fun) fun
applyLast :: fun -> Apply f (CountArgs fun) fun
applyLast = NumArgs (CountArgs fun) fun -> fun -> Apply f (CountArgs fun) fun
forall (f :: * -> *) (n :: Nat) fun.
Applicative f =>
NumArgs n fun -> fun -> Apply f n fun
applyLast' @f (NumArgs (CountArgs fun) fun
forall (numArgs :: Nat) arrows.
CNumArgs numArgs arrows =>
NumArgs numArgs arrows
getNA :: NumArgs (CountArgs fun) fun)

applyLast' :: forall f n fun . Applicative f => NumArgs n fun -> fun -> Apply f n fun
applyLast' :: NumArgs n fun -> fun -> Apply f n fun
applyLast' NumArgs n fun
NAZ fun
x     = fun -> f fun
forall (f :: * -> *) a. Applicative f => a -> f a
pure fun
x
applyLast' (NAS NumArgs n b
n) fun
f = NumArgs n b -> b -> Apply f n b
forall (f :: * -> *) (n :: Nat) fun.
Applicative f =>
NumArgs n fun -> fun -> Apply f n fun
applyLast' @f NumArgs n b
n (b -> Apply f n b) -> (a -> b) -> a -> Apply f n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. fun
a -> b
f