flexible-defaults-0.0.1.2/0000755000000000000000000000000012722731064013441 5ustar0000000000000000flexible-defaults-0.0.1.2/flexible-defaults.cabal0000644000000000000000000000456312722731064020034 0ustar0000000000000000name: flexible-defaults version: 0.0.1.2 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. 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 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.2/Setup.lhs0000644000000000000000000000011612722731064015247 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain flexible-defaults-0.0.1.2/examples/0000755000000000000000000000000012722731064015257 5ustar0000000000000000flexible-defaults-0.0.1.2/examples/Class.hs0000644000000000000000000000365012722731064016664 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.2/examples/Instances.hs0000644000000000000000000000206212722731064017542 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.2/src/0000755000000000000000000000000012722731064014230 5ustar0000000000000000flexible-defaults-0.0.1.2/src/Language/0000755000000000000000000000000012722731064015753 5ustar0000000000000000flexible-defaults-0.0.1.2/src/Language/Haskell/0000755000000000000000000000000012722731064017336 5ustar0000000000000000flexible-defaults-0.0.1.2/src/Language/Haskell/TH/0000755000000000000000000000000012722731064017651 5ustar0000000000000000flexible-defaults-0.0.1.2/src/Language/Haskell/TH/FlexibleDefaults.hs0000644000000000000000000000575612722731064023444 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. {-# LANGUAGE CPP #-} 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 #if MIN_VERSION_template_haskell(2,11,0) [InstanceD ol clsCxt cls decs] -> do impl <- implementDefaults defs decs return [InstanceD ol clsCxt cls impl] #else [InstanceD clsCxt cls decs] -> do impl <- implementDefaults defs decs return [InstanceD clsCxt cls impl] #endif _ -> fail "withDefaults: second parameter should be a single instance declaration" flexible-defaults-0.0.1.2/src/Language/Haskell/TH/FlexibleDefaults/0000755000000000000000000000000012722731064023073 5ustar0000000000000000flexible-defaults-0.0.1.2/src/Language/Haskell/TH/FlexibleDefaults/DSL.hs0000644000000000000000000001302312722731064024050 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.2/src/Language/Haskell/TH/FlexibleDefaults/Solve.hs0000644000000000000000000000345112722731064024522 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)