product-isomorphic-0.0.3.3/0000755000000000000000000000000013340521761013675 5ustar0000000000000000product-isomorphic-0.0.3.3/Setup.hs0000644000000000000000000000005613340521761015332 0ustar0000000000000000import Distribution.Simple main = defaultMain product-isomorphic-0.0.3.3/product-isomorphic.cabal0000644000000000000000000000462213340521761020517 0ustar0000000000000000name: product-isomorphic version: 0.0.3.3 synopsis: Weaken applicative functor on products description: Weaken applicative functor which allows only product construction. Product constructions and deconstructions are always isomorphic. homepage: http://github.com/khibino/haskell-product-isomorphic license: BSD3 license-file: LICENSE author: Kei Hibino maintainer: ex8k.hibino@gmail.com copyright: Copyright (c) 2017 Kei Hibino category: Data build-type: Simple -- extra-source-files: cabal-version: >=1.10 tested-with: GHC == 8.4.1, GHC == 8.4.2, GHC == 8.4.3 , GHC == 8.2.1, GHC == 8.2.2 , GHC == 8.0.1, GHC == 8.0.2 , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3 , GHC == 7.4.1, GHC == 7.4.2 library exposed-modules: Data.Functor.ProductIsomorphic.Class Data.Functor.ProductIsomorphic.Instances Data.Functor.ProductIsomorphic.TupleInstances Data.Functor.ProductIsomorphic.GenericInstances Data.Functor.ProductIsomorphic.Unsafe Data.Functor.ProductIsomorphic Data.Functor.ProductIsomorphic.TH other-modules: Data.Functor.ProductIsomorphic.TH.Internal build-depends: base >=4.5 && <5 , template-haskell , th-data-compat if impl(ghc == 7.4.*) build-depends: ghc-prim == 0.2.* hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall test-suite th build-depends: base <5 , template-haskell , product-isomorphic type: exitcode-stdio-1.0 main-is: doTH.hs hs-source-dirs: test ghc-options: -Wall default-language: Haskell2010 source-repository head type: git location: https://github.com/khibino/haskell-product-isomorphic source-repository head type: mercurial location: https://bitbucket.org/khibino/haskell-product-isomorphic product-isomorphic-0.0.3.3/LICENSE0000644000000000000000000000275613340521761014714 0ustar0000000000000000Copyright (c) 2015, Kei Hibino 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 Kei Hibino 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. product-isomorphic-0.0.3.3/test/0000755000000000000000000000000013340521761014654 5ustar0000000000000000product-isomorphic-0.0.3.3/test/doTH.hs0000644000000000000000000000175513340521761016056 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} import Language.Haskell.TH (runIO) import Data.Functor.ProductIsomorphic.TH (reifyRecordType, defineProductConstructor) newtype NNormal = NNormal Int newtype NRec = NRec { _nrec :: Int } data DNormal = DNormal Int data DRec = DRec { _drec :: Int } -- expect compilation error on test failure $(mapM_ (\(tn, dn) -> do runIO . putStrLn $ "testing " ++ show (tn, dn) --- (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])) (((tq, vns), eq), (fns, ftqs)) <- reifyRecordType tn ty <- tq expr <- eq fts <- sequence ftqs runIO $ print (((ty, vns), expr), (fns, fts)) ) [(''NNormal, 'NNormal), (''NRec, 'NRec), (''DNormal, 'DNormal), (''DRec, 'DRec)] >> return []) $(defineProductConstructor ''NNormal) $(defineProductConstructor ''NRec) $(defineProductConstructor ''DNormal) $(defineProductConstructor ''DRec) main :: IO () main = return () product-isomorphic-0.0.3.3/src/0000755000000000000000000000000013340521761014464 5ustar0000000000000000product-isomorphic-0.0.3.3/src/Data/0000755000000000000000000000000013340521761015335 5ustar0000000000000000product-isomorphic-0.0.3.3/src/Data/Functor/0000755000000000000000000000000013340521761016755 5ustar0000000000000000product-isomorphic-0.0.3.3/src/Data/Functor/ProductIsomorphic.hs0000644000000000000000000000136113340521761022767 0ustar0000000000000000-- | -- Module : Data.Functor.ProductIsomorphic -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This is the integrated interface module for product restricted functors. module Data.Functor.ProductIsomorphic ( module Data.Functor.ProductIsomorphic.Unsafe, module Data.Functor.ProductIsomorphic.Class, module Data.Functor.ProductIsomorphic.Instances, ) where import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor) import Data.Functor.ProductIsomorphic.Class import Data.Functor.ProductIsomorphic.Instances import Data.Functor.ProductIsomorphic.TupleInstances () import Data.Functor.ProductIsomorphic.GenericInstances () product-isomorphic-0.0.3.3/src/Data/Functor/ProductIsomorphic/0000755000000000000000000000000013340521761022432 5ustar0000000000000000product-isomorphic-0.0.3.3/src/Data/Functor/ProductIsomorphic/TupleInstances.hs0000644000000000000000000000136313340521761025732 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Data.Functor.ProductIsomorphic.TupleInstances -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines instances of tuple types. module Data.Functor.ProductIsomorphic.TupleInstances () where import Control.Applicative ((<$>)) import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor (..)) import Data.Functor.ProductIsomorphic.TH.Internal (defineTupleProductConstructor) instance ProductConstructor () where productConstructor = () $(concat <$> mapM defineTupleProductConstructor [2..7]) product-isomorphic-0.0.3.3/src/Data/Functor/ProductIsomorphic/Class.hs0000644000000000000000000000415713340521761024042 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Data.Functor.ProductIsomorphic.Class -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines functor interfaces which morphed functions -- are restricted to products. module Data.Functor.ProductIsomorphic.Class ( -- * ProductIso classes ProductIsoFunctor (..), ProductIsoApplicative (..), ProductIsoAlternative (..), -- * Empty element ProductIsoEmpty (..), peRightR, peLeftR, --- (<|), (|>), ) where import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor) import Data.Functor.ProductIsomorphic.TupleInstances () -- | Restricted functor on products. class ProductIsoFunctor f where (|$|) :: ProductConstructor (a -> b) => (a -> b) -> f a -> f b -- | Restricted applicative functor on products. class ProductIsoFunctor f => ProductIsoApplicative f where pureP :: ProductConstructor a => a -> f a (|*|) :: f (a -> b) -> f a -> f b -- | Restricted alternative on products. class ProductIsoApplicative f => ProductIsoAlternative f where emptyP :: f a (|||) :: f a -> f a -> f a infixl 4 |$|, |*| infixl 3 ||| -- | Empty element of product operator class ProductIsoApplicative f => ProductIsoEmpty f e where pureE :: f e peRight :: f (a, e) -> f a peLeft :: f (e, a) -> f a -- | peRight and peRightR should have isomorphic law. -- @ -- peRight . peRightR == peRightR . peRight == id -- @ peRightR :: ProductIsoEmpty f e => f a -> f (a, e) peRightR p = (,) |$| p |*| pureE {-# INLINABLE peRightR #-} -- | peLeft and peLeftR should have isomorphic law. -- @ -- peLeft . peLeftR == peLeftR . peLeft == id -- @ peLeftR :: ProductIsoEmpty f e => f a -> f (e, a) peLeftR p = (,) |$| pureE |*| p {-# INLINABLE peLeftR #-} {- (<|) :: ProductIsoEmpty f e => f a -> f e -> f a p <| e = peRight $ (,) |$| p |*| e {-# INLINABLE (<|) #-} (|>) :: ProductIsoEmpty f e => f e -> f a -> f a e |> p = peLeft $ (,) |$| e |*| p {-# INLINABLE (|>) #-} infixl 4 <|, |> -} product-isomorphic-0.0.3.3/src/Data/Functor/ProductIsomorphic/Instances.hs0000644000000000000000000000573313340521761024725 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Data.Functor.ProductIsomorphic.Instances -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines functor instances morphed functions -- are restricted to products. module Data.Functor.ProductIsomorphic.Instances ( WrappedFunctor (..), WrappedAlter (..), ) where import Data.Monoid (Monoid, mempty, (<>)) import Control.Applicative ((<$>), Applicative, pure, (<*>), Alternative, empty, (<|>), Const (..)) import Data.Functor.ProductIsomorphic.Class (ProductIsoFunctor(..), ProductIsoApplicative (..), ProductIsoAlternative (..), ProductIsoEmpty (..)) instance ProductIsoFunctor (Const a) where _ |$| Const a = Const a {-# INLINABLE (|$|) #-} instance Monoid a => ProductIsoApplicative (Const a) where pureP _ = Const mempty {-# INLINABLE pureP #-} Const a |*| Const b = Const $ a <> b {-# INLINABLE (|*|) #-} instance Monoid a => ProductIsoEmpty (Const a) () where pureE = pureP () {-# INLINABLE pureE #-} peRight (Const a) = Const a {-# INLINABLE peRight #-} peLeft (Const a) = Const a {-# INLINABLE peLeft #-} -- | Wrapped functor type to make instances of product-iso functors. newtype WrappedFunctor f a = WrapFunctor { unwrapFunctor :: f a } instance Functor f => ProductIsoFunctor (WrappedFunctor f) where f |$| fa = WrapFunctor $ f <$> unwrapFunctor fa {-# INLINABLE (|$|) #-} instance Applicative f => ProductIsoApplicative (WrappedFunctor f) where pureP = WrapFunctor . pure {-# INLINABLE pureP #-} WrapFunctor ff |*| WrapFunctor fa = WrapFunctor $ ff <*> fa {-# INLINABLE (|*|) #-} instance Alternative f => ProductIsoAlternative (WrappedFunctor f) where emptyP = WrapFunctor empty {-# INLINABLE emptyP #-} WrapFunctor fa1 ||| WrapFunctor fa2 = WrapFunctor $ fa1 <|> fa2 {-# INLINABLE (|||) #-} instance Applicative f => ProductIsoEmpty (WrappedFunctor f) () where pureE = pureP () {-# INLINABLE pureE #-} peRight = WrapFunctor . fmap fst . unwrapFunctor {-# INLINABLE peRight #-} peLeft = WrapFunctor . fmap snd . unwrapFunctor {-# INLINABLE peLeft #-} -- | Wrapped Const Alternative objects to make instances like Const functor. newtype WrappedAlter f a b = WrapAlter { unWrapAlter :: Const (f a) b } instance ProductIsoFunctor (WrappedAlter f a) where _ |$| WrapAlter (Const fa) = WrapAlter $ Const fa {-# INLINABLE (|$|) #-} instance Alternative f => ProductIsoApplicative (WrappedAlter f a) where pureP _ = WrapAlter $ Const empty {-# INLINABLE pureP #-} WrapAlter (Const a) |*| WrapAlter (Const b) = WrapAlter $ Const $ a <|> b {-# INLINABLE (|*|) #-} instance Alternative f => ProductIsoEmpty (WrappedAlter f a) () where pureE = pureP () {-# INLINABLE pureE #-} peRight = WrapAlter . fmap fst . unWrapAlter {-# INLINABLE peRight #-} peLeft = WrapAlter . fmap snd . unWrapAlter product-isomorphic-0.0.3.3/src/Data/Functor/ProductIsomorphic/GenericInstances.hs0000644000000000000000000000250713340521761026216 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Functor.ProductIsomorphic.GenericInstances -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines instances for constructors used in generic-programming. module Data.Functor.ProductIsomorphic.GenericInstances () where import GHC.Generics (U1 (U1), K1 (K1), M1 (M1), (:*:) ((:*:)), ) -- import GHC.Generics (Generic, Rep, from, to, ) import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor (..)) instance ProductConstructor (U1 p) where productConstructor = U1 {-# INLINEABLE productConstructor #-} instance ProductConstructor (c -> K1 i c p) where productConstructor = K1 {-# INLINEABLE productConstructor #-} instance ProductConstructor (f p -> M1 i c f p) where productConstructor = M1 {-# INLINEABLE productConstructor #-} instance ProductConstructor (f x -> g x -> (f :*: g) x) where productConstructor = (:*:) {-# INLINEABLE productConstructor #-} {- -- why compile error? instance Generic a => ProductConstructor (a -> Rep a x) where productConstructor = from instance Generic a => ProductConstructor (Rep a x -> a) where productConstructor = to -} product-isomorphic-0.0.3.3/src/Data/Functor/ProductIsomorphic/TH.hs0000644000000000000000000000114613340521761023303 0ustar0000000000000000-- | -- Module : Data.Functor.ProductIsomorphic.TH -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module exports templates to make product constructors. module Data.Functor.ProductIsomorphic.TH ( -- * Template of ProductConstructor defineProductConstructor, defineTupleProductConstructor, -- * Low-level API to get record info reifyRecordType, ) where import Data.Functor.ProductIsomorphic.TH.Internal (defineProductConstructor, defineTupleProductConstructor, reifyRecordType, ) product-isomorphic-0.0.3.3/src/Data/Functor/ProductIsomorphic/Unsafe.hs0000644000000000000000000000075013340521761024211 0ustar0000000000000000-- | -- Module : Data.Functor.ProductIsomorphic.Unsafe -- Copyright : 2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines unsafe class interfaces. module Data.Functor.ProductIsomorphic.Unsafe ( ProductConstructor (..), ) where -- | Define product isomorphic inference rule -- to specify record constructor class ProductConstructor c where productConstructor :: c product-isomorphic-0.0.3.3/src/Data/Functor/ProductIsomorphic/TH/0000755000000000000000000000000013340521761022745 5ustar0000000000000000product-isomorphic-0.0.3.3/src/Data/Functor/ProductIsomorphic/TH/Internal.hs0000644000000000000000000000612713340521761025063 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} -- | -- Module : Data.Functor.ProductIsomorphic.TH.Internal -- Copyright : 2017-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module defines templates to make product constructors. module Data.Functor.ProductIsomorphic.TH.Internal ( defineProductConstructor, defineTupleProductConstructor, reifyRecordType, ) where import Control.Applicative ((<|>)) import Language.Haskell.TH (Q, Name, tupleTypeName, Info (..), reify, TypeQ, arrowT, appT, conT, varT, Dec, ExpQ, conE, Con (..), TyVarBndr (..), nameBase,) import Language.Haskell.TH.Compat.Data (unDataD, unNewtypeD) import Data.List (foldl') import Data.Functor.ProductIsomorphic.Unsafe (ProductConstructor (..)) recordInfo' :: Info -> Maybe (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])) recordInfo' = d where d (TyConI tcon) = do (tcn, bs, r) <- do (_cxt, tcn, bs, _mk, [r], _ds) <- unDataD tcon Just (tcn, bs, r) <|> do (_cxt, tcn, bs, _mk, r , _ds) <- unNewtypeD tcon Just (tcn, bs, r) let vns = map getTV bs case r of NormalC dcn ts -> Just (((buildT tcn vns, vns), conE dcn), (Nothing, [return t | (_, t) <- ts])) RecC dcn vts -> Just (((buildT tcn vns, vns), conE dcn), (Just ns, ts)) where (ns, ts) = unzip [(n, return t) | (n, _, t) <- vts] _ -> Nothing d _ = Nothing getTV (PlainTV n) = n getTV (KindedTV n _) = n buildT tcn vns = foldl' appT (conT tcn) [ varT vn | vn <- vns ] -- | Low-level reify interface for record type name. reifyRecordType :: Name -> Q (((TypeQ, [Name]), ExpQ), (Maybe [Name], [TypeQ])) reifyRecordType recTypeName = maybe (fail msgOnErr) return . recordInfo' =<< reify recTypeName where recTypeNameS = show recTypeName recTypeNameB = nameBase recTypeName msgOnErr = "Valid record type constructor not found: " ++ recTypeNameS ++ ".\n" ++ " Possible causes:\n" ++ " - " ++ recTypeNameB ++ " is not a type name.\n" ++ " (Type name must be prefixed with double-single-quotes: e.g. ''" ++ recTypeNameB ++ ")\n" ++ " - " ++ recTypeNameB ++ " has multiple data constructors.\n" ++ " (Currently, only types with exactly *one* data constructors are supported)\n" -- | Make template of ProductConstructor instance from type constructor name. defineProductConstructor :: Name -- ^ name of product or record type constructor -> Q [Dec] -- ^ result template defineProductConstructor tyN = do (((tyQ, _), dtQ), (_, colts)) <- reifyRecordType tyN [d| instance ProductConstructor $(foldr (appT . (arrowT `appT`)) tyQ colts) where productConstructor = $(dtQ) |] -- | Make template of ProductConstructor instance of tuple type. defineTupleProductConstructor :: Int -- ^ n-tuple -> Q [Dec] -- ^ result template defineTupleProductConstructor = defineProductConstructor . tupleTypeName