From 782462a0486a1ef976b8e7724161d95a978cd781 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 22 Jul 2024 13:40:09 -0600 Subject: [PATCH 1/5] type to name --- ChangeLog.md | 4 ++ lift-type.cabal | 3 +- src/LiftType.hs | 175 ++++++++++++++++++++++++++++++++---------------- test/Spec.hs | 24 ++++++- 4 files changed, 147 insertions(+), 59 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 13c7031..8b10331 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for lift-typeable +## 0.1.2.0 + +- Add `typeToName`, making it possible to accurately extract a `Name` from a type. [#]() + ## 0.1.1.1 - Fix lifting the `Data.Kind.Type` into a `TemplateHaskell.Type` [#9](https://github.com/parsonsmatt/lift-type/pull/9) diff --git a/lift-type.cabal b/lift-type.cabal index eaa0eff..1b01e53 100644 --- a/lift-type.cabal +++ b/lift-type.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: lift-type -version: 0.1.1.1 +version: 0.1.2.0 description: Lift your types from a Typeable constraint to a Template Haskell type synopsis: Lift a type from a Typeable constraint to a Template Haskell type homepage: https://github.com/parsonsmatt/lift-type#readme @@ -39,4 +39,5 @@ test-suite lift-type-test base , lift-type , template-haskell + , hspec default-language: Haskell2010 diff --git a/src/LiftType.hs b/src/LiftType.hs index ca90b7b..778754d 100644 --- a/src/LiftType.hs +++ b/src/LiftType.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -32,6 +33,39 @@ import Language.Haskell.TH.Syntax import Text.Read (readMaybe) import Type.Reflection +-- | Convert a type argument into a Template Haskell 'Type'. +-- +-- Use with @TypeApplications@. +-- +-- Example: +-- +-- @ +-- >>> :set -XTypeApplications +-- >>> liftType \@Bool +-- ConT GHC.Types.Bool +-- >>> liftType \@[Char] +-- AppT (ConT GHC.Types.[]) (ConT GHC.Types.Char) +-- @ +-- +-- This works with data kinds, too. +-- +-- @ +-- >>> :set -XDataKinds +-- >>> liftType \@3 +-- LitT (NumTyLit 3) +-- >>> liftType \@"hello" +-- LitT (StrTyLit "hello") +-- >>> liftType \@'[Int, Char] +-- AppT (AppT (PromotedT GHC.Types.:) (ConT GHC.Types.Int)) (AppT (AppT (PromotedT GHC.Types.:) (ConT GHC.Types.Char)) (PromotedT GHC.Types.[])) +-- >>> liftType \@'(Int, Char) +-- AppT (AppT (PromotedT GHC.Tuple.(,)) (ConT GHC.Types.Int)) (ConT GHC.Types.Char) +-- @ +-- +-- @since 0.1.0.0 +liftType :: forall t. Typeable t => Type +liftType = + typeRepToType (SomeTypeRep (typeRep @t)) + -- | 'liftType' promoted to the 'Q' monad. -- -- @since 0.1.0.0 @@ -62,6 +96,8 @@ typeRepToType (SomeTypeRep a) = go a let tcName = tyConName tyCon + typeOrDataName = + tyConToName tyCon trySymbol = case tcName of '"' : cs -> @@ -69,72 +105,97 @@ typeRepToType (SomeTypeRep a) = go a _ -> Nothing tryTicked = - case tcName of - '\'' : dcName -> - let nameBase = - mkOccName dcName - - flavor = - NameG - DataName - (mkPkgName $ tyConPackage tyCon) - (mkModName $ tyConModule tyCon) - name = - Name - nameBase - flavor - in - Just (PromotedT name) + case typeOrDataName of + PromotedDataName name -> + Just (PromotedT name) _ -> Nothing tryNat = LitT . NumTyLit <$> readMaybe tcName plainType = - let - nameBase = - mkOccName tcName - flavor = - NameG - TcClsName - (mkPkgName $ tyConPackage tyCon) - (mkModName $ tyConModule tyCon) - name = - Name - nameBase - flavor - in - ConT name + ConT (getTypeOrDataName typeOrDataName) in fromMaybe plainType $ asum [tryTicked, trySymbol, tryNat] --- | Convert a type argument into a Template Haskell 'Type'. +-- | Extract the 'TypeOrDataName' from a 'TyCon'. You probably want to use +-- 'typeToName' instead. See that function for documentation and more +-- information. -- --- Use with @TypeApplications@. +-- @since 0.1.2.0 +tyConToName :: TyCon -> TypeOrDataName +tyConToName tyCon = + let + tcName = + tyConName tyCon + tryTicked = + case tcName of + '\'' : dcName -> + let nameBase = + mkOccName dcName + + flavor = + NameG + DataName + (mkPkgName $ tyConPackage tyCon) + (mkModName $ tyConModule tyCon) + name = + Name + nameBase + flavor + in + Just (PromotedDataName name) + _ -> + Nothing + plainType = + let + nameBase = + mkOccName tcName + flavor = + NameG + TcClsName + (mkPkgName $ tyConPackage tyCon) + (mkModName $ tyConModule tyCon) + name = + Name + nameBase + flavor + in + TypeName name + in fromMaybe plainType tryTicked + +-- | This function returns the name of the outermost type constructor. -- --- Example: +-- >>> typeToName @Char +-- TypeName ''Char +-- >>> typeToName @Maybe +-- TypeName ''Maybe +-- >>> typeToName @(Maybe Char) +-- TypeName ''Maybe +-- >>> typeToName @(Int -> Char) +-- TypeName ''(->) +-- >>> typeToName @'False +-- PromotedDataName 'False -- --- @ --- >>> :set -XTypeApplications --- >>> liftType \@Bool --- ConT GHC.Types.Bool --- >>> liftType \@[Char] --- AppT (ConT GHC.Types.[]) (ConT GHC.Types.Char) --- @ --- --- This works with data kinds, too. +-- @since 0.1.2.0 +typeToName :: forall t. Typeable t => TypeOrDataName +typeToName = tyConToName (typeRepTyCon (typeRep @t)) + +-- | It's possible to use a data constructor with a @DataKinds@ promotion. +-- This disambiguates where the name comes from. -- --- @ --- >>> :set -XDataKinds --- >>> liftType \@3 --- LitT (NumTyLit 3) --- >>> liftType \@"hello" --- LitT (StrTyLit "hello") --- >>> liftType \@'[Int, Char] --- AppT (AppT (PromotedT GHC.Types.:) (ConT GHC.Types.Int)) (AppT (AppT (PromotedT GHC.Types.:) (ConT GHC.Types.Char)) (PromotedT GHC.Types.[])) --- >>> liftType \@'(Int, Char) --- AppT (AppT (PromotedT GHC.Tuple.(,)) (ConT GHC.Types.Int)) (ConT GHC.Types.Char) --- @ +-- @since 0.1.2.0 +data TypeOrDataName + = TypeName Name + | PromotedDataName Name + deriving (Show, Eq) + +-- | Retrieve the 'Name' from a 'TypeOrDataName', forgetting how it was +-- parsed. -- --- @since 0.1.0.0 -liftType :: forall t. Typeable t => Type -liftType = - typeRepToType (SomeTypeRep (typeRep @t)) +-- @since 0.1.2.0 +getTypeOrDataName :: TypeOrDataName -> Name +getTypeOrDataName d = + case d of + TypeName n -> + n + PromotedDataName n -> + n diff --git a/test/Spec.hs b/test/Spec.hs index 0089519..c288190 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -6,6 +6,7 @@ import LiftType import Data.Proxy import Data.Kind import GHC.Exts +import Test.Hspec main :: IO () main = do @@ -24,4 +25,25 @@ main = do plainTuple = (Proxy :: Proxy $(liftTypeQ @(Int, Char))) == Proxy @(Int, Char) symbol = Proxy :: Proxy $(liftTypeQ @"hello") isTrue2 = symbol == Proxy @"hello" - putStrLn "should compile" + + hspec $ do + describe "LiftType" $ do + describe "typeToName" $ do + it "returns function arrow on functions" $ do + typeToName @(Int -> Char) `shouldBe` TypeName ''(->) + it "works on a plain type" $ do + typeToName @Char `shouldBe` TypeName ''Char + it "works on Maybe" $ do + typeToName @Maybe `shouldBe` TypeName ''Maybe + it "works on a class" $ do + typeToName @Functor `shouldBe` TypeName ''Functor + it "pulls the outermost type constructor" $ do + typeToName @(Maybe Int) `shouldBe` TypeName ''Maybe + it "works on a ticked constructor" $ do + typeToName @'False `shouldBe` PromotedDataName 'False + +assert :: String -> Bool -> IO () +assert msg cond = + if cond + then pure () + else error msg From 932ad2a31b54355fd6bd7103322fb4d971346dfb Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 22 Jul 2024 13:41:04 -0600 Subject: [PATCH 2/5] stylish haskell --- src/LiftType.hs | 1 - test/Spec.hs | 9 ++++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/LiftType.hs b/src/LiftType.hs index 778754d..02a05bb 100644 --- a/src/LiftType.hs +++ b/src/LiftType.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/test/Spec.hs b/test/Spec.hs index c288190..843b224 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,11 +1,14 @@ -{-# language MagicHash, TemplateHaskell, DataKinds, TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} module Main where -import LiftType -import Data.Proxy import Data.Kind +import Data.Proxy import GHC.Exts +import LiftType import Test.Hspec main :: IO () From 4216cfae450407076bae922f80c2b90e47583b3f Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 22 Jul 2024 13:41:23 -0600 Subject: [PATCH 3/5] changelog link --- ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 8b10331..abd07b0 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,7 +2,7 @@ ## 0.1.2.0 -- Add `typeToName`, making it possible to accurately extract a `Name` from a type. [#]() +- Add `typeToName`, making it possible to accurately extract a `Name` from a type. [#11](https://github.com/parsonsmatt/lift-type/pull/11) ## 0.1.1.1 From 6aa9aeef3e938c79f95c24c6dc23d7c2840b8dec Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 22 Jul 2024 13:42:11 -0600 Subject: [PATCH 4/5] add some more ghcs --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index bbbdfd0..a53e7f7 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -16,7 +16,7 @@ jobs: strategy: fail-fast: false matrix: - ghc: ["8.6.5", "8.8.4", "8.10.4", "9.0.2", "9.2.4", "9.4.2"] + ghc: ["8.6.5", "8.8.4", "8.10.4", "9.0.2", "9.2.4", "9.4.2", "9.6", "9.8", "9.10"] experimental: [false] include: - ghc: "latest" From 06658071f2ef6a6ea65dedeb67897b9f5a5ac45b Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 22 Jul 2024 13:57:28 -0600 Subject: [PATCH 5/5] lol ok --- lift-type.cabal | 1 + test/Spec.hs | 6 ++++++ 2 files changed, 7 insertions(+) diff --git a/lift-type.cabal b/lift-type.cabal index 1b01e53..fb89ee9 100644 --- a/lift-type.cabal +++ b/lift-type.cabal @@ -40,4 +40,5 @@ test-suite lift-type-test , lift-type , template-haskell , hspec + , ghc-prim default-language: Haskell2010 diff --git a/test/Spec.hs b/test/Spec.hs index 843b224..32b5a81 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} @@ -10,6 +11,7 @@ import Data.Proxy import GHC.Exts import LiftType import Test.Hspec +import GHC.Prim main :: IO () main = do @@ -33,7 +35,11 @@ main = do describe "LiftType" $ do describe "typeToName" $ do it "returns function arrow on functions" $ do +#if __GLASGOW_HASKELL__ >= 900 + typeToName @(Int -> Char) `shouldBe` TypeName ''GHC.Prim.FUN +#else typeToName @(Int -> Char) `shouldBe` TypeName ''(->) +#endif it "works on a plain type" $ do typeToName @Char `shouldBe` TypeName ''Char it "works on Maybe" $ do