diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain + diff --git a/examples/Class.hs b/examples/Class.hs new file mode 100644 --- /dev/null +++ b/examples/Class.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-type-defaults #-} +module Class + ( DefaultsTest(..) + , defaultsTest + ) where + +import Language.Haskell.TH.FlexibleDefaults +import Data.Char +import Data.Monoid +import qualified Data.Map as M +import qualified Data.Set as S + +-- A very silly example. For a real-world example, see the random-source package: +-- https://github.com/mokus0/random-fu/blob/master/random-source/src/Data/Random/Internal/TH.hs +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" + +defaults :: Defaults (Sum Int) () +defaults = scoreBy Sum $ do + function "foo" $ do + 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 + |] + 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 + dependsOn "foo" + return [d| quux x = toInteger (read (foo x) :: Int) == read (foo x) |] + implementation $ do + dependsOn "bar" + dependsOn "qux" + return [d| quux x = toInteger (bar x) == qux x |] + +defaultsTest = withDefaults defaults diff --git a/examples/Instances.hs b/examples/Instances.hs new file mode 100644 --- /dev/null +++ b/examples/Instances.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances #-} +{-# OPTIONS_GHC -ddump-splices -fno-warn-orphans -fno-warn-missing-signatures #-} +module Instances where + +import Class + +$(defaultsTest + [d| + instance DefaultsTest Int where + qux = toInteger + |] + ) + +$(defaultsTest + [d| + instance DefaultsTest [Char] where + foo = id + |] + ) + +$(defaultsTest + [d| + instance DefaultsTest Integer where + |] + ) + +$(defaultsTest + [d| + instance DefaultsTest Float where + bar = round + |] + ) + +$(defaultsTest + [d| + instance DefaultsTest Double where + quux = (>2147483647) . abs + |] + ) + +$(defaultsTest + [d| + instance DefaultsTest Bool where + foo True = "0" + foo False = "1" + + baz = (||) + |] + ) + +test x = + ( foo x + , bar x + , qux x + , quux x + ) + +tests = + [ test (1 :: Int) + , test "123" + , test (1000000000000000000000000000 :: Integer) + , test (1e10 :: Float) + , test (1e30 :: Double) + , test True + ] diff --git a/flexible-defaults.cabal b/flexible-defaults.cabal new file mode 100644 --- /dev/null +++ b/flexible-defaults.cabal @@ -0,0 +1,49 @@ +name: flexible-defaults +version: 0.0.0.1 +stability: experimental + +cabal-version: >= 1.6 +build-type: Simple + +author: James Cook +maintainer: James Cook +license: PublicDomain +homepage: https://github.com/mokus0/flexible-defaults + +category: Code Generation, Template Haskell +synopsis: Generate default function implementations for complex type classes. +description: Template Haskell code to implement default implementations + for type-class functions based on which functions are + already implemented. Currently extremely crude but + still fairly effective. + + When defining a type class with many functions, each + of which can be implemented based on arbitrary subsets + of the others, the standard default-implementation + concept breaks down quite badly. This library provides + a system by which more complex rules can be described + for choosing default implementations based on which + ones the user supplies. These implementations can + additionally be given \"suitability scores\", so that + when multiple possible choices could be made, the + library can choose the \"best\" one. + +extra-source-files: examples/*.hs + +tested-with: GHC == 6.8.3, GHC == 6.10.4, GHC == 6.12.1, + GHC == 6.12.3, GHC == 7.0.1, GHC == 7.0.2 + +source-repository head + type: git + location: https://github.com/mokus0/flexible-defaults.git + +Library + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: Language.Haskell.TH.FlexibleDefaults + other-modules: Language.Haskell.TH.FlexibleDefaults.DSL + Language.Haskell.TH.FlexibleDefaults.Solve + build-depends: base >= 3 && <5, + containers, + template-haskell, + transformers diff --git a/src/Language/Haskell/TH/FlexibleDefaults.hs b/src/Language/Haskell/TH/FlexibleDefaults.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/FlexibleDefaults.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP #-} +-- |A code-generation system for complex typeclass default-implementation +-- configurations. There are usage examples in this package's source +-- distribution[1] and in the random-source package[2]. +-- +-- 1. +-- +-- 2. +module Language.Haskell.TH.FlexibleDefaults + ( Defaults + , scoreBy + , Function + , function + , requireFunction + , Implementation + , implementation + , score + , cost + , dependsOn + , inline + , noinline + + , withDefaults + , implementDefaults + ) where + +import Data.List +import Data.Monoid +import Data.Ord +import qualified Data.Map as M +import qualified Data.Set as S +import Language.Haskell.TH +import Language.Haskell.TH.FlexibleDefaults.DSL +import Language.Haskell.TH.FlexibleDefaults.Solve + +declaredValueNames :: Dec -> [Name] +declaredValueNames (FunD n _) = [n] +declaredValueNames (ValD p _ _) = matchedNames p +declaredValueNames _ = [] + +matchedNames :: Pat -> [Name] +matchedNames (VarP n) = [n] +matchedNames (TupP ps) = concatMap matchedNames ps +matchedNames (InfixP p1 _ p2) = matchedNames p1 ++ matchedNames p2 +matchedNames (TildeP p) = matchedNames p +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 +matchedNames (BangP p) = matchedNames p +#endif +matchedNames (AsP n p) = n : matchedNames p +matchedNames (RecP _ fs) = concatMap (matchedNames . snd) fs +matchedNames (ListP ps) = concatMap matchedNames ps +matchedNames (SigP p _) = matchedNames p +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 700 +matchedNames (ViewP _ p) = matchedNames p +#endif +matchedNames _ = [] + +deleteKeys :: Ord k => S.Set k -> M.Map k v -> M.Map k v +deleteKeys ks m = m M.\\ M.fromDistinctAscList [(k,()) | k <- S.toAscList ks] + +-- |Given a partial list of function declarations, complete that list based on +-- the 'Defaults' specification given. +implementDefaults :: (Ord s, Monoid s) => Defaults s () -> [Dec] -> Q [Dec] +implementDefaults defs decs = do + let prob = toProblem defs + + implemented = S.fromList (map nameBase (concatMap declaredValueNames decs)) + unimplemented = deleteKeys implemented prob + + solutions = chooseImplementations unimplemented + + implementations <- case solutions of + [] -> fail "implementDefaults: incomplete set of basis functions" + 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. +-- Or even accept something like "M.Map String (exists s. Defaults s)" to support +-- many different instance decls, choosing the 'Defaults' spec by class name. + +-- |Given a @Q [Dec]@ containing an instance declaration, complete that instance +-- declaration using the given 'Defaults' specification. Typical usage would be +-- along the lines of the following: +-- +-- > $(withDefaults fooDefaults [d| instance Foo t where {- ... -} |]) +withDefaults :: (Monoid s, Ord s) => Defaults s () -> Q [Dec] -> Q [Dec] +withDefaults defs decQ = do + dec <- decQ + + case dec of + [InstanceD clsCxt cls decs] -> do + impl <- implementDefaults defs decs + return [InstanceD clsCxt cls impl] + + _ -> 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 new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/FlexibleDefaults/DSL.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-} +module Language.Haskell.TH.FlexibleDefaults.DSL where + +import Control.Applicative +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Control.Monad.Trans.Writer +import Data.List +import Data.Monoid +import qualified Data.Map as M +import Data.Ord +import qualified Data.Set as S +import Language.Haskell.TH +import Language.Haskell.TH.FlexibleDefaults.Solve + +-- newtype wrapper for Problem, because the default implementation of Monoid +-- (@mappend = union@) is not the one we want here; we want +-- @mappend = unionWith mappend@ +newtype Impls s = Impls { unImpls :: M.Map String [ImplSpec s] } + +instance Functor Impls where + fmap f (Impls m) = Impls (M.map (map (fmap f)) m) + +instance Monoid (Impls s) where + mempty = Impls mempty + mappend (Impls x) (Impls y) = Impls (M.unionWith mappend x y) + +-- |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 } + deriving (Functor, Applicative, Monad) + + +addImplSpecs :: String -> [ImplSpec s] -> Defaults s () +addImplSpecs f = Defaults . tell . Impls . M.singleton f + +addImplSpec :: String -> ImplSpec s -> Defaults s () +addImplSpec f = addImplSpecs f . (:[]) + +toProblem :: (Ord s, Monoid s) => Defaults s () -> Problem s +toProblem + = fmap (sortBy (flip (comparing scoreImplSpec))) + . unImpls + . snd + . runWriter + . unDefaults + +-- |Map a function over all scores. This function's name comes from the +-- following idiom (where 'Sum' is replaced by whatever monoid-constructor +-- you want to use to combine scores): +-- +-- > foo = scoreBy Sum $ do +-- > ... +scoreBy :: (a -> b) -> Defaults a t -> Defaults b t +scoreBy f = Defaults . mapWriterT (fmap (fmap (fmap f))) . unDefaults + +-- |A representation of a function for which one or more default +-- 'Implementation's exist. Defined using the 'function' function. +newtype Function s a = Function (ReaderT String (Defaults s) a) + deriving (Functor, Applicative, Monad) + +-- |Declare a function that must be implemented, and provide a description +-- of any default implementations which can be used. +function :: String -> Function s a -> Defaults s a +function f (Function x) = do + requireFunction f + runReaderT x f + +-- |State that a function must be implemented but has no default implementation. +requireFunction :: String -> Defaults s () +requireFunction f = addImplSpecs f [] + +#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 612 +type InlineSpec = () +#endif + +-- |A representation of a single possible implementation of a 'Function'. Defined +-- using the 'implementation' function. +newtype Implementation s a = Implementation (State (Maybe s, S.Set String, Maybe InlineSpec) a) + deriving (Functor, Applicative, Monad) + +-- |Describe a default implementation of the current function +implementation :: Implementation s (Q [Dec]) -> Function s () +implementation (Implementation x) = case runState x (Nothing, S.empty, Nothing) of + (dec, (s, deps, inl)) -> Function $ do + fName <- ask + ReaderT (const (addImplSpec fName (ImplSpec s deps (applyInline fName inl dec)))) + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 +applyInline :: String -> Maybe InlineSpec -> Q [Dec] -> Q [Dec] +applyInline _ Nothing = id +applyInline n (Just inl) = fmap (PragmaD (InlineP (mkName n) inl) :) +#else +applyInline :: String -> Maybe InlineSpec -> Q [Dec] -> Q [Dec] +applyInline _ _ = id +#endif + +-- |Specify the score associated with the current implementation. Only one +-- invocation of either 'score' or 'cost' may be used per implementation. +score :: s -> Implementation s () +score s = Implementation $ do + (oldS, deps, inl) <- get + case oldS of + Nothing -> put (Just s, deps, inl) + Just _ -> fail "score: score was already set" + +-- |Specify the cost (negated score) associated with the current implementation. +-- Only one invocation of either 'score' or 'cost' may be used per implementation. +cost :: Num s => s -> Implementation s () +cost = score . negate + +-- |Specify that the current implementation must not be used unless the given +-- function is already defined. If this implementation can be used +-- mutually-recursively with _ALL_ potential implementations of some other +-- function, then a dependency need not be declared on that function. +dependsOn :: String -> Implementation s () +dependsOn dep = Implementation $ do + (s, deps, inl) <- get + put (s, S.insert dep deps, inl) + +setInline :: InlineSpec -> Implementation s () +setInline inl = Implementation $ do + (s, deps, _) <- get + put (s, deps, Just inl) + +-- |Specify that an 'Implementation' should be annotated with an INLINE pragma. +-- Under GHC versions earlier than 6.12 this is a no-op, because those Template +-- Haskell implementations do not support pragmas. +inline :: Implementation s () + +-- |Specify that an 'Implementation' should be annotated with a NOINLINE pragma. +-- Under GHC versions earlier than 6.12 this is a no-op, because those Template +-- Haskell implementations do not support pragmas. +noinline :: Implementation s () + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 +inline = setInline (InlineSpec True False Nothing) +noinline = setInline (InlineSpec False False Nothing) +#else +inline = return () +noinline = return () +#endif diff --git a/src/Language/Haskell/TH/FlexibleDefaults/Solve.hs b/src/Language/Haskell/TH/FlexibleDefaults/Solve.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/TH/FlexibleDefaults/Solve.hs @@ -0,0 +1,54 @@ +module Language.Haskell.TH.FlexibleDefaults.Solve + ( ImplSpec(..) + , scoreImplSpec + , Problem + , Solution + , scoreSolution + , chooseImplementations + ) where + +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 + +data ImplSpec s = ImplSpec + { implScore :: Maybe s + , dependencies :: S.Set String + , definition :: Q [Dec] + } + +instance Functor ImplSpec where + fmap f s = s {implScore = fmap f (implScore s)} + +type Problem s = M.Map String [ImplSpec s] +type Solution s = M.Map String (ImplSpec s) + +scoreImplSpec :: Monoid s => ImplSpec s -> s +scoreImplSpec = fromMaybe mempty . implScore + +scoreSolution :: Monoid s => Solution s -> s +scoreSolution = mconcat . map scoreImplSpec . M.elems + +-- Find all feasible solutions. This is not particularly efficient but I believe +-- it works and is correct. At any given point, the solution set is well-founded: +-- initially, it is those functions which have direct implementations. At each +-- step it adds an implementation which only depends upon already-implemented +-- functions. +-- +-- Considers all possible orderings of resolutions, which means this takes +-- O(n!) time, where 'n' is the number of missing functions. +chooseImplementations :: Problem s -> [Solution s] +chooseImplementations unimplemented + | M.null unimplemented = [M.empty] + | otherwise = do + (name, impls) <- M.assocs unimplemented + let newUnimplemented = M.delete name unimplemented + implemented = not . flip M.member newUnimplemented + impl <- take 1 (filter (all implemented . dependencies) impls) + otherImpls <- chooseImplementations newUnimplemented + return (M.insert name impl otherImpls) +