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