{-# 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))
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
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)