flexible-defaults-0.0.1.1/0000755000000000000000000000000012115151441013427 5ustar0000000000000000flexible-defaults-0.0.1.1/flexible-defaults.cabal0000644000000000000000000000540512115151441020016 0ustar0000000000000000name: flexible-defaults version: 0.0.1.1 stability: provisional 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. . Changes in 0.0.1.0: Updated for Template Haskell changes in GHC 7.6 . Changes in v0.0.0.3: Added a hack to fix under GHC 7.2. . Changes in v0.0.0.2: Nothing at all except setting 'buildable: False' under GHC 7.2.1. extra-source-files: examples/*.hs tested-with: GHC == 6.8.3, GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.1 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, th-extras, transformers flexible-defaults-0.0.1.1/Setup.lhs0000644000000000000000000000011612115151441015235 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain flexible-defaults-0.0.1.1/examples/0000755000000000000000000000000012115151441015245 5ustar0000000000000000flexible-defaults-0.0.1.1/examples/Class.hs0000644000000000000000000000365012115151441016652 0ustar0000000000000000{-# 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 flexible-defaults-0.0.1.1/examples/Instances.hs0000644000000000000000000000206212115151441017530 0ustar0000000000000000{-# 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-0.0.1.1/src/0000755000000000000000000000000012115151441014216 5ustar0000000000000000flexible-defaults-0.0.1.1/src/Language/0000755000000000000000000000000012115151441015741 5ustar0000000000000000flexible-defaults-0.0.1.1/src/Language/Haskell/0000755000000000000000000000000012115151441017324 5ustar0000000000000000flexible-defaults-0.0.1.1/src/Language/Haskell/TH/0000755000000000000000000000000012115151441017637 5ustar0000000000000000flexible-defaults-0.0.1.1/src/Language/Haskell/TH/FlexibleDefaults.hs0000644000000000000000000000542412115151441023422 0ustar0000000000000000-- |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.Extras import Language.Haskell.TH.FlexibleDefaults.DSL import Language.Haskell.TH.FlexibleDefaults.Solve 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 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 -> 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" flexible-defaults-0.0.1.1/src/Language/Haskell/TH/FlexibleDefaults/0000755000000000000000000000000012115151441023061 5ustar0000000000000000flexible-defaults-0.0.1.1/src/Language/Haskell/TH/FlexibleDefaults/DSL.hs0000644000000000000000000001302312115151441024036 0ustar0000000000000000{-# 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 !MIN_VERSION_template_haskell(2,8,0) data Inline = NoInline | Inline | Inlinable deriving (Eq, Show) #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 Inline) 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)))) applyInline :: String -> Maybe Inline -> Q [Dec] -> Q [Dec] #if MIN_VERSION_template_haskell(2,8,0) applyInline n (Just inl) = fmap (PragmaD (InlineP (mkName n) inl FunLike AllPhases) :) #elif MIN_VERSION_template_haskell(2,4,0) applyInline n (Just inl) | inl /= Inlinable = fmap (PragmaD (InlineP (mkName n) (InlineSpec (inl == Inline) False Nothing)) :) #endif applyInline _ _ = id -- |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 :: Inline -> 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 an INLINEABLE pragma. -- Under GHC versions earlier than 7.6 this is a no-op, because those Template -- Haskell implementations do not support this pragma. inlinable :: 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 () inline = setInline Inline inlinable = setInline Inlinable noinline = setInline NoInline flexible-defaults-0.0.1.1/src/Language/Haskell/TH/FlexibleDefaults/Solve.hs0000644000000000000000000000345112115151441024510 0ustar0000000000000000module 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)