-- |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. <https://github.com/mokus0/flexible-defaults/tree/master/examples>
--
-- 2. <https://github.com/mokus0/random-fu/blob/master/random-source/src/Data/Random/Internal/TH.hs>
{-# 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 :: Set k -> Map k v -> Map k v
deleteKeys ks :: Set k
ks m :: Map k v
m = Map k v
m Map k v -> Map k () -> Map k v
forall k a b. Ord k => Map k a -> Map k b -> Map k a
M.\\ [(k, ())] -> Map k ()
forall k a. [(k, a)] -> Map k a
M.fromDistinctAscList [(k
k,()) | k
k <- Set k -> [k]
forall a. Set a -> [a]
S.toAscList Set k
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 :: Defaults s () -> [Dec] -> Q [Dec]
implementDefaults defs :: Defaults s ()
defs futzedDecs :: [Dec]
futzedDecs = do
    let decs :: [Dec]
decs = [Dec] -> [Dec]
genericalizeDecs [Dec]
futzedDecs
        prob :: Problem s
prob = Defaults s () -> Problem s
forall s. (Ord s, Monoid s) => Defaults s () -> Problem s
toProblem Defaults s ()
defs

        implemented :: Set String
implemented = [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList ((Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name -> String
nameBase ((Dec -> [Name]) -> [Dec] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Dec -> [Name]
namesBoundInDec [Dec]
decs))
        unimplemented :: Problem s
unimplemented = Set String -> Problem s -> Problem s
forall k v. Ord k => Set k -> Map k v -> Map k v
deleteKeys Set String
implemented Problem s
prob

        solutions :: [Solution s]
solutions = Problem s -> [Solution s]
forall s. Problem s -> [Solution s]
chooseImplementations Problem s
unimplemented

    [[Dec]]
implementations <- case [Solution s]
solutions of
        []  -> String -> Q [[Dec]]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "implementDefaults: incomplete set of basis functions"
        ss :: [Solution s]
ss  ->
            let best :: Solution s
best = (Solution s -> Solution s -> Ordering)
-> [Solution s] -> Solution s
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((Solution s -> s) -> Solution s -> Solution s -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Solution s -> s
forall s. Monoid s => Solution s -> s
scoreSolution) [Solution s]
ss
             in [Q [Dec]] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Q [Dec]
decQ | ImplSpec _ _ decQ :: Q [Dec]
decQ <- Solution s -> [ImplSpec s]
forall k a. Map k a -> [a]
M.elems Solution s
best]

    [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
decs [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Dec]]
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 :: Defaults s () -> Q [Dec] -> Q [Dec]
withDefaults defs :: Defaults s ()
defs decQ :: Q [Dec]
decQ = do
    [Dec]
dec <- Q [Dec]
decQ

    case [Dec]
dec of
#if MIN_VERSION_template_haskell(2,11,0)
        [InstanceD ol :: Maybe Overlap
ol clsCxt :: Cxt
clsCxt cls :: Type
cls decs :: [Dec]
decs] -> do
            [Dec]
impl <- Defaults s () -> [Dec] -> Q [Dec]
forall s. (Ord s, Monoid s) => Defaults s () -> [Dec] -> Q [Dec]
implementDefaults Defaults s ()
defs [Dec]
decs
            [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
ol Cxt
clsCxt Type
cls [Dec]
impl]
#else
        [InstanceD clsCxt cls decs] -> do
            impl <- implementDefaults defs decs
            return [InstanceD clsCxt cls impl]
#endif

        _ -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "withDefaults: second parameter should be a single instance declaration"