type to name

.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"

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. [#11](https://github.com/parsonsmatt/lift-type/pull/11)
+
 ## 0.1.1.1
 
 - Fix lifting the `Data.Kind.Type` into a `TemplateHaskell.Type` [#9](https://github.com/parsonsmatt/lift-type/pull/9)

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,6 @@ test-suite lift-type-test
       base
     , lift-type
     , template-haskell
+    , hspec
+    , ghc-prim
   default-language: Haskell2010

src/LiftType.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeInType #-}
 {-# LANGUAGE TypeOperators #-}
 
 -- | Template Haskell has a class 'Lift' that allows you to promote values
@@ -32,6 +32,39 @@
 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,79 +95,106 @@
         let
             tcName =
                 tyConName tyCon
+            typeOrDataName =
+                tyConToName tyCon
             trySymbol =
                 case tcName of
                     '"' : cs ->
                         Just $ LitT (StrTyLit (zipWith const cs (drop 1 cs)))
                     _ ->
                         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

test/Spec.hs

@@ -1,11 +1,17 @@
-{-# language MagicHash, TemplateHaskell, DataKinds, TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE CPP #-}
+{-# 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
+import GHC.Prim
 
 main :: IO ()
 main = do
@@ -24,4 +30,29 @@ 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
+#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
+                    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