{-# 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 :: Maybe b
implScore = (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ImplSpec a -> Maybe a
forall s. ImplSpec s -> Maybe s
implScore ImplSpec a
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)
-> (Map String (ImplSpec s) -> [s]) -> Map String (ImplSpec 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])
-> (Map String (ImplSpec s) -> [ImplSpec s])
-> Map String (ImplSpec s)
-> [s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String (ImplSpec 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
        (String
name, [ImplSpec s]
impls) <- Problem s -> [(String, [ImplSpec s])]
forall k a. Map k a -> [(k, a)]
M.assocs Problem s
unimplemented
        let newUnimplemented :: Problem s
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 :: String -> Bool
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
        ImplSpec s
impl <- Int -> [ImplSpec s] -> [ImplSpec s]
forall a. Int -> [a] -> [a]
take Int
1 ((ImplSpec s -> Bool) -> [ImplSpec s] -> [ImplSpec s]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> Bool) -> Set String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all String -> Bool
implemented (Set String -> Bool)
-> (ImplSpec s -> Set String) -> ImplSpec s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImplSpec s -> Set String
forall s. ImplSpec s -> Set String
dependencies) [ImplSpec s]
impls)
        Solution s
otherImpls <- Problem s -> [Solution s]
forall s. Problem s -> [Solution s]
chooseImplementations Problem s
newUnimplemented
        Solution s -> [Solution s]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ImplSpec s -> Solution s -> Solution s
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
name ImplSpec s
impl Solution s
otherImpls)