    {-# 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
        { forall s. ImplSpec s -> Maybe s
    implScore     :: Maybe s
        , forall s. ImplSpec s -> Set String
    dependencies  :: S.Set String
        , forall s. ImplSpec s -> Q [Dec]
    definition    :: Q [Dec]
        }

    instance Functor ImplSpec where
        fmap :: forall a b. (a -> b) -> ImplSpec a -> ImplSpec b
    fmap a -> b
    f ImplSpec a
    s = ImplSpec a
    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 :: forall s. Monoid s => ImplSpec s -> s
    scoreImplSpec = s -> Maybe s -> s
    forall a. a -> Maybe a -> a
    fromMaybe s
    forall a. Monoid a => a
    mempty (Maybe s -> s) -> (ImplSpec s -> Maybe s) -> ImplSpec s -> s
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ImplSpec s -> Maybe s
    forall s. ImplSpec s -> Maybe s
    implScore

    scoreSolution :: Monoid s => Solution s -> s
    scoreSolution :: forall s. Monoid s => Solution s -> s
    scoreSolution = [s] -> s
    forall a. Monoid a => [a] -> a
    mconcat ([s] -> s) -> (Solution s -> [s]) -> Solution s -> s
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ImplSpec s -> s) -> [ImplSpec s] -> [s]
    forall a b. (a -> b) -> [a] -> [b]
    map ImplSpec s -> s
    forall s. Monoid s => ImplSpec s -> s
    scoreImplSpec ([ImplSpec s] -> [s])
    -> (Solution s -> [ImplSpec s]) -> Solution s -> [s]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Solution s -> [ImplSpec s]
    forall k a. Map k a -> [a]
    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 :: forall s. Problem s -> [Solution s]
    chooseImplementations Problem s
    unimplemented
        | Problem s -> Bool
    forall k a. Map k a -> Bool
    M.null Problem s
    unimplemented = [Solution s
    forall k a. Map k a
    M.empty]
        | Bool
    otherwise = do
            (name, impls) <- Problem s -> [(String, [ImplSpec s])]
    forall k a. Map k a -> [(k, a)]
    M.assocs Problem s
    unimplemented
            let newUnimplemented = String -> Problem s -> Problem s
    forall k a. Ord k => k -> Map k a -> Map k a
    M.delete String
    name Problem s
    unimplemented
                implemented = Bool -> Bool
    not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> Problem s -> Bool) -> Problem s -> String -> Bool
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip String -> Problem s -> Bool
    forall k a. Ord k => k -> Map k a -> Bool
    M.member Problem s
    newUnimplemented
            impl <- take 1 (filter (all implemented . dependencies) impls)
            otherImpls <- chooseImplementations newUnimplemented
            return (M.insert name impl otherImpls)