diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -2,4 +2,3 @@ > import Distribution.Simple > main = defaultMain - diff --git a/examples/Class.hs b/examples/Class.hs --- a/examples/Class.hs +++ b/examples/Class.hs @@ -16,16 +16,16 @@ class DefaultsTest a where foo :: a -> String foo = error "foo not implemented" - + bar :: a -> Int bar = error "bar not implemented" - + baz :: a -> a -> a baz = error "baz not implemented" - + qux :: a -> Integer qux = error "qux not implemented" - + quux :: a -> Bool quux = error "quux not implemented" @@ -35,27 +35,27 @@ implementation $ do cost 1 return [d| foo = filter isDigit . show |] - + function "bar" $ do implementation $ do dependsOn "qux" return [d| bar = fromInteger . qux |] - + function "baz" $ do implementation $ do score 1 dependsOn "quux" return [d| baz x | quux x = const x - | otherwise = id + | otherwise = id |] implementation $ do return [d| baz = const |] - + function "qux" $ do implementation $ do dependsOn "foo" return [d| qux = read . foo |] - + function "quux" $ do implementation $ do cost 1 diff --git a/examples/Instances.hs b/examples/Instances.hs --- a/examples/Instances.hs +++ b/examples/Instances.hs @@ -43,7 +43,7 @@ instance DefaultsTest Bool where foo True = "0" foo False = "1" - + baz = (||) |] ) diff --git a/flexible-defaults.cabal b/flexible-defaults.cabal --- a/flexible-defaults.cabal +++ b/flexible-defaults.cabal @@ -1,14 +1,14 @@ name: flexible-defaults -version: 0.0.1.2 +version: 0.0.2 stability: provisional cabal-version: >= 1.6 build-type: Simple author: James Cook -maintainer: James Cook +maintainer: Peter Simons license: PublicDomain -homepage: https://github.com/mokus0/flexible-defaults +homepage: https://github.com/peti/flexible-defaults category: Code Generation, Template Haskell synopsis: Generate default function implementations for complex type classes. @@ -30,13 +30,13 @@ extra-source-files: examples/*.hs -tested-with: GHC == 7.0.4, GHC == 7.2.1, GHC == 7.2.2, - GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, - GHC == 7.10.3, GHC == 8.0.1, GHC == 8.1 +tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, + GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, + GHC == 8.4.3 source-repository head type: git - location: https://github.com/mokus0/flexible-defaults.git + location: https://github.com/peti/flexible-defaults.git Library hs-source-dirs: src @@ -49,3 +49,5 @@ template-haskell, th-extras, transformers + if !impl(ghc >= 8.0) + build-depends: semigroups == 0.18.* diff --git a/src/Language/Haskell/TH/FlexibleDefaults.hs b/src/Language/Haskell/TH/FlexibleDefaults.hs --- a/src/Language/Haskell/TH/FlexibleDefaults.hs +++ b/src/Language/Haskell/TH/FlexibleDefaults.hs @@ -1,7 +1,7 @@ -- |A code-generation system for complex typeclass default-implementation --- configurations. There are usage examples in this package's source +-- configurations. There are usage examples in this package's source -- distribution[1] and in the random-source package[2]. --- +-- -- 1. -- -- 2. @@ -19,14 +19,17 @@ , dependsOn , inline , noinline - + , withDefaults , implementDefaults ) where import Data.List -import Data.Monoid import Data.Ord +#if !(MIN_VERSION_base(4,8,0)) +-- starting with base-4.8, Monoid is rexported from Prelude +import Data.Monoid +#endif import qualified Data.Map as M import qualified Data.Set as S import Language.Haskell.TH @@ -43,18 +46,18 @@ implementDefaults defs futzedDecs = do let decs = genericalizeDecs futzedDecs prob = toProblem defs - + implemented = S.fromList (map nameBase (concatMap namesBoundInDec decs)) unimplemented = deleteKeys implemented prob - + solutions = chooseImplementations unimplemented - + implementations <- case solutions of [] -> fail "implementDefaults: incomplete set of basis functions" - ss -> + ss -> let best = maximumBy (comparing scoreSolution) ss in sequence [ decQ | ImplSpec _ _ decQ <- M.elems best] - + return (decs ++ concat implementations) -- TODO: maybe make this accept multiple instance declarations, and/or pass non-instance Dec's unmodified. @@ -69,7 +72,7 @@ withDefaults :: (Monoid s, Ord s) => Defaults s () -> Q [Dec] -> Q [Dec] withDefaults defs decQ = do dec <- decQ - + case dec of #if MIN_VERSION_template_haskell(2,11,0) [InstanceD ol clsCxt cls decs] -> do @@ -80,6 +83,5 @@ impl <- implementDefaults defs decs return [InstanceD clsCxt cls impl] #endif - - _ -> fail "withDefaults: second parameter should be a single instance declaration" + _ -> fail "withDefaults: second parameter should be a single instance declaration" diff --git a/src/Language/Haskell/TH/FlexibleDefaults/DSL.hs b/src/Language/Haskell/TH/FlexibleDefaults/DSL.hs --- a/src/Language/Haskell/TH/FlexibleDefaults/DSL.hs +++ b/src/Language/Haskell/TH/FlexibleDefaults/DSL.hs @@ -1,12 +1,16 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-} + module Language.Haskell.TH.FlexibleDefaults.DSL where +#if !(MIN_VERSION_base(4,8,0)) +-- starting with base-4.8, Applicative is rexported from Prelude import Control.Applicative +#endif import Control.Monad.Trans.Reader import Control.Monad.Trans.State import Control.Monad.Trans.Writer import Data.List -import Data.Monoid +import Data.Semigroup as Semigroup import qualified Data.Map as M import Data.Ord import qualified Data.Set as S @@ -21,10 +25,13 @@ instance Functor Impls where fmap f (Impls m) = Impls (M.map (map (fmap f)) m) +instance Semigroup.Semigroup (Impls s) where + (<>) (Impls x) (Impls y) = Impls (M.unionWith mappend x y) + instance Monoid (Impls s) where mempty = Impls mempty - mappend (Impls x) (Impls y) = Impls (M.unionWith mappend x y) - + mappend = (Semigroup.<>) + -- |A description of a system of 'Function's and default 'Implementation's -- which can be used to complete a partial implementation of some type class. newtype Defaults s a = Defaults { unDefaults :: Writer (Impls s) a } diff --git a/src/Language/Haskell/TH/FlexibleDefaults/Solve.hs b/src/Language/Haskell/TH/FlexibleDefaults/Solve.hs --- a/src/Language/Haskell/TH/FlexibleDefaults/Solve.hs +++ b/src/Language/Haskell/TH/FlexibleDefaults/Solve.hs @@ -1,4 +1,6 @@ -module Language.Haskell.TH.FlexibleDefaults.Solve +{-# LANGUAGE CPP #-} + +module Language.Haskell.TH.FlexibleDefaults.Solve ( ImplSpec(..) , scoreImplSpec , Problem @@ -10,10 +12,13 @@ import Prelude hiding (all) import Data.Foldable (all) import Data.Maybe -import Data.Monoid import qualified Data.Map as M import qualified Data.Set as S import Language.Haskell.TH +#if !(MIN_VERSION_base(4,8,0)) +-- starting with base-4.8, Monoid is rexported from Prelude +import Data.Monoid +#endif data ImplSpec s = ImplSpec { implScore :: Maybe s @@ -51,4 +56,3 @@ impl <- take 1 (filter (all implemented . dependencies) impls) otherImpls <- chooseImplementations newUnimplemented return (M.insert name impl otherImpls) -