things

src/Misc/Lift1.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Misc.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
+
+import Data.Fix
+--------------------------------------------------------------------------------
+
+class Lift1 (f :: Data.Kind.Type -> Data.Kind.Type) where
+    lift1 :: (Quote m, Lift t) => f t -> m Exp
+
+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
+
+