diff --git a/ChangeLog.md b/ChangeLog.md --- 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. [#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) diff --git a/lift-type.cabal b/lift-type.cabal --- 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,6 @@ base , lift-type , template-haskell + , hspec + , ghc-prim default-language: Haskell2010 diff --git a/src/LiftType.hs b/src/LiftType.hs --- a/src/LiftType.hs +++ b/src/LiftType.hs @@ -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,6 +95,8 @@ let tcName = tyConName tyCon + typeOrDataName = + tyConToName tyCon trySymbol = case tcName of '"' : cs -> @@ -69,72 +104,97 @@ _ -> 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'. --- --- Use with @TypeApplications@. +-- | Extract the 'TypeOrDataName' from a 'TyCon'. You probably want to use +-- 'typeToName' instead. See that function for documentation and more +-- information. -- --- Example: +-- @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. -- --- @ --- >>> :set -XTypeApplications --- >>> liftType \@Bool --- ConT GHC.Types.Bool --- >>> liftType \@[Char] --- AppT (ConT GHC.Types.[]) (ConT GHC.Types.Char) --- @ +-- >>> typeToName @Char +-- TypeName ''Char +-- >>> typeToName @Maybe +-- TypeName ''Maybe +-- >>> typeToName @(Maybe Char) +-- TypeName ''Maybe +-- >>> typeToName @(Int -> Char) +-- TypeName ''(->) +-- >>> typeToName @'False +-- PromotedDataName 'False -- --- 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 --- a/test/Spec.hs +++ b/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 @@ 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