flexible-defaults-0.0.2/0000755000000000000000000000000013314174776013313 5ustar0000000000000000flexible-defaults-0.0.2/flexible-defaults.cabal0000644000000000000000000000466013314174776017704 0ustar0000000000000000name: flexible-defaults version: 0.0.2 stability: provisional cabal-version: >= 1.6 build-type: Simple author: James Cook maintainer: Peter Simons license: PublicDomain homepage: https://github.com/peti/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.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/peti/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 if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* flexible-defaults-0.0.2/Setup.lhs0000644000000000000000000000011513314174776015120 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain flexible-defaults-0.0.2/examples/0000755000000000000000000000000013314174776015131 5ustar0000000000000000flexible-defaults-0.0.2/examples/Instances.hs0000644000000000000000000000204613314174776017416 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.2/examples/Class.hs0000644000000000000000000000360713314174776016540 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.2/src/0000755000000000000000000000000013314174776014102 5ustar0000000000000000flexible-defaults-0.0.2/src/Language/0000755000000000000000000000000013314174776015625 5ustar0000000000000000flexible-defaults-0.0.2/src/Language/Haskell/0000755000000000000000000000000013314174776017210 5ustar0000000000000000flexible-defaults-0.0.2/src/Language/Haskell/TH/0000755000000000000000000000000013314174776017523 5ustar0000000000000000flexible-defaults-0.0.2/src/Language/Haskell/TH/FlexibleDefaults.hs0000644000000000000000000000604313314174776023304 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.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 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.2/src/Language/Haskell/TH/FlexibleDefaults/0000755000000000000000000000000013314174776022745 5ustar0000000000000000flexible-defaults-0.0.2/src/Language/Haskell/TH/FlexibleDefaults/DSL.hs0000644000000000000000000001332013314174776023722 0ustar0000000000000000{-# 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.Semigroup as Semigroup 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 Semigroup.Semigroup (Impls s) where (<>) (Impls x) (Impls y) = Impls (M.unionWith mappend x y) instance Monoid (Impls s) where mempty = Impls mempty 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 } 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.2/src/Language/Haskell/TH/FlexibleDefaults/Solve.hs0000644000000000000000000000363613314174776024401 0ustar0000000000000000{-# LANGUAGE CPP #-} 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 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 , 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)