diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ +## 0.1 +* Initial commit diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Ryan Scott + +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 Ryan Scott 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,20 @@ +# `lift-generics` + +[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] +[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] +[![Build](https://img.shields.io/travis/RyanGlScott/lift-generics.svg)](https://travis-ci.org/RyanGlScott/lift-generics) + +[Haskell.org]: + http://www.haskell.org + "The Haskell Programming Language" +[tl;dr Legal: BSD3]: + https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 + "BSD 3-Clause License (Revised)" + +This package provides a `GHC.Generics`-based `genericLiftWithPkg` function (intended for GHC 7.10 and earlier), as well as a `genericLift` function (only available on GHC 8.0 and later), both of which can be used for providing a `Language.Haskell.TH.Syntax.lift` implementation. See the documentation in the `Language.Haskell.TH.Lift.Generics` module to get started. + +Credit goes to Matthew Pickering for [suggesting this idea](https://ghc.haskell.org/trac/ghc/ticket/1830#comment:12). + +Note that due to API limitations, `GHC.Generics` wasn't powerful enough to come up with the entirety of a `lift` implementation prior to GHC 8.0. For this reason, `genericLiftWithPkg` requires you to produce the package name yourself, which proves to be no small feat (see the documentation for more info). + +Luckily, you don't have to jump through as many hoops on GHC 8.0 and later: simply use the `genericLift` function, and life is good. 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-generics.cabal b/lift-generics.cabal new file mode 100644 --- /dev/null +++ b/lift-generics.cabal @@ -0,0 +1,64 @@ +name: lift-generics +version: 0.1 +synopsis: GHC.Generics-based Language.Haskell.TH.Syntax.lift implementation +description: This package provides a "GHC.Generics"-based @genericLiftWithPkg@ + function (intended for GHC 7.10 and earlier), as well as a + @genericLift@ function (only available on GHC 8.0 and later), + both of which can be used for providing a + @Language.Haskell.TH.Syntax.lift@ implementation. See the + documentation in the "Language.Haskell.TH.Lift.Generics" module + to get started. + . + Credit goes to Matthew Pickering for + . + . + Note that due to API limitations, "GHC.Generics" wasn't powerful + enough to come up with the entirety of a `lift` implementation prior + to GHC 8.0. For this reason, @genericLiftWithPkg@ requires you to + produce the package name yourself, which proves to be no small feat + (see the documentation for more info). + . + Luckily, you don't have to jump through as many hoops on GHC 8.0 and + later: simply use the @genericLift@ function, and life is good. +homepage: https://github.com/RyanGlScott/lift-generics +bug-reports: https://github.com/RyanGlScott/lift-generics/issues +license: BSD3 +license-file: LICENSE +author: Ryan Scott +maintainer: Ryan Scott +stability: Experimental +copyright: (C) 2015 Ryan Scott +category: Language +build-type: Simple +extra-source-files: CHANGELOG.md, README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/RyanGlScott/lift-generics + +library + exposed-modules: Language.Haskell.TH.Lift.Generics + build-depends: base >= 4.3 && < 5 + , generic-deriving >= 1.9 && < 2 + , ghc-prim + , template-haskell >= 2.4 && < 2.12 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: LiftGenericsSpec + Types + Paths_lift_generics + build-depends: base >= 4.3 && < 5 + , base-compat >= 0.8.2 && < 1 + , generic-deriving >= 1.9 && < 2 + , hspec >= 2 && < 3 + , lift-generics == 0.1 + , template-haskell >= 2.4 && < 2.12 + hs-source-dirs: tests + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts diff --git a/src/Language/Haskell/TH/Lift/Generics.hs b/src/Language/Haskell/TH/Lift/Generics.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/Lift/Generics.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-| +Module: Language.Haskell.TH.Lift.Generics +Copyright: (C) 2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott + +"GHC.Generics"-based approach to implementing `lift`. +-} +module Language.Haskell.TH.Lift.Generics ( + genericLiftWithPkg +#if __GLASGOW_HASKELL__ >= 711 + , genericLift +#endif + , GLift(..) + , GLiftDatatype(..) + , GLiftArgs(..) + -- * 'Lift' reexport + , Lift(..) + ) where + +#if MIN_VERSION_template_haskell(2,8,0) +import Data.Char (ord) +import Data.Word (Word8) +#endif + +import Generics.Deriving + +import GHC.Base (unpackCString#) +import GHC.Exts + +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +#undef CURRENT_PACKAGE_KEY +-- | "GHC.Generics"-based 'lift' implementation. +-- +-- API limitations of early versions of GHC (7.10 and earlier) require the user +-- to produce the package name themselves. This isn't as easy to come up with as +-- it sounds, because GHC 7.10 uses a hashed package ID for a name. To make things +-- worse, if you produce the wrong package name, you might get bizarre compilation +-- errors! +-- +-- There's no need to fear, though—the code sample below shows an example of how to +-- properly use 'genericLiftWithPkg' without shooting yourself in the foot: +-- +-- @ +-- {-# LANGUAGE CPP, DeriveGeneric #-} +-- -- part of package foobar +-- module Foo where +-- +-- import GHC.Generics +-- import Language.Haskell.Lift.Generics +-- +-- #ifndef CURRENT_PACKAGE_KEY +-- import Data.Version (showVersion) +-- import Paths_foobar (version) +-- #endif +-- +-- pkgName :: String +-- #ifdef CURRENT_PACKAGE_KEY +-- pkgName = CURRENT_PACKAGE_KEY +-- #else +-- pkgName = "foobar-" ++ showVersion version +-- #endif +-- +-- data Foo = Foo Int Char String +-- deriving Generic +-- +-- instance Lift Foo where +-- lift = genericLiftWithPkg pkgName +-- @ +-- +-- As you can see, this trick only works if (1) the current package key is known +-- (i.e., the 'Lift' instance is defined in the same package as the datatype), or +-- (2) you're dealing with a package that has a fixed package name (e.g., @base@, +-- @ghc-prim@, @template-haskell@, etc.). +-- +-- Once the @Lift Foo@ instance is defined, you can splice @Foo@ values directly +-- into Haskell source code: +-- +-- @ +-- {-# LANGUAGE TemplateHaskell #-} +-- module Bar where +-- +-- import Foo +-- import Language.Haskell.TH.Syntax +-- +-- foo :: Foo +-- foo = $(lift (Foo 1 'a' "baz")) +-- @ +genericLiftWithPkg :: (Generic a, GLift (Rep a)) => String -> a -> Q Exp +genericLiftWithPkg pkg = glift pkg . from + +#if __GLASGOW_HASKELL__ >= 711 +-- | "GHC.Generics"-based 'lift' implementation. Only available on GHC 8.0 and later +-- due to API limitations of earlier GHC versions. +-- +-- Unlike 'genericLiftWithPkg', this function does all of the work for you: +-- +-- @ +-- {-# LANGUAGE DeriveGeneric #-} +-- module Foo where +-- +-- import GHC.Generics +-- import Language.Haskell.Lift.Generics +-- +-- data Foo = Foo Int Char String +-- deriving Generic +-- +-- instance Lift Foo where +-- lift = genericLift +-- @ +-- +-- Now you can splice @Foo@ values directly into Haskell source code: +-- +-- @ +-- {-# LANGUAGE TemplateHaskell #-} +-- module Bar where +-- +-- import Foo +-- import Language.Haskell.TH.Syntax +-- +-- foo :: Foo +-- foo = $(lift (Foo 1 'a' "baz")) +-- @ +genericLift :: (Generic a, GLift (Rep a)) => a -> Q Exp +genericLift = glift "" . from +#endif + +-- | Class of generic representation types which can be converted to Template +-- Haskell expressions. You shouldn't need to use this typeclass directly; it is +-- only exported for educational purposes. +class GLift f where + glift :: String -- ^ The package name (not used on GHC 8.0 and later) + -> f a -- ^ The generic value + -> Q Exp -- ^ The resulting Template Haskell expression + +instance (Datatype d, GLiftDatatype f) => GLift (D1 d f) where + glift _pkg d@(M1 x) = gliftWith pName mName x + where + pName, mName :: String +#if __GLASGOW_HASKELL__ >= 711 + pName = packageName d +#else + pName = _pkg +#endif + mName = moduleName d + +-- | Class of generic representation types which can be converted to Template +-- Haskell expressions, given a package and module name. You shouldn't need to use +-- this typeclass directly; it is only exported for educational purposes. +class GLiftDatatype f where + gliftWith :: String -- ^ The package name + -> String -- ^ The module name + -> f a -- ^ The generic value + -> Q Exp -- ^ The resulting Template Haskell expression + +instance (Constructor c, GLiftArgs f) => GLiftDatatype (C1 c f) where + gliftWith pName mName c@(M1 x) = + appsE (conE (mkNameG_d pName mName cName) : gliftArgs x) + where + cName :: String + cName = conName c + +instance (GLiftDatatype f, GLiftDatatype g) => GLiftDatatype (f :+: g) where + gliftWith pName mName (L1 l) = gliftWith pName mName l + gliftWith pName mName (R1 r) = gliftWith pName mName r + +-- | Class of generic representation types which can be converted to a list of +-- Template Haskell expressions (which represent a constructors' arguments). You +-- shouldn't need to use this typeclass directly; it is only exported for educational +-- purposes. +class GLiftArgs f where + gliftArgs :: f a -> [Q Exp] + +instance GLiftArgs U1 where + gliftArgs U1 = [] + +instance Lift c => GLiftArgs (K1 i c) where + gliftArgs (K1 x) = [lift x] + +instance GLiftArgs f => GLiftArgs (S1 s f) where + gliftArgs (M1 x) = gliftArgs x + +instance (GLiftArgs f, GLiftArgs g) => GLiftArgs (f :*: g) where + gliftArgs (f :*: g) = gliftArgs f ++ gliftArgs g + +instance GLiftArgs UAddr where + gliftArgs (UAddr a) = [litE (stringPrimL (word8ify (unpackCString# a)))] + where +#if MIN_VERSION_template_haskell(2,8,0) + word8ify :: String -> [Word8] + word8ify = map (fromIntegral . ord) +#else + word8ify :: String -> String + word8ify = id +#endif + +#if MIN_VERSION_template_haskell(2,11,0) +instance GLiftArgs UChar where + gliftArgs (UChar c) = [litE (charPrimL (C# c))] +#endif + +instance GLiftArgs UDouble where + gliftArgs (UDouble d) = [litE (doublePrimL (toRational (D# d)))] + +instance GLiftArgs UFloat where + gliftArgs (UFloat f) = [litE (floatPrimL (toRational (F# f)))] + +instance GLiftArgs UInt where + gliftArgs (UInt i) = [litE (intPrimL (toInteger (I# i)))] + +instance GLiftArgs UWord where + gliftArgs (UWord w) = [litE (wordPrimL (toInteger (W# w)))] diff --git a/tests/LiftGenericsSpec.hs b/tests/LiftGenericsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/LiftGenericsSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module: LiftGenericsSpec +Copyright: (C) 2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott + +@hspec@ tests for `lift-generics`. +-} +module LiftGenericsSpec (main, spec) where + +import Language.Haskell.TH.Syntax (lift) +import Test.Hspec (Spec, hspec, describe, it, parallel, shouldBe) +import Types (Unit(..), p, s, u) + +main :: IO () +main = hspec spec + +description :: String +description = "should equal its lifted counterpart" + +spec :: Spec +-- spec = return () +spec = parallel $ do + describe "Unit" $ + it description $ + Unit `shouldBe` $(lift Unit) + describe "Product" $ + it description $ + p `shouldBe` $(lift p) + describe "Sum" $ + it description $ + s `shouldBe` $(lift s) + describe "Unboxed" $ + it description $ + u `shouldBe` $(lift u) diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/Types.hs b/tests/Types.hs new file mode 100644 --- /dev/null +++ b/tests/Types.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module: Types +Copyright: (C) 2015 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott + +Data types for testing `lift-generics`' capabilities. +-} +module Types (Unit(..), Product(..), Sum(..), p, s, u) where + +import Generics.Deriving.TH (deriveAll) + +import GHC.Exts + +import Language.Haskell.TH.Lift.Generics (genericLiftWithPkg) +import Language.Haskell.TH.Syntax (Lift(..)) + +import Prelude () +import Prelude.Compat + +data Unit = Unit + deriving (Eq, Ord, Show) +data Product a b c d = Product a b c d + deriving (Eq, Ord, Show) +data Sum a b = Inl a | Inr b + deriving (Eq, Ord, Show) +data Unboxed a + = Unboxed a +#if MIN_VERSION_template_haskell(2,11,0) + Char# +#endif + Double# + Float# + Int# + Word# + deriving (Eq, Ord, Show) + +p :: Product Char Int Bool String +p = Product 'a' 1 True "b" + +s :: Sum Char Int +s = Inl 'c' + +u :: Unboxed Int +u = Unboxed 1 +#if MIN_VERSION_template_haskell(2,11,0) + '1'# +#endif + 1.0## + 1.0# + 1# + 1## + +pkgKey :: String +pkgKey = "main" + +instance Lift Unit where + lift = genericLiftWithPkg pkgKey + +instance (Lift a, Lift b, Lift c, Lift d) => Lift (Product a b c d) where + lift = genericLiftWithPkg pkgKey + +instance (Lift a, Lift b) => Lift (Sum a b) where + lift = genericLiftWithPkg pkgKey + +instance Lift a => Lift (Unboxed a) where + lift = genericLiftWithPkg pkgKey + +$(deriveAll ''Unit) +$(deriveAll ''Product) +$(deriveAll ''Sum) +$(deriveAll ''Unboxed)