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]
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)
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"