barbies-th (empty) → 0

raw patch · 6 files changed

+205/−0 lines, 6 filesdep +barbiesdep +barbies-thdep +basesetup-changed

Dependencies added: barbies, barbies-th, base, template-haskell

Files

CHANGELOG.md +5/−0
LICENSE +30/−0
Setup.hs +2/−0
barbies-th.cabal +34/−0
src/Data/Barbie/TH.hs +116/−0
tests/Main.hs +18/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for barbies-th++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ barbies-th.cabal view

@@ -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

+ src/Data/Barbie/TH.hs view

@@ -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

+ tests/Main.hs view

@@ -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 ()