From 516921255f11aadac81aa38f495e1d3f6850f907 Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Thu, 12 Sep 2024 01:29:51 +0200 Subject: [PATCH] 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 | 2 ++ src/OsPath/Internal/Include.hs | 12 +++------- src/Path/Internal/Include.hs | 13 ++++------ src/Utils.hs | 43 ++++++++++++++++++++++++++++++++++ test-ospath/TH/Include.hs | 5 ++++ test/TH/Include.hs | 5 ++++ 6 files changed, 62 insertions(+), 18 deletions(-) create mode 100644 src/Utils.hs diff --git a/path.cabal b/path.cabal index 443c697..f923841 100644 --- a/path.cabal +++ b/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 diff --git a/src/OsPath/Internal/Include.hs b/src/OsPath/Internal/Include.hs index 765015d..0000124 100644 --- a/src/OsPath/Internal/Include.hs +++ b/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 diff --git a/src/Path/Internal/Include.hs b/src/Path/Internal/Include.hs index aa9035b..b86c085 100644 --- a/src/Path/Internal/Include.hs +++ b/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 diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 index 0000000..ec32f6d --- /dev/null +++ b/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) diff --git a/test-ospath/TH/Include.hs b/test-ospath/TH/Include.hs index 8fc564b..2d4b797 100644 --- a/test-ospath/TH/Include.hs +++ b/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))) diff --git a/test/TH/Include.hs b/test/TH/Include.hs index 3e1bf30..cff3303 100644 --- a/test/TH/Include.hs +++ b/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)))