diff --git a/functor-infix.cabal b/functor-infix.cabal --- a/functor-infix.cabal +++ b/functor-infix.cabal @@ -1,7 +1,7 @@ name: functor-infix version: - 0.0.1 + 0.0.2 synopsis: Compositions of functors. homepage: @@ -26,14 +26,11 @@ Data.Functor.Infix other-modules: Data.Functor.Infix.Definitions, - Data.Functor.Infix.TH, - Data.Functor.Infix.Utilities + Data.Functor.Infix.TH build-depends: - base == 4.*, - template-haskell >= 2.8 && < 3.0 + base >= 4.7 && < 4.9, + template-haskell >= 2.8 && < 2.11 hs-source-dirs: src default-language: Haskell2010 - ghc-options: - -Wall -fno-warn-name-shadowing diff --git a/src/Data/Functor/Infix.hs b/src/Data/Functor/Infix.hs --- a/src/Data/Functor/Infix.hs +++ b/src/Data/Functor/Infix.hs @@ -1,6 +1,6 @@ -module Data.Functor.Infix ( - module Data.Functor.Infix.TH, - module Data.Functor.Infix.Definitions +module Data.Functor.Infix +( module Data.Functor.Infix.Definitions +, module Data.Functor.Infix.TH ) where import Data.Functor.Infix.TH diff --git a/src/Data/Functor/Infix/Definitions.hs b/src/Data/Functor/Infix/Definitions.hs --- a/src/Data/Functor/Infix/Definitions.hs +++ b/src/Data/Functor/Infix/Definitions.hs @@ -2,8 +2,8 @@ module Data.Functor.Infix.Definitions where -import Data.Functor.Infix.TH (declareInfixFmapN, declareInfixPamfN) -import Data.Functor.Infix.Utilities (concatMapM) +import Control.Monad (msum) +import Data.Functor.Infix.TH (declareInfixFmapForFunctorCompositionOfDegree, declareFlippedInfixFmapForFunctorCompositionOfDegree) -$(concatMapM declareInfixFmapN [1..20]) -$(concatMapM declareInfixPamfN [1..20]) +$(fmap msum $ mapM declareInfixFmapForFunctorCompositionOfDegree [1..20]) +$(fmap msum $ mapM declareFlippedInfixFmapForFunctorCompositionOfDegree [1..20]) diff --git a/src/Data/Functor/Infix/TH.hs b/src/Data/Functor/Infix/TH.hs --- a/src/Data/Functor/Infix/TH.hs +++ b/src/Data/Functor/Infix/TH.hs @@ -1,44 +1,70 @@ -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PatternSynonyms #-} -module Data.Functor.Infix.TH ( - declareInfixFmapN, - declareInfixPamfN +module Data.Functor.Infix.TH +( declareInfixFmapForFunctorCompositionOfDegree +, declareFlippedInfixFmapForFunctorCompositionOfDegree +, declareInfixFmapN +, declareInfixPamfN ) where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative ((<$>), (<*>), pure) import Control.Monad (replicateM) import Language.Haskell.TH (Q, Exp(..), Type(..), Dec(..), Pat(..), TyVarBndr(..), Pred(..), Body(..), newName, mkName, Fixity(..), FixityDirection(..)) -declareInfixFmapN :: Int -> Q [Dec] -declareInfixFmapN = declareInfixN fmapExpN fmapTypeN (Fixity 4 InfixL) '$' +(~>) :: Type -> Type -> Type +x ~> y = AppT ArrowT x `AppT` y +infixr 0 ~> -fmapExpN :: Int -> Q Exp -fmapExpN n = do - (idt, fmp) <- (,) <$> [|id|] <*> [|fmap|] - return $ foldr (AppE . AppE fmp) idt (replicate n fmp) +fmapTypeOfDegree :: Int -> Q Type +fmapTypeOfDegree n = do + names@(a:b:fs) <- (mkName "a":) <$> (mkName "b":) <$> replicateM n (newName "f") + let variables = map PlainTV names +#if MIN_VERSION_template_haskell(2,10,0) + constraints = AppT (ConT $ mkName "Functor") . VarT <$> fs +#else + constraints = map (ClassP (mkName "Functor") . pure . VarT) fs +#endif + wrap hask = foldr AppT (VarT hask) $ map VarT fs + type_ = (VarT a ~> VarT b) ~> wrap a ~> wrap b + pure $ ForallT variables constraints type_ -fmapTypeN :: Int -> Q Type -fmapTypeN n = do - (varsAB, varsFu) <- ([mkName "a", mkName "b"],) <$> replicateM n (newName "f") - let vrs = PlainTV <$> varsAB ++ varsFu - cns = ClassP (mkName "Functor") . return . VarT <$> varsFu - wrp = \n -> foldr AppT (VarT n) $ VarT <$> varsFu - typ = AppT (AppT ArrowT (AppT (AppT ArrowT (VarT $ varsAB!!0)) (VarT $ varsAB!!1))) (AppT (AppT ArrowT . wrp $ varsAB!!0) (wrp $ varsAB!!1)) - return $ ForallT vrs cns typ +fmapExpressionOfDegree :: Int -> Q Exp +fmapExpressionOfDegree n = do + (id_, fmap_) <- (,) <$> [|id|] <*> [|fmap|] + pure $ foldr (AppE . AppE fmap_) id_ (replicate n fmap_) -declareInfixPamfN :: Int -> Q [Dec] -declareInfixPamfN = declareInfixN pamfExpN pamfTypeN (Fixity 1 InfixL) '&' +declareInfixWithDegree :: (Int -> Q Exp) -> (Int -> Q Type) -> Fixity -> Char -> (Int -> Q [Dec]) +declareInfixWithDegree expressionOfDegree typeOfDegree fixity symbol n = do + let name = mkName $ "<" ++ replicate n symbol ++ ">" + (expression, type_) <- (,) <$> expressionOfDegree n <*> typeOfDegree n + pure $ SigD name type_ + : ValD (VarP name) (NormalB expression) [] + : InfixD fixity name + : [] -pamfExpN :: Int -> Q Exp -pamfExpN n = [|flip|] >>= \flip -> AppE flip <$> fmapExpN n +declareInfixFmapForFunctorCompositionOfDegree :: Int -> Q [Dec] +declareInfixFmapForFunctorCompositionOfDegree = declareInfixWithDegree fmapExpressionOfDegree fmapTypeOfDegree (Fixity 4 InfixL) '$' -pamfTypeN :: Int -> Q Type -pamfTypeN n = fmapTypeN n >>= \(ForallT crs wrp (AppT (AppT ArrowT ab) (AppT (AppT ArrowT x) y))) -> - return $ ForallT crs wrp (AppT (AppT ArrowT x) (AppT (AppT ArrowT ab) y)) +pattern x :> y = AppT ArrowT x `AppT` y -declareInfixN :: (Int -> Q Exp) -> (Int -> Q Type) -> Fixity -> Char -> Int -> Q [Dec] -declareInfixN expN typN fixity chr n = do - let name = mkName $ "<" ++ replicate n chr ++ ">" - (exp, typ) <- (,) <$> expN n <*> typN n - return [SigD name typ, ValD (VarP name) (NormalB exp) [], InfixD fixity name] +(<$$>) :: Functor f => Functor g => (a -> b) -> f (g a) -> f (g b) +(<$$>) = fmap fmap fmap +infixl 1 <$$> + +declareFlippedInfixFmapForFunctorCompositionOfDegree :: Int -> Q [Dec] +declareFlippedInfixFmapForFunctorCompositionOfDegree = do + let flipExpression = AppE $ VarE (mkName "flip") + flipType (ForallT variables constraints (a :> (b :> c))) = ForallT variables constraints (b ~> (a ~> c)) + flipType _ = error "The impossible happened!" + declareInfixWithDegree (flipExpression <$$> fmapExpressionOfDegree) (flipType <$$> fmapTypeOfDegree) (Fixity 1 InfixL) '&' + +{-# DEPRECATED declareInfixFmapN "Use 'declareInfixFmapForFunctorCompositionOfDegree' and/or reconsider your life choices." #-} +declareInfixFmapN :: Int -> Q [Dec] +declareInfixFmapN = declareInfixFmapForFunctorCompositionOfDegree + +{-# DEPRECATED declareInfixPamfN "Use 'declareFlippedInfixFmapForFunctorCompositionOfDegree' and/or reconsider your life choices." #-} +declareInfixPamfN :: Int -> Q [Dec] +declareInfixPamfN = declareFlippedInfixFmapForFunctorCompositionOfDegree diff --git a/src/Data/Functor/Infix/Utilities.hs b/src/Data/Functor/Infix/Utilities.hs deleted file mode 100644 --- a/src/Data/Functor/Infix/Utilities.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Data.Functor.Infix.Utilities (concatMapM) where - -import Data.Monoid (Monoid(mconcat)) - -concatMapM :: Functor m => Monad m => Monoid b => (a -> m b) -> [a] -> m b -concatMapM = fmap (fmap mconcat) `fmap` mapM -- It'd be really convenient to have <$$$> here. ;-)