Improved Lift instances for Path/OsPath types

The `Lift` instances support now parametic types and promoted data
constructors for the two parameters of the Path/OsPath types.

path.cabal

@@ -69,6 +69,8 @@ library
                    , OsPath.Internal.Posix
                    , OsPath.Internal.Windows
 
+  other-modules:     Utils
+
   build-depends:     aeson      >= 1.0.0.0
                    , base       >= 4.12    && < 5
                    , deepseq

src/OsPath/Internal/Include.hs

@@ -54,6 +54,7 @@ import qualified System.OsPath.PLATFORM_NAME as OsPath
 
 import System.OsString.Compat.PLATFORM_NAME (PLATFORM_STRING)
 import qualified System.OsString.Compat.PLATFORM_NAME as OsString
+import Utils (typeableToType)
 
 -- | Path of some base and type.
 --
@@ -113,16 +114,9 @@ instance Hashable (Path b t) where
 
 instance forall b t. (Typeable b, Typeable t) => TH.Lift (Path b t) where
   lift (Path str) = do
-    let b = TH.ConT $ getTCName (Proxy :: Proxy b)
-        t = TH.ConT $ getTCName (Proxy :: Proxy t)
+    let b = typeableToType (Proxy :: Proxy b)
+        t = typeableToType (Proxy :: Proxy t)
     [| Path $(TH.lift str) :: Path $(pure b) $(pure t) |]
-    where
-      getTCName :: Typeable a => proxy a -> TH.Name
-      getTCName a = TH.Name occ flav
-        where
-        tc   = typeRepTyCon (typeRep a)
-        occ  = TH.OccName (tyConName tc)
-        flav = TH.NameG TH.TcClsName (TH.PkgName (tyConPackage tc)) (TH.ModName (tyConModule tc))
 
 #if MIN_VERSION_template_haskell(2,17,0)
   liftTyped = TH.unsafeCodeCoerce . TH.lift

src/Path/Internal/Include.hs

@@ -30,6 +30,8 @@ import qualified Data.List as L
 import qualified Language.Haskell.TH.Syntax as TH
 import qualified System.FilePath.PLATFORM_NAME as FilePath
 
+import Utils (typeableToType)
+
 -- | Path of some base and type.
 --
 -- The type variables are:
@@ -121,16 +123,9 @@ instance Hashable (Path b t) where
 
 instance forall b t. (Typeable b, Typeable t) => TH.Lift (Path b t) where
   lift (Path str) = do
-    let b = TH.ConT $ getTCName (Proxy :: Proxy b)
-        t = TH.ConT $ getTCName (Proxy :: Proxy t)
+    let b = typeableToType (Proxy :: Proxy b)
+        t = typeableToType (Proxy :: Proxy t)
     [|Path $(pure (TH.LitE (TH.StringL str))) :: Path $(pure b) $(pure t) |]
-    where
-      getTCName :: Typeable a => proxy a -> TH.Name
-      getTCName a = TH.Name occ flav
-        where
-        tc   = typeRepTyCon (typeRep a)
-        occ  = TH.OccName (tyConName tc)
-        flav = TH.NameG TH.TcClsName (TH.PkgName (tyConPackage tc)) (TH.ModName (tyConModule tc))
 
 #if MIN_VERSION_template_haskell(2,17,0)
   liftTyped = TH.unsafeCodeCoerce . TH.lift

src/Utils.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE TypeApplications #-}
+
+module Utils
+    ( typeableToType
+    ) where
+
+import Data.Bifunctor (first)
+import Data.Kind (Type)
+import qualified Data.List as List
+import Data.Typeable (splitTyConApp)
+import qualified Language.Haskell.TH.Syntax as TH
+import Type.Reflection
+
+typeableToType :: (Typeable a) => proxy a -> TH.Type
+typeableToType = typeRepToType . someTypeRep
+
+typeRepToType :: SomeTypeRep -> TH.Type
+typeRepToType rep =
+    uncurry (foldl' f)
+        . first tyConToType
+        . splitTyConApp
+        $ rep
+    where
+        f :: TH.Type -> SomeTypeRep -> TH.Type
+        f memo = TH.AppT memo . typeRepToType
+
+        tyConToType :: TyCon -> TH.Type
+        tyConToType tc =
+            (if isType then TH.ConT else TH.PromotedT)
+                ( TH.Name
+                    (TH.OccName (List.dropWhile (== '\'') (tyConName tc)))
+                    ( TH.NameG
+                        (if isType then TH.TcClsName else TH.DataName)
+                        (TH.PkgName (tyConPackage tc))
+                        (TH.ModName (tyConModule tc))
+                    )
+                )
+
+        isType :: Bool
+        isType = someTypeRepKind rep == SomeTypeRep (typeRep @Type)
+
+someTypeRepKind :: SomeTypeRep -> SomeTypeRep
+someTypeRepKind (SomeTypeRep rep) = SomeTypeRep (typeRepKind rep)

test-ospath/TH/Include.hs

@@ -2,6 +2,7 @@
 --     PLATFORM_NAME = Posix | Windows
 --     PLATFORM_PATH = PosixPath | WindowsPath
 
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -11,6 +12,7 @@
 -- | Test functions to check the template haskell bits.
 module TH.PLATFORM_NAME where
 
+import Data.Proxy (Proxy)
 import qualified Language.Haskell.TH.Syntax as TH
 import System.OsPath.PLATFORM_NAME (PLATFORM_PATH)
 
@@ -48,3 +50,6 @@ liftRelDir = checkInstantiated $(TH.lift (Path [OsString.pstr|name/|] :: Path Re
 
 liftRelFile :: PLATFORM_PATH
 liftRelFile = checkInstantiated $(TH.lift (Path [OsString.pstr|name|] :: Path Rel File))
+
+liftComplex :: PLATFORM_PATH
+liftComplex = toOsPath $(TH.lift (Path [OsString.pstr|name|] :: Path [[Bool]] (Proxy 'True)))

test/TH/Include.hs

@@ -1,6 +1,7 @@
 -- This template expects CPP definitions for:
 --     PLATFORM_NAME = Posix | Windows
 
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -9,6 +10,7 @@
 -- | Test functions to check the template haskell bits.
 module TH.PLATFORM_NAME where
 
+import Data.Proxy (Proxy)
 import qualified Language.Haskell.TH.Syntax as TH
 
 import Path.Internal.PLATFORM_NAME
@@ -44,3 +46,6 @@ liftRelDir = checkInstantiated $(TH.lift (Path "name/" :: Path Rel Dir))
 
 liftRelFile :: FilePath
 liftRelFile = checkInstantiated $(TH.lift (Path "name" :: Path Rel File))
+
+liftComplex :: FilePath
+liftComplex = toFilePath $(TH.lift (Path "name" :: Path [[Bool]] (Proxy 'True)))