cleveland-0.1.1: lorentz-test/Test/Lorentz/CustomValue.hs

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

-- | Checks that the strategies for 'Morley.Util.CustomGeneric' work as expected to
-- produce 'IsoValue' with a custom shape.

{-# OPTIONS_GHC -Wno-partial-fields #-}

module Test.Lorentz.CustomValue
  ( test_Custom_Values
  ) where

import Data.Typeable ((:~:)(..))
import GHC.TypeNats (type (-))
import Test.Tasty (TestTree)

import Lorentz.Layouts.NonDupable
import Lorentz.Value
import Morley.Michelson.Typed.T

----------------------------------------------------------------------------
-- Example data types
----------------------------------------------------------------------------

data CustomType a
  = CustomUp Integer Integer
  | CustomMid {unMid :: Natural}
  | CustomDown a
  | CustomNone

$(customGeneric "CustomType" $ withDepths
    [ cstr @3 [fld @1, fld @1]
    , cstr @3 [fld @0]
    , cstr @2 [fld @0]
    , cstr @1 []
    ]
  )

deriving anyclass instance IsoValue a => IsoValue (CustomType a)

data KindaRightType
  = KindaRightA
  | KindaRightB Mutez Integer
  | KindaRightC Mutez Natural

$(customGeneric "KindaRightType" rightBalanced)

deriving anyclass instance IsoValue KindaRightType

data KindaLeftType
  = KindaLeftA Integer Integer Integer
  | KindaLeftB Natural Mutez Natural

$(customGeneric "KindaLeftType" leftBalanced)

deriving anyclass instance IsoValue KindaLeftType

data VeryRightType
  = VeryRightA
  | VeryRightB
  | VeryRightC
  | VeryRightD
  | VeryRightE
  | VeryRightF

$(customGeneric "VeryRightType" rightComb)

deriving anyclass instance IsoValue VeryRightType

data VeryLeftType = VeryLeft
  { unA :: Integer
  , unB :: Natural
  , unC :: Mutez
  , unD :: Natural
  , unE :: Integer
  }

$(customGeneric "VeryLeftType" leftComb)

deriving anyclass instance IsoValue VeryLeftType

data HaskellLikeType = HaskellLike
  { _ha :: Integer
  , _hb :: Natural
  , _hc :: Mutez
  , _hd :: Natural
  , _he :: Integer
  }

$(customGeneric "HaskellLikeType" haskellBalanced)

deriving anyclass instance IsoValue HaskellLikeType

data LigoType = LigoType
  { _l1 :: ()
  , _l2 :: ()
  , _l3 :: ()
  , _l4 :: ()
  , _l5 :: ()
  , _l6 :: ()
  , _l7 :: ()
  , _l8 :: ()
  , _l9 :: ()
  , _l10 :: ()
  , _l11 :: ()
  , _l12 :: ()
  , _l13 :: ()
  }

$(customGeneric "LigoType" ligoLayout)

deriving anyclass instance IsoValue LigoType

data LigoUnorderedType = LigoUnorderedType
  { _lu5 :: ()
  , _lu1 :: Integer
  , _lu2 :: Natural
  , _lu3 :: MText
  , _lu4 :: ByteString
  }

$(customGeneric "LigoUnorderedType" ligoLayout)

deriving anyclass instance IsoValue LigoUnorderedType

data LigoSumType
  = LigoSumTypeB Integer
  | LigoSumTypeA ()

$(customGeneric "LigoSumType" ligoLayout)

deriving anyclass instance IsoValue LigoSumType

data LigoCombType = LigoCombType
  { _lc5 :: Integer
  , _lc1 :: ()
  , _lc2 :: ()
  , _lc3 :: ()
  , _lc4 :: ()
  }

$(customGeneric "LigoCombType" ligoCombLayout)

deriving anyclass instance IsoValue LigoCombType

data LigoCombSumType
  = LigoCombSumTypeB Integer
  | LigoCombSumTypeA ()

$(customGeneric "LigoCombSumType" ligoCombLayout)

deriving anyclass instance IsoValue LigoCombSumType

newtype NewType a = NewType (CustomType a)

$(customGeneric "NewType" haskellBalanced)

deriving anyclass instance IsoValue a => IsoValue (NewType a)

data SemiDupableType = SemiDupableType
  { _sdt1 :: Integer
  , _sdt2 :: Natural
  , _sdt3 :: ByteString
  , _sdt4 :: MText
  , _sdt5 :: ()
  , _sdt6 :: Ticket Integer
  , _sdt7 :: Ticket Natural
  }

$(deriveSemiDupableGeneric "SemiDupableType" 2)

deriving anyclass instance IsoValue SemiDupableType

----------------------------------------------------------------------------
-- Expected resulting IsoValue
----------------------------------------------------------------------------

type ExpectedCustomValue a =
  'TOr ('TOr ('TOr ('TPair 'TInt 'TInt) 'TNat) (ToT a)) 'TUnit

type ExpectedKindaRightValue =
  'TOr 'TUnit ('TOr ('TPair 'TMutez 'TInt) ('TPair 'TMutez 'TNat))

type ExpectedKindaLeftValue =
  'TOr ('TPair ('TPair 'TInt 'TInt) 'TInt) ('TPair ('TPair 'TNat 'TMutez) 'TNat)

type ExpectedVeryRightValue =
  'TOr 'TUnit ('TOr 'TUnit ('TOr 'TUnit ('TOr 'TUnit ('TOr 'TUnit 'TUnit))))

type ExpectedVeryLeftValue =
  'TPair ('TPair ('TPair ('TPair 'TInt 'TNat) 'TMutez) 'TNat) 'TInt

data HaskellTrueType = HaskellTrue
  { _ha' :: Integer
  , _hb' :: Natural
  , _hc' :: Mutez
  , _hd' :: Natural
  , _he' :: Integer
  } deriving stock (Generic)
    deriving anyclass (IsoValue)

type ExpectedHaskellLikeValue =
  ToT HaskellTrueType

type family CompletePairTree n e where
  CompletePairTree 0 e = e
  CompletePairTree k e =
    'TPair (CompletePairTree (k - 1) e) (CompletePairTree (k - 1) e)

type ExpectedLigoValue =
  'TPair
    (CompletePairTree 3 'TUnit)
    ('TPair
     (CompletePairTree 2 'TUnit)
     'TUnit
    )

type ExpectedLigoUnorderedValue =
  'TPair ('TPair ('TPair 'TInt 'TNat) ('TPair 'TString 'TBytes)) 'TUnit

type ExpectedLigoSumValue =
  'TOr 'TUnit 'TInt

type ExpectedLigoCombValue =
  'TPair 'TInt $ 'TPair 'TUnit $ 'TPair 'TUnit $ 'TPair 'TUnit 'TUnit

type ExpectedLigoCombSumValue =
  'TOr 'TInt 'TUnit

type ExpectedSemiDupableValue =
  'TPair
    ('TPair ('TPair 'TInt 'TNat) ('TPair 'TBytes ('TPair 'TString 'TUnit)))
    ('TPair ('TTicket 'TInt) ('TTicket 'TNat))

----------------------------------------------------------------------------
-- Type equality checking
----------------------------------------------------------------------------

-- Fake tests to deceive "weeder".
-- We only do typechecking in this module.
test_Custom_Values :: [TestTree]
test_Custom_Values = []
  where
    _nonSense = (unMid, unA, unB, unC, unD, unE)

_checkWithDepths :: ToT (CustomType a) :~: (ExpectedCustomValue a)
_checkWithDepths = Refl

_checkRightBalanced :: ToT KindaRightType :~: ExpectedKindaRightValue
_checkRightBalanced = Refl

_checkLeftBalanced :: ToT KindaLeftType :~: ExpectedKindaLeftValue
_checkLeftBalanced = Refl

_checkRightComb :: ToT VeryRightType :~: ExpectedVeryRightValue
_checkRightComb = Refl

_checkLeftComb :: ToT VeryLeftType :~: ExpectedVeryLeftValue
_checkLeftComb = Refl

_checkHaskellLike :: ToT HaskellLikeType :~: ExpectedHaskellLikeValue
_checkHaskellLike = Refl

_checkLigoLayout :: ToT LigoType :~: ExpectedLigoValue
_checkLigoLayout = Refl

_checkLigoLayout2 :: ToT LigoUnorderedType :~: ExpectedLigoUnorderedValue
_checkLigoLayout2 = Refl

_checkLigoLayout3 :: ToT LigoSumType :~: ExpectedLigoSumValue
_checkLigoLayout3 = Refl

_checkLigoCombLayout1 :: ToT LigoCombType :~: ExpectedLigoCombValue
_checkLigoCombLayout1 = Refl

_checkLigoCombLayout2 :: ToT LigoCombSumType :~: ExpectedLigoCombSumValue
_checkLigoCombLayout2 = Refl

_checkNewType :: ToT (NewType a) :~: ToT (CustomType a)
_checkNewType = Refl

_checkSemiDupable :: ToT SemiDupableType :~: ExpectedSemiDupableValue
_checkSemiDupable = Refl