55 lines
1.6 KiB
Haskell
55 lines
1.6 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
module Misc.Lift1
|
|
( Lift1(..), lift1
|
|
, liftCon, liftCon2, liftCon3
|
|
, Lift(..)
|
|
)
|
|
where
|
|
--------------------------------------------------------------------------------
|
|
import Language.Haskell.TH hiding (Type, Name)
|
|
import Language.Haskell.TH.Syntax hiding (Type, Name)
|
|
import Language.Haskell.TH.Syntax qualified as TH
|
|
import Language.Haskell.TH.Quote
|
|
import Data.Kind qualified
|
|
import GHC.Generics
|
|
|
|
-- instances
|
|
import Data.Fix
|
|
import Data.Functor.Sum
|
|
--------------------------------------------------------------------------------
|
|
|
|
class Lift1 (f :: Data.Kind.Type -> Data.Kind.Type) where
|
|
-- lift1 :: (Quote m, Lift t) => f t -> m Exp
|
|
liftLift :: (Quote m) => (a -> m Exp) -> f a -> m Exp
|
|
|
|
lift1 :: (Lift1 f, Lift a, Quote m) => f a -> m Exp
|
|
lift1 = liftLift lift
|
|
|
|
liftCon :: Quote m => TH.Name -> m Exp -> m Exp
|
|
liftCon n = fmap (AppE (ConE n))
|
|
|
|
liftCon2 :: Quote m => TH.Name -> m Exp -> m Exp -> m Exp
|
|
liftCon2 n a b = do
|
|
a' <- a
|
|
b' <- b
|
|
pure $ ConE n `AppE` a' `AppE` b'
|
|
|
|
liftCon3 :: Quote m => TH.Name -> m Exp -> m Exp -> m Exp -> m Exp
|
|
liftCon3 n a b c = do
|
|
a' <- a
|
|
b' <- b
|
|
c' <- c
|
|
pure $ ConE n `AppE` a' `AppE` b' `AppE` c'
|
|
|
|
instance Lift1 f => Lift (Fix f) where
|
|
lift (Fix f) = AppE (ConE 'Fix) <$> lift1 f
|
|
|
|
instance Lift1 [] where
|
|
liftLift lf [] = pure $ ConE '[]
|
|
liftLift lf (a:as) = liftCon2 '(:) (lf a) (liftLift lf as)
|
|
|
|
instance (Lift1 f, Lift1 g) => Lift1 (Sum f g) where
|
|
liftLift lf (InL fa) = liftCon 'InL $ liftLift lf fa
|
|
liftLift lf (InR ga) = liftCon 'InR $ liftLift lf ga
|
|
|