lift-type 0.1.0.1 → 0.1.1.0

raw patch · 3 files changed

+85/−79 lines, 3 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• lift-type.cabal +3/−3
• src/LiftType.hs +77/−76

@@ -1,5 +1,10 @@ # Changelog for lift-typeable +## 0.1.1.0++- Cleanup and a slight performance improvement [#7](https://github.com/parsonsmatt/lift-type/pull/7)+- Implement `typeRepToType :: SomeTypeRep -> Type` [#8](https://github.com/parsonsmatt/lift-type/pull/8)+ ## 0.1.0.1  - Support GHC 8.2.2, which evidently required `TypeInType` for the `forall k (a :: k)` signature.

@@ -1,6 +1,6 @@ cabal-version: 1.12 name:           lift-type-version:        0.1.0.1+version:        0.1.1.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@@ -25,7 +25,7 @@   hs-source-dirs:       src   build-depends:-      base >=4.10 && <5+      base >= 4.10 && <5     , template-haskell   default-language: Haskell2010 @@ -36,7 +36,7 @@       test   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:-      base >=4.7 && <5+      base     , lift-type     , template-haskell   default-language: Haskell2010

@@ -1,4 +1,9 @@-{-# language TypeInType, ScopedTypeVariables, AllowAmbiguousTypes, TypeApplications, PolyKinds, TemplateHaskell #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeInType #-}  -- | Template Haskell has a class 'Lift' that allows you to promote values -- from Haskell-land into the land of metaprogramming - 'Q'.@@ -18,10 +23,13 @@ -- @since 0.1.0.0 module LiftType where -import Data.Char import Control.Applicative-import Type.Reflection+import Data.Char+import Data.Foldable (asum)+import Data.Maybe (fromMaybe) import Language.Haskell.TH.Syntax+import Text.Read (readMaybe)+import Type.Reflection  -- | 'liftType' promoted to the 'Q' monad. --@@ -29,6 +37,71 @@ liftTypeQ :: forall t. Typeable t => Q Type liftTypeQ = pure $ liftType @t +-- | Promote a 'SomeTypeRep' into a 'Type'.+--+-- @since 0.1.1.0+typeRepToType :: SomeTypeRep -> Type+typeRepToType (SomeTypeRep a) = go a+  where+    go :: forall k (a :: k). TypeRep a -> Type+    go tr =+        case tr of+            Con tyCon ->+                mk tyCon+            Fun trA trB ->+                ConT ''(->) `AppT` go trA `AppT` go trB+            App trA trB ->+                AppT (go trA) (go trB)++    mk :: TyCon -> Type+    mk tyCon =+        let+            tcName =+                tyConName 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)+                    _ ->+                        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+        in fromMaybe plainType $ asum [tryTicked, trySymbol, tryNat]+ -- | Convert a type argument into a Template Haskell 'Type'. -- -- Use with @TypeApplications@.@@ -60,76 +133,4 @@ -- @since 0.1.0.0 liftType :: forall t. Typeable t => Type liftType =-    go (typeRep @t)-  where-    go :: forall k (a :: k). TypeRep a -> Type-    go tr =-        case tr of-            Con tyCon ->-                mk tyCon-            App trA trB ->-                AppT (go trA) (go trB)-            Fun trA trB ->-                ConT ''(->) `AppT` go trA `AppT` go trB--    mk :: TyCon -> Type-    mk tyCon =-        let-            tcName =-                tyConName tyCon-        in-            if hasTick tcName-            then-                let-                    nameBase =-                        mkOccName (drop 1 tcName)-                    flavor =-                        NameG-                            DataName-                            (mkPkgName $ tyConPackage tyCon)-                            (mkModName $ tyConModule tyCon)-                    name =-                        Name-                            nameBase-                            flavor-                in-                    PromotedT name-            else if hasDigit tcName then-                LitT (NumTyLit (read tcName))-            else if hasQuote tcName then-                LitT (StrTyLit (stripQuotes tcName))-            else-                let-                    nameBase =-                        mkOccName tcName-                    flavor =-                        NameG-                            TcClsName-                            (mkPkgName $ tyConPackage tyCon)-                            (mkModName $ tyConModule tyCon)-                    name =-                        Name-                            nameBase-                            flavor-                in-                    ConT name--    stripQuotes xs =-        case xs of-            [] ->-                []-            ('"' : rest) ->-                reverse (stripQuotes (reverse rest))-            _ ->-                xs-    hasTick = prefixSatisfying ('\'' ==)-    hasDigit = prefixSatisfying isDigit-    hasQuote = prefixSatisfying ('"' ==)-    isList = ("'[]" ==)-    prefixSatisfying :: (Char -> Bool) -> [Char] -> Bool-    prefixSatisfying p xs =-        case xs of-            a : _ ->-                p a-            _ ->-                False+    typeRepToType (SomeTypeRep (typeRep @t))