lift-type 0.1.1.1 → 0.1.2.0
raw patch · 4 files changed
+159/−62 lines, 4 filesdep +ghc-primdep +hspec
Dependencies added: ghc-prim, hspec
Files
- ChangeLog.md +4/−0
- lift-type.cabal +3/−1
- src/LiftType.hs +117/−57
- test/Spec.hs +35/−4
ChangeLog.md view
@@ -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 view
@@ -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
src/LiftType.hs view
@@ -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
test/Spec.hs view
@@ -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