flexible-defaults (empty) → 0.0.0.1
raw patch · 7 files changed
+483/−0 lines, 7 filesdep +basedep +containersdep +template-haskellsetup-changed
Dependencies added: base, containers, template-haskell, transformers
Files
- Setup.lhs +5/−0
- examples/Class.hs +69/−0
- examples/Instances.hs +65/−0
- flexible-defaults.cabal +49/−0
- src/Language/Haskell/TH/FlexibleDefaults.hs +99/−0
- src/Language/Haskell/TH/FlexibleDefaults/DSL.hs +142/−0
- src/Language/Haskell/TH/FlexibleDefaults/Solve.hs +54/−0
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain+
+ examples/Class.hs view
@@ -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
+ examples/Instances.hs view
@@ -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+ ]
+ flexible-defaults.cabal view
@@ -0,0 +1,49 @@+name: flexible-defaults+version: 0.0.0.1+stability: experimental++cabal-version: >= 1.6+build-type: Simple++author: James Cook <mokus@deepbondi.net>+maintainer: James Cook <mokus@deepbondi.net>+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
+ src/Language/Haskell/TH/FlexibleDefaults.hs view
@@ -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. <https://github.com/mokus0/flexible-defaults/tree/master/examples>+--+-- 2. <https://github.com/mokus0/random-fu/blob/master/random-source/src/Data/Random/Internal/TH.hs>+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"+
+ src/Language/Haskell/TH/FlexibleDefaults/DSL.hs view
@@ -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
+ src/Language/Haskell/TH/FlexibleDefaults/Solve.hs view
@@ -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)+