{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Arrow.Transformer.NoInline where

import Prelude hiding (id,(.),lookup,read,fail)

import Control.Category
import Control.Arrow
import Control.Arrow.Const
import Control.Arrow.Environment as Env
import Control.Arrow.Closure as Cls
import Control.Arrow.Except as Exc
import Control.Arrow.Fail as Fail
import Control.Arrow.Fix
import Control.Arrow.Fix.Cache as Cache
import Control.Arrow.Fix.Context as Context
import Control.Arrow.Order
import Control.Arrow.Reader as Reader
import Control.Arrow.State as State
import Control.Arrow.Store as Store
import Control.Arrow.Trans
import Control.Arrow.Writer
import Control.Arrow.LetRec

import Data.Profunctor
import Data.Profunctor.Unsafe
import Unsafe.Coerce

newtype NoInlineT c x y = NoInlineT { runNoInlineTT :: c x y }

instance ArrowRun c => ArrowRun (NoInlineT c) where
  type Run (NoInlineT c) x y = Run c x y

instance ArrowLift (NoInlineT c) where
  type Underlying (NoInlineT c) x y = c x y

instance ArrowTrans NoInlineT where
  lift' = NoInlineT
  {-# INLINE lift' #-}

instance Profunctor c => Profunctor (NoInlineT c) where
  dimap f g h = lift $ dimap f g (unlift h)
  lmap f h = lift $ lmap f (unlift h)
  rmap g h = lift $ rmap g (unlift h)
  f .# _ = f `seq` unsafeCoerce f
  _ #. g = g `seq` unsafeCoerce g
  {-# NOINLINE dimap #-}
  {-# NOINLINE lmap #-}
  {-# NOINLINE rmap #-}
  {-# NOINLINE (.#) #-}
  {-# NOINLINE (#.) #-}

-- instance ArrowTrans NoInlineT where
--   lift' = lift
--   {-# NOINLINE lift' #-}

instance Category c => Category (NoInlineT c) where
  id    = lift id
  f . g = lift (unlift f . unlift g)
  {-# NOINLINE id #-}
  {-# NOINLINE (.) #-}

instance Arrow c => Arrow (NoInlineT c) where
  arr f    = lift (arr f)
  first f  = lift $ first (unlift f)
  second f = lift $ second (unlift f)
  f &&& g  = lift $ unlift f &&& unlift g
  f *** g  = lift $ unlift f *** unlift g
  {-# NOINLINE arr #-}
  {-# NOINLINE first #-}
  {-# NOINLINE second #-}
  {-# NOINLINE (&&&) #-}
  {-# NOINLINE (***) #-}

instance (ArrowChoice c) => ArrowChoice (NoInlineT c) where
  left f  = lift $ left (unlift f)
  right f = lift $ right (unlift f)
  f +++ g = lift $ unlift f +++ unlift g
  f ||| g = lift $ unlift f ||| unlift g
  {-# NOINLINE left #-}
  {-# NOINLINE right #-}
  {-# NOINLINE (+++) #-}
  {-# NOINLINE (|||) #-}

instance (ArrowApply c, Profunctor c) => ArrowApply (NoInlineT c) where
  app = lift $ lmap (\(f,b) -> (unlift f,b)) app
  {-# NOINLINE app #-}

instance ArrowReader r c => ArrowReader r (NoInlineT c) where
  ask = lift ask
  local f = lift $ local (unlift f)
  {-# NOINLINE ask #-}
  {-# NOINLINE local #-}

instance ArrowState s c => ArrowState s (NoInlineT c) where
  get = lift State.get
  put = lift State.put
  modify f = lift (State.modify (unlift f))
  {-# NOINLINE get #-}
  {-# NOINLINE put #-}
  {-# NOINLINE modify #-}

instance ArrowWriter w c => ArrowWriter w (NoInlineT c) where
  tell = lift tell
  {-# NOINLINE tell #-}

instance ArrowFail e c => ArrowFail e (NoInlineT c) where
  type Join x (NoInlineT c) = Fail.Join x c
  fail = lift fail
  {-# NOINLINE fail #-}

instance ArrowEnv var val c => ArrowEnv var val (NoInlineT c) where
  type Join y (NoInlineT c) = Env.Join y c
  lookup f g = lift (Env.lookup (unlift f) (unlift g))
  extend f = lift (Env.extend (unlift f))
  {-# NOINLINE lookup #-}
  {-# NOINLINE extend #-}

instance ArrowLetRec var val c => ArrowLetRec var val (NoInlineT c) where
  letRec f = lift (letRec (unlift f))
  {-# NOINLINE letRec #-}

instance ArrowClosure expr cls c => ArrowClosure expr cls (NoInlineT c) where
  type Join y cls (NoInlineT c) = Cls.Join y cls c
  closure = lift Cls.closure
  apply f = lift $ Cls.apply (unlift f)
  {-# NOINLINE closure #-}
  {-# NOINLINE apply #-}

instance ArrowStore var val c => ArrowStore var val (NoInlineT c) where
  type Join y (NoInlineT c) = Store.Join y c
  read f g = lift $ Store.read (unlift f) (unlift g)
  write = lift Store.write
  {-# NOINLINE read #-}
  {-# NOINLINE write #-}

instance ArrowFix (Underlying (NoInlineT c) x y) => ArrowFix (NoInlineT c x y) where
  type Fix (NoInlineT c x y) = Fix (Underlying (NoInlineT c) x y)

instance ArrowExcept e c => ArrowExcept e (NoInlineT c) where
  type Join z (NoInlineT c) = Exc.Join z c
  throw = lift throw
  try f g h = lift $ try (unlift f) (unlift g) (unlift h)
  {-# NOINLINE throw #-}
  {-# NOINLINE try #-}

instance ArrowJoin c => ArrowJoin (NoInlineT c) where
  joinSecond lub f g = lift $ joinSecond lub f (unlift g)
  {-# NOINLINE joinSecond #-}

instance ArrowLowerBounded y c => ArrowLowerBounded y (NoInlineT c) where
  bottom = lift bottom
  {-# NOINLINE bottom #-}

instance ArrowComplete y c => ArrowComplete y (NoInlineT c) where
  f <⊔> g = lift $ unlift f <⊔> unlift g
  {-# NOINLINE (<⊔>) #-}

instance ArrowConst x c => ArrowConst x (NoInlineT c) where
  askConst f = lift (askConst (unlift . f))
  {-# NOINLINE askConst #-}

instance ArrowCallSite ctx c => ArrowCallSite ctx (NoInlineT c) where
  pushLabel k f = lift $ pushLabel k (unlift f)
  {-# NOINLINE pushLabel #-}

instance ArrowCache a b c => ArrowCache a b (NoInlineT c) where
  type Widening (NoInlineT c) = Cache.Widening c
  initialize = lift Cache.initialize
  lookup = lift Cache.lookup
  write = lift Cache.write
  update = lift Cache.update
  setStable = lift Cache.setStable
  {-# NOINLINE initialize #-}
  {-# NOINLINE lookup #-}
  {-# NOINLINE write #-}
  {-# NOINLINE update #-}
  {-# NOINLINE setStable #-}
