diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for lift-typeable + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lift-type.cabal b/lift-type.cabal new file mode 100644 --- /dev/null +++ b/lift-type.cabal @@ -0,0 +1,41 @@ +cabal-version: 1.12 +name: lift-type +version: 0.1.0.0 +description: Please see the README on GitHub at +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 diff --git a/src/LiftType.hs b/src/LiftType.hs new file mode 100644 --- /dev/null +++ b/src/LiftType.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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"