{-# LANGUAGE DerivingStrategies, FunctionalDependencies #-}
module Lorentz.Referenced
( dupT
, dipT
, dropT
) where
import Prelude hiding (drop, swap)
import qualified Data.Kind as Kind
import Data.Type.Bool (If)
import GHC.TypeLits (ErrorMessage(..), TypeError)
import Lorentz.Base
import Lorentz.Instr
import Util.Type
type family StackElemNotFound st a :: ErrorMessage where
StackElemNotFound st a =
'Text "Element of type `" ':<>: 'ShowType a ':<>:
'Text "` is not present on stack" ':$$: 'ShowType st
type family StackElemAmbiguous st a :: ErrorMessage where
StackElemAmbiguous st a =
'Text "Ambigous reference to element of type `" ':<>: 'ShowType a ':<>:
'Text "` for stack" ':$$: 'ShowType st
class DupT (origSt :: [Kind.Type]) (a :: Kind.Type) (st :: [Kind.Type]) where
dupTImpl :: st :-> a : st
instance TypeError (StackElemNotFound origSt a) =>
DupT origSt a '[] where
dupTImpl = error "impossible"
instance {-# OVERLAPPING #-}
If (a `IsElem` st)
(TypeError (StackElemAmbiguous origSt a))
(() :: Constraint) =>
DupT origSt a (a : st) where
dupTImpl = dup
instance {-# OVERLAPPABLE #-}
DupT origSt a st =>
DupT origSt a (b : st) where
dupTImpl = dip (dupTImpl @origSt) # swap
dupT :: forall a st. DupT st a st => st :-> a : st
dupT = dupTImpl @st @a @st
_dupSample1 :: [Integer, Text, ()] :-> [Text, Integer, Text, ()]
_dupSample1 = dupT @Text
class DipT (origInp :: [Kind.Type]) (a :: Kind.Type)
(inp :: [Kind.Type]) (dipInp :: [Kind.Type])
(dipOut :: [Kind.Type]) (out :: [Kind.Type])
| inp a -> dipInp, dipOut inp a -> out where
dipTImpl :: (dipInp :-> dipOut) -> (inp :-> out)
instance ( TypeError (StackElemNotFound origSt a)
, dipInp ~ TypeError ('Text "Undefined type (see next error)")
, out ~ TypeError ('Text "Undefined type (see next error)")
) =>
DipT origSt a '[] dipInp dipOut out where
dipTImpl = error "impossible"
instance {-# OVERLAPPING #-}
( If (a `IsElem` st)
(TypeError (StackElemAmbiguous origSt a))
(() :: Constraint)
, dipInp ~ (a : st)
, dipOut ~ out
) =>
DipT origSt a (a : st) dipInp dipOut out where
dipTImpl = id
instance {-# OVERLAPPABLE #-}
( DipT origSt a st dipInp dipOut out
, out1 ~ (b : out)
) =>
DipT origSt a (b : st) dipInp dipOut out1 where
dipTImpl = dip . dipTImpl @origSt @a @st
dipT
:: forall a inp dinp dout out.
DipT inp a inp dinp dout out
=> (dinp :-> dout) -> (inp :-> out)
dipT = dipTImpl @inp @a @inp @dinp
_dipSample1
:: [Natural, ()]
:-> '[ByteString]
-> [Integer, Text, Natural, ()]
:-> [Integer, Text, ByteString]
_dipSample1 = dipT @Natural
dropT
:: forall a inp dinp dout out.
( DipT inp a inp dinp dout out
, dinp ~ (a ': dout)
)
=> inp :-> out
dropT = dipT @a drop
_dropSample1 :: [Integer, (), Natural] :-> [Integer, Natural]
_dropSample1 = dropT @()