{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LinearTypes #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_HADDOCK hide #-}

-- | This module exports instances of Consumable, Dupable and Movable
--
-- We export instances in this module to avoid a circular dependence
-- and keep things clean. Movable depends on the defintion of Ur yet
-- many instances of Movable which we might have put in the module with
-- Movable depend on Ur. So, we just put the instances of Movable and the
-- other classes (for cleanness) in this module to avoid this dependence.
module Data.Unrestricted.Linear.Internal.Instances where

import qualified Data.Functor.Linear.Internal.Applicative as Data
import qualified Data.Functor.Linear.Internal.Functor as Data
import Data.Monoid.Linear
import Data.Replicator.Linear.Internal.Instances ()
import Data.Unrestricted.Linear.Internal.Consumable
import Data.Unrestricted.Linear.Internal.Dupable
import Data.Unrestricted.Linear.Internal.Movable
import Data.Unrestricted.Linear.Internal.Ur
import Data.V.Linear.Internal (V (..))
import qualified Data.V.Linear.Internal as V
import qualified Data.Vector as Vector
import GHC.Int
import GHC.TypeLits
import GHC.Word
import Prelude.Linear.Internal
import qualified Unsafe.Linear as Unsafe
import qualified Prelude

-- | Newtype that must be used with @DerivingVia@ to get efficient 'Dupable'
-- and 'Consumable' implementations for 'Movable' types.
newtype AsMovable a = AsMovable a

instance Movable a => Movable (AsMovable a) where
  move :: AsMovable a %1 -> Ur (AsMovable a)
move (AsMovable a
x) =
    a %1 -> Ur a
forall a. Movable a => a %1 -> Ur a
move a
x Ur a %1 -> (Ur a %1 -> Ur (AsMovable a)) -> Ur (AsMovable a)
forall a b (p :: Multiplicity) (q :: Multiplicity).
a %p -> (a %p -> b) %q -> b
& \case
      Ur a
x' -> AsMovable a -> Ur (AsMovable a)
forall a. a -> Ur a
Ur (a -> AsMovable a
forall a. a -> AsMovable a
AsMovable a
x')

instance Movable a => Consumable (AsMovable a) where
  consume :: AsMovable a %1 -> ()
consume AsMovable a
x =
    AsMovable a %1 -> Ur (AsMovable a)
forall a. Movable a => a %1 -> Ur a
move AsMovable a
x Ur (AsMovable a) %1 -> (Ur (AsMovable a) %1 -> ()) -> ()
forall a b (p :: Multiplicity) (q :: Multiplicity).
a %p -> (a %p -> b) %q -> b
& \case
      Ur AsMovable a
_ -> ()

instance Movable a => Dupable (AsMovable a) where
  dupR :: AsMovable a %1 -> Replicator (AsMovable a)
dupR AsMovable a
x =
    AsMovable a %1 -> Ur (AsMovable a)
forall a. Movable a => a %1 -> Ur a
move AsMovable a
x Ur (AsMovable a)
%1 -> (Ur (AsMovable a) %1 -> Replicator (AsMovable a))
-> Replicator (AsMovable a)
forall a b (p :: Multiplicity) (q :: Multiplicity).
a %p -> (a %p -> b) %q -> b
& \case
      Ur AsMovable a
x' -> AsMovable a -> Replicator (AsMovable a)
forall (f :: * -> *) a. Applicative f => a -> f a
Data.pure AsMovable a
x'

deriving via (AsMovable Int8) instance Consumable Int8

deriving via (AsMovable Int8) instance Dupable Int8

instance Movable Int8 where
  -- /!\ 'Int8#' is an unboxed unlifted data-types, therefore it cannot have any
  -- linear values hidden in a closure anywhere. Therefore it is safe to call
  -- non-linear functions linearly on this type: there is no difference between
  -- copying an 'Int8#' and using it several times. /!\
  move :: Int8 %1 -> Ur Int8
move (I8# Int#
i) = (Int# -> Ur Int8) %1 -> Int# %1 -> Ur Int8
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear (\Int#
j -> Int8 -> Ur Int8
forall a. a -> Ur a
Ur (Int# -> Int8
I8# Int#
j)) Int#
i

deriving via (AsMovable Int16) instance Consumable Int16

deriving via (AsMovable Int16) instance Dupable Int16

instance Movable Int16 where
  -- /!\ 'Int16#' is an unboxed unlifted data-types, therefore it cannot have any
  -- linear values hidden in a closure anywhere. Therefore it is safe to call
  -- non-linear functions linearly on this type: there is no difference between
  -- copying an 'Int16#' and using it several times. /!\
  move :: Int16 %1 -> Ur Int16
move (I16# Int#
i) = (Int# -> Ur Int16) %1 -> Int# %1 -> Ur Int16
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear (\Int#
j -> Int16 -> Ur Int16
forall a. a -> Ur a
Ur (Int# -> Int16
I16# Int#
j)) Int#
i

deriving via (AsMovable Int32) instance Consumable Int32

deriving via (AsMovable Int32) instance Dupable Int32

instance Movable Int32 where
  -- /!\ 'Int32#' is an unboxed unlifted data-types, therefore it cannot have any
  -- linear values hidden in a closure anywhere. Therefore it is safe to call
  -- non-linear functions linearly on this type: there is no difference between
  -- copying an 'Int32#' and using it several times. /!\
  move :: Int32 %1 -> Ur Int32
move (I32# Int#
i) = (Int# -> Ur Int32) %1 -> Int# %1 -> Ur Int32
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear (\Int#
j -> Int32 -> Ur Int32
forall a. a -> Ur a
Ur (Int# -> Int32
I32# Int#
j)) Int#
i

deriving via (AsMovable Int64) instance Consumable Int64

deriving via (AsMovable Int64) instance Dupable Int64

instance Movable Int64 where
  -- /!\ 'Int64#' is an unboxed unlifted data-types, therefore it cannot have any
  -- linear values hidden in a closure anywhere. Therefore it is safe to call
  -- non-linear functions linearly on this type: there is no difference between
  -- copying an 'Int64#' and using it several times. /!\
  move :: Int64 %1 -> Ur Int64
move (I64# Int#
i) = (Int# -> Ur Int64) %1 -> Int# %1 -> Ur Int64
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear (\Int#
j -> Int64 -> Ur Int64
forall a. a -> Ur a
Ur (Int# -> Int64
I64# Int#
j)) Int#
i

deriving via (AsMovable Word8) instance Consumable Word8

deriving via (AsMovable Word8) instance Dupable Word8

instance Movable Word8 where
  -- /!\ 'Word8#' is an unboxed unlifted data-types, therefore it cannot have any
  -- linear values hidden in a closure anywhere. Therefore it is safe to call
  -- non-linear functions linearly on this type: there is no difference between
  -- copying an 'Word8#' and using it several times. /!\
  move :: Word8 %1 -> Ur Word8
move (W8# Word#
i) = (Word# -> Ur Word8) %1 -> Word# %1 -> Ur Word8
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear (\Word#
j -> Word8 -> Ur Word8
forall a. a -> Ur a
Ur (Word# -> Word8
W8# Word#
j)) Word#
i

deriving via (AsMovable Word16) instance Consumable Word16

deriving via (AsMovable Word16) instance Dupable Word16

instance Movable Word16 where
  -- /!\ 'Word16#' is an unboxed unlifted data-types, therefore it cannot have any
  -- linear values hidden in a closure anywhere. Therefore it is safe to call
  -- non-linear functions linearly on this type: there is no difference between
  -- copying an 'Word16#' and using it several times. /!\
  move :: Word16 %1 -> Ur Word16
move (W16# Word#
i) = (Word# -> Ur Word16) %1 -> Word# %1 -> Ur Word16
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear (\Word#
j -> Word16 -> Ur Word16
forall a. a -> Ur a
Ur (Word# -> Word16
W16# Word#
j)) Word#
i

deriving via (AsMovable Word32) instance Consumable Word32

deriving via (AsMovable Word32) instance Dupable Word32

instance Movable Word32 where
  -- /!\ 'Word32#' is an unboxed unlifted data-types, therefore it cannot have any
  -- linear values hidden in a closure anywhere. Therefore it is safe to call
  -- non-linear functions linearly on this type: there is no difference between
  -- copying an 'Word32#' and using it several times. /!\
  move :: Word32 %1 -> Ur Word32
move (W32# Word#
i) = (Word# -> Ur Word32) %1 -> Word# %1 -> Ur Word32
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear (\Word#
j -> Word32 -> Ur Word32
forall a. a -> Ur a
Ur (Word# -> Word32
W32# Word#
j)) Word#
i

deriving via (AsMovable Word64) instance Consumable Word64

deriving via (AsMovable Word64) instance Dupable Word64

instance Movable Word64 where
  -- /!\ 'Word64#' is an unboxed unlifted data-types, therefore it cannot have any
  -- linear values hidden in a closure anywhere. Therefore it is safe to call
  -- non-linear functions linearly on this type: there is no difference between
  -- copying an 'Word64#' and using it several times. /!\
  move :: Word64 %1 -> Ur Word64
move (W64# Word#
i) = (Word# -> Ur Word64) %1 -> Word# %1 -> Ur Word64
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear (\Word#
j -> Word64 -> Ur Word64
forall a. a -> Ur a
Ur (Word# -> Word64
W64# Word#
j)) Word#
i

-- TODO: instances for longer primitive tuples
-- TODO: default instances based on the Generic framework

instance Consumable (V 0 a) where
  consume :: V 0 a %1 -> ()
consume = V 0 a %1 -> ()
forall a. V 0 a %1 -> ()
V.consume

instance (KnownNat n, Consumable a) => Consumable (V n a) where
  consume :: V n a %1 -> ()
consume (V Vector a
xs) = [a] %1 -> ()
forall a. Consumable a => a %1 -> ()
consume ((Vector a -> [a]) %1 -> Vector a %1 -> [a]
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear Vector a -> [a]
forall a. Vector a -> [a]
Vector.toList Vector a
xs)

instance (KnownNat n, Dupable a) => Dupable (V n a) where
  dupR :: V n a %1 -> Replicator (V n a)
dupR (V Vector a
xs) =
    Vector a %1 -> V n a
forall (n :: Nat) a. Vector a -> V n a
V (Vector a %1 -> V n a) -> ([a] %1 -> Vector a) -> [a] %1 -> V n a
forall b c a (q :: Multiplicity) (m :: Multiplicity)
       (n :: Multiplicity).
(b %1 -> c) %q -> (a %1 -> b) %m -> a %n -> c
. ([a] -> Vector a) %1 -> [a] %1 -> Vector a
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear (Int -> [a] -> Vector a
forall a. Int -> [a] -> Vector a
Vector.fromListN (forall (n :: Nat). KnownNat n => Int
V.theLength @n))
      ([a] %1 -> V n a) -> Replicator [a] %1 -> Replicator (V n a)
forall (f :: * -> *) a b. Functor f => (a %1 -> b) -> f a %1 -> f b
Data.<$> [a] %1 -> Replicator [a]
forall a. Dupable a => a %1 -> Replicator a
dupR ((Vector a -> [a]) %1 -> Vector a %1 -> [a]
forall a b (p :: Multiplicity) (x :: Multiplicity).
(a %p -> b) %1 -> a %x -> b
Unsafe.toLinear Vector a -> [a]
forall a. Vector a -> [a]
Vector.toList Vector a
xs)

-- Some stock instances

newtype MovableMonoid a = MovableMonoid a
  deriving (NonEmpty (MovableMonoid a) -> MovableMonoid a
MovableMonoid a -> MovableMonoid a -> MovableMonoid a
(MovableMonoid a -> MovableMonoid a -> MovableMonoid a)
-> (NonEmpty (MovableMonoid a) -> MovableMonoid a)
-> (forall b.
    Integral b =>
    b -> MovableMonoid a -> MovableMonoid a)
-> Semigroup (MovableMonoid a)
forall b. Integral b => b -> MovableMonoid a -> MovableMonoid a
forall a.
Semigroup a =>
NonEmpty (MovableMonoid a) -> MovableMonoid a
forall a.
Semigroup a =>
MovableMonoid a -> MovableMonoid a -> MovableMonoid a
forall a b.
(Semigroup a, Integral b) =>
b -> MovableMonoid a -> MovableMonoid a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> MovableMonoid a -> MovableMonoid a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> MovableMonoid a -> MovableMonoid a
sconcat :: NonEmpty (MovableMonoid a) -> MovableMonoid a
$csconcat :: forall a.
Semigroup a =>
NonEmpty (MovableMonoid a) -> MovableMonoid a
<> :: MovableMonoid a -> MovableMonoid a -> MovableMonoid a
$c<> :: forall a.
Semigroup a =>
MovableMonoid a -> MovableMonoid a -> MovableMonoid a
Prelude.Semigroup, Semigroup (MovableMonoid a)
MovableMonoid a
Semigroup (MovableMonoid a)
-> MovableMonoid a
-> (MovableMonoid a -> MovableMonoid a -> MovableMonoid a)
-> ([MovableMonoid a] -> MovableMonoid a)
-> Monoid (MovableMonoid a)
[MovableMonoid a] -> MovableMonoid a
MovableMonoid a -> MovableMonoid a -> MovableMonoid a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall {a}. Monoid a => Semigroup (MovableMonoid a)
forall a. Monoid a => MovableMonoid a
forall a. Monoid a => [MovableMonoid a] -> MovableMonoid a
forall a.
Monoid a =>
MovableMonoid a -> MovableMonoid a -> MovableMonoid a
mconcat :: [MovableMonoid a] -> MovableMonoid a
$cmconcat :: forall a. Monoid a => [MovableMonoid a] -> MovableMonoid a
mappend :: MovableMonoid a -> MovableMonoid a -> MovableMonoid a
$cmappend :: forall a.
Monoid a =>
MovableMonoid a -> MovableMonoid a -> MovableMonoid a
mempty :: MovableMonoid a
$cmempty :: forall a. Monoid a => MovableMonoid a
Prelude.Monoid)

instance (Movable a, Prelude.Semigroup a) => Semigroup (MovableMonoid a) where
  MovableMonoid a
a <> :: MovableMonoid a %1 -> MovableMonoid a %1 -> MovableMonoid a
<> MovableMonoid a
b = a %1 -> MovableMonoid a
forall a. a -> MovableMonoid a
MovableMonoid (Semigroup a => Ur a %1 -> Ur a %1 -> a
Ur a %1 -> Ur a %1 -> a
combine (a %1 -> Ur a
forall a. Movable a => a %1 -> Ur a
move a
a) (a %1 -> Ur a
forall a. Movable a => a %1 -> Ur a
move a
b))
    where
      combine :: Prelude.Semigroup a => Ur a %1 -> Ur a %1 -> a
      combine :: Semigroup a => Ur a %1 -> Ur a %1 -> a
combine (Ur a
x) (Ur a
y) = a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
Prelude.<> a
y

instance (Movable a, Prelude.Monoid a) => Monoid (MovableMonoid a) where
  mempty :: MovableMonoid a
mempty = a -> MovableMonoid a
forall a. a -> MovableMonoid a
MovableMonoid a
forall a. Monoid a => a
Prelude.mempty