Wrappable.hs

-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

-- | Permissions for casts between wrappers and their inner types.
module Lorentz.Wrappable
  ( Unwrappable (..)
  , Wrappable
  ) where

import Data.Fixed (Fixed(..))
import GHC.Generics (C1, D1, Generic(..), Meta(..), Rec0, S1)
import GHC.TypeLits (ErrorMessage(..), TypeError)

import Morley.Michelson.Typed (ToT)
import Morley.Util.Named

{- | Declares that this type is just a wrapper over some other type and it can
be safely unwrapped to that inner type.

Inspired by lens @Wrapped@.

Generic-derivable for newtypes.

>>> import Lorentz
>>> :{
newtype Foo = Foo Integer
  deriving stock Generic
  deriving anyclass (IsoValue, Unwrappable)
:}

@IsoValue@ instance is mandatory, but 'Generic' isn't:

>>> import Morley.Michelson.Typed.T
>>> :{
data Foo = Foo Integer
--
instance IsoValue Foo where
  type ToT Foo = TInt
  toVal (Foo i) = toVal i
  fromVal i = Foo $ fromVal i
--
instance Unwrappable Foo where
  type Unwrappabled Foo = Integer
:}
-}
class ToT s ~ ToT (Unwrappabled s) => Unwrappable (s :: Type) where
  -- | The type we unwrap to (inner type of the newtype).
  --
  -- Used in constraint for Lorentz instruction wrapping into a Haskell newtype
  -- and vice versa.
  type Unwrappabled s :: Type
  type Unwrappabled s = GUnwrappabled s (Rep s)

-- | Declares that it is safe to wrap an inner type to the given
-- wrapper type. Can be provided in addition to 'Unwrappable'.
--
-- You can declare this instance when your wrapper exists just to
-- make type system differentiate the two types. Example:
-- @newtype TokenId = TokenId Natural@.
--
-- Do /not/ define this instance for wrappers that provide some invariants.
-- Example: @UStore@ type from @morley-upgradeable@.
--
-- 'Wrappable' is similar to lens @Wrapped@ class without the method.
class Unwrappable s => Wrappable (s :: Type)

type family GUnwrappabled (orig :: Type) (rep :: Type -> Type) :: Type where
  GUnwrappabled _ (D1 ('MetaData _ _ _ 'True) (C1 _ (S1 _ (Rec0 a)))) = a
  GUnwrappabled orig _ =
    TypeError ('Text "Type " ':<>: 'ShowType orig ':<>: 'Text " is not a newtype")

instance Unwrappable (NamedF Identity a name) where
  type Unwrappabled (NamedF Identity a name) = a

instance Wrappable (NamedF Identity a name)

instance Unwrappable (NamedF Maybe a name) where
  type Unwrappabled (NamedF Maybe a name) = Maybe a

instance Wrappable (NamedF Maybe a name)

instance Unwrappable (Fixed a) where
  type Unwrappabled (Fixed a) = Integer