lift-type (empty) → 0.1.0.0
raw patch · 7 files changed
+235/−0 lines, 7 filesdep +basedep +lift-typedep +template-haskellsetup-changed
Dependencies added: base, lift-type, template-haskell
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +3/−0
- Setup.hs +2/−0
- lift-type.cabal +41/−0
- src/LiftType.hs +135/−0
- test/Spec.hs +21/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for lift-typeable++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,3 @@+# lift-type++This library provides a utility function `liftType` which accepts a type application argument and returns the `Template Haskell` `Type` representation of it.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lift-type.cabal view
@@ -0,0 +1,41 @@+cabal-version: 1.12+name: lift-type+version: 0.1.0.0+description: Please see the README on GitHub at <https://github.com/githubuser/lift-type#readme>+homepage: https://github.com/parsonsmatt/lift-type#readme+bug-reports: https://github.com/parsonsmatt/lift-type/issues+author: Matt Parsons+maintainer: parsonsmatt@gmail.com+copyright: 2021 Matt Parsons+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/parsonsmatt/lift-type++library+ exposed-modules:+ LiftType+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , template-haskell+ default-language: Haskell2010++test-suite lift-type-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , lift-type+ , template-haskell+ default-language: Haskell2010
+ src/LiftType.hs view
@@ -0,0 +1,135 @@+{-# language ScopedTypeVariables, AllowAmbiguousTypes, TypeApplications, PolyKinds, TemplateHaskell #-}++-- | Template Haskell has a class 'Lift' that allows you to promote values+-- from Haskell-land into the land of metaprogramming - 'Q'.+--+-- @+-- class 'Lift' a where+-- 'lift' :: a -> 'Q' 'Exp'+--+-- 'liftTyped' :: a -> 'Q' ('TExp' a)+-- @+--+-- However, there wasn't a way to promote a *type* into a @'Q' 'Type'@.+--+-- This library provides exactly that function. It requires a 'Typeable'+-- constraint, but this is automatically satisfied by GHC.+--+-- @since 0.1.0.0+module LiftType where++import Data.Char+import Control.Applicative+import Type.Reflection+import Language.Haskell.TH.Syntax++-- | 'liftType' promoted to the 'Q' monad.+--+-- @since 0.1.0.0+liftTypeQ :: forall t. Typeable t => Q Type+liftTypeQ = pure $ liftType @t++-- | 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 =+ 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
+ test/Spec.hs view
@@ -0,0 +1,21 @@+{-# language TemplateHaskell, DataKinds, TypeApplications #-}+module Main where++import LiftType+import Data.Proxy++main :: IO ()+main = do+ let+ bool = Proxy :: Proxy $(liftTypeQ @Bool)+ true = Proxy :: Proxy $(liftTypeQ @'True)+ three = Proxy :: Proxy $(liftTypeQ @3)+ valList = Proxy :: Proxy $(liftTypeQ @[Char])+ isTrue = valList == Proxy @[Char]+ list = Proxy :: Proxy $(liftTypeQ @'[Int, Char])+ tuple = Proxy :: Proxy $(liftTypeQ @'(Int, Char))+ isTrueTuple = tuple == Proxy @'(Int, Char)+ plainTuple = (Proxy :: Proxy $(liftTypeQ @(Int, Char))) == Proxy @(Int, Char)+ symbol = Proxy :: Proxy $(liftTypeQ @"hello")+ isTrue2 = symbol == Proxy @"hello"+ putStrLn "should compile"