diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for barbies-th + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Fumiaki Kinoshita (c) 2019 + +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 Fumiaki Kinoshita 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/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/barbies-th.cabal b/barbies-th.cabal new file mode 100644 --- /dev/null +++ b/barbies-th.cabal @@ -0,0 +1,34 @@ +cabal-version: 2.4 +name: barbies-th +version: 0 +synopsis: Create strippable HKD via TH +description: Please see Data.Barbie.TH +bug-reports: https://github.com/fumieval/barbies-th +license: BSD-3-Clause +license-file: LICENSE +author: Fumiaki Kinoshita +maintainer: fumiexcel@gmail.com +copyright: Copyright (c) 2019 Fumiaki Kinoshita +category: Data, Generics +extra-source-files: CHANGELOG.md + +library + exposed-modules: Data.Barbie.TH + other-extensions: RankNTypes, PolyKinds, DataKinds, KindSignatures, TemplateHaskell, TypeFamilies + build-depends: base >= 4.12 + , template-haskell >= 2.14 && <2.16 + , barbies + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +test-suite th + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + tests + build-depends: + base >=4.7 && <5 + , barbies + , barbies-th + default-language: Haskell2010 diff --git a/src/Data/Barbie/TH.hs b/src/Data/Barbie/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Barbie/TH.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Data.Barbie.TH (FieldNamesB(..) + , declareBareB + ) where + +import Language.Haskell.TH hiding (cxt) +import Language.Haskell.TH.Syntax (VarBangType) +import Data.String +import Data.Foldable (foldl') +import Data.Barbie +import Data.Barbie.Bare +import Data.Functor.Product +import GHC.Generics (Generic) +import Control.Applicative +import Data.Functor.Identity (Identity(..)) + +-- | barbies doesn't care about field names, but they are useful in many use cases +class FieldNamesB b where + -- | A collection of field names. + bfieldNames :: IsString a => b (Const a) + +-- | Transform a regular Haskell record declaration into HKD form. +-- 'BareB', 'FieldNamesB', 'FunctorB', 'TraversableB', 'ProductB', +-- 'ConstraintsB' and 'ProductBC' instances are derived. +-- +-- For example, +-- +-- @declareBareB [d|data User = User { uid :: Int, name :: String}|]@ +-- +-- becomes +-- +-- @data User t f = User { uid :: Wear t f Int, name :: Wear t f String }@ +-- +declareBareB :: DecsQ -> DecsQ +declareBareB decsQ = do + decs <- decsQ + decs' <- traverse go decs + return $ concat decs' + where + go (DataD _ dataName tvbs _ [con@(RecC conName fields)] drv) = do + varS <- newName "sw" + varW <- newName "h" + let xs = varNames "x" fields + let ys = varNames "y" fields + let transformed = transformCon varS varW con + let names = foldl' AppE (ConE conName) [AppE (ConE 'Const) $ AppE (VarE 'fromString) $ LitE $ StringL $ nameBase name | (name, _, _) <- fields] + let datC = conT dataName `appT` conT ''Covered + decs <- [d| + instance BareB $(conT dataName) where + bcover $(conP conName $ map varP xs) = $(foldl' + appE + (conE conName) + (appE (conE 'Identity) . varE <$> xs) + ) + {-# INLINE bcover #-} + bstrip $(conP conName $ map varP xs) = $(foldl' + appE + (conE conName) + (appE (varE 'runIdentity) . varE <$> xs) + ) + {-# INLINE bstrip #-} + instance FieldNamesB $(datC) where bfieldNames = $(pure names) + instance FunctorB $(datC) where + bmap f $(conP conName $ map varP xs) = $(foldl' + appE + (conE conName) + (appE (varE 'f) . varE <$> xs) + ) + instance TraversableB $(datC) where + btraverse f $(conP conName $ map varP xs) = $(fst $ foldl' + (\(l, op) r -> (infixE (Just l) (varE op) (Just r), '(<*>))) + (conE conName, '(<$>)) + (appE (varE 'f) . varE <$> xs) + ) + {-# INLINE btraverse #-} + instance ConstraintsB $(datC) + instance ProductBC $(datC) + instance ProductB $(datC) where + bprod $(conP conName $ map varP xs) $(conP conName $ map varP ys) = $(foldl' + (\r (x, y) -> [|$(r) (Pair $(varE x) $(varE y))|]) + (conE conName) (zip xs ys)) + |] + return $ DataD [] dataName + (tvbs ++ [PlainTV varS, PlainTV varW]) + Nothing + [transformed] + (DerivClause Nothing [ConT ''Generic] : drv) + : decs + go d = pure [d] + +varNames :: String -> [VarBangType] -> [Name] +varNames p vbt = [mkName (p ++ nameBase v) | (v, _, _) <- vbt] + +transformCon :: Name -- ^ switch variable + -> Name -- ^ wrapper variable + -> Con -- ^ original constructor + -> Con +transformCon switchName wrapperName (RecC name xs) = RecC name + [(v, b, ConT ''Wear + `AppT` VarT switchName + `AppT` VarT wrapperName + `AppT` t) + | (v, b, t) <- xs + ] +transformCon var w (ForallC tvbs cxt con) = ForallC tvbs cxt $ transformCon var w con +transformCon _ _ con = error $ "transformCon: unsupported " ++ show con diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS -ddump-splices #-} +module Main where +import Data.Barbie.TH +import GHC.Generics +import Data.Barbie +import Data.Barbie.Bare +declareBareB [d| + data Foo = Foo + { foo :: Int + , bar :: String + } |] +main = pure ()