{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-}

module Language.Haskell.TH.FlexibleDefaults.DSL where

#if !(MIN_VERSION_base(4,8,0))
-- starting with base-4.8, Applicative is rexported from Prelude
import Control.Applicative
#endif
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer
import Data.List
import Data.Semigroup as Semigroup
import qualified Data.Map as M
import Data.Ord
import qualified Data.Set as S
import Language.Haskell.TH
import Language.Haskell.TH.FlexibleDefaults.Solve

-- newtype wrapper for Problem, because the default implementation of Monoid
-- (@mappend = union@) is not the one we want here; we want
-- @mappend = unionWith mappend@
newtype Impls s = Impls { forall s. Impls s -> Map String [ImplSpec s]
unImpls :: M.Map String [ImplSpec s] }

instance Functor Impls where
    fmap :: forall a b. (a -> b) -> Impls a -> Impls b
fmap a -> b
f (Impls Map String [ImplSpec a]
m) = Map String [ImplSpec b] -> Impls b
forall s. Map String [ImplSpec s] -> Impls s
Impls (([ImplSpec a] -> [ImplSpec b])
-> Map String [ImplSpec a] -> Map String [ImplSpec b]
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((ImplSpec a -> ImplSpec b) -> [ImplSpec a] -> [ImplSpec b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> ImplSpec a -> ImplSpec b
forall a b. (a -> b) -> ImplSpec a -> ImplSpec b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)) Map String [ImplSpec a]
m)

instance Semigroup.Semigroup (Impls s) where
     <> :: Impls s -> Impls s -> Impls s
(<>) (Impls Map String [ImplSpec s]
x) (Impls Map String [ImplSpec s]
y) = Map String [ImplSpec s] -> Impls s
forall s. Map String [ImplSpec s] -> Impls s
Impls (([ImplSpec s] -> [ImplSpec s] -> [ImplSpec s])
-> Map String [ImplSpec s]
-> Map String [ImplSpec s]
-> Map String [ImplSpec s]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith [ImplSpec s] -> [ImplSpec s] -> [ImplSpec s]
forall a. Monoid a => a -> a -> a
mappend Map String [ImplSpec s]
x Map String [ImplSpec s]
y)

instance Monoid (Impls s) where
    mempty :: Impls s
mempty = Map String [ImplSpec s] -> Impls s
forall s. Map String [ImplSpec s] -> Impls s
Impls Map String [ImplSpec s]
forall a. Monoid a => a
mempty
    mappend :: Impls s -> Impls s -> Impls s
mappend = Impls s -> Impls s -> Impls s
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)

-- |A description of a system of 'Function's and default 'Implementation's 
-- which can be used to complete a partial implementation of some type class.
newtype Defaults s a = Defaults { forall s a. Defaults s a -> Writer (Impls s) a
unDefaults :: Writer (Impls s) a }
    deriving ((forall a b. (a -> b) -> Defaults s a -> Defaults s b)
-> (forall a b. a -> Defaults s b -> Defaults s a)
-> Functor (Defaults s)
forall a b. a -> Defaults s b -> Defaults s a
forall a b. (a -> b) -> Defaults s a -> Defaults s b
forall s a b. a -> Defaults s b -> Defaults s a
forall s a b. (a -> b) -> Defaults s a -> Defaults s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall s a b. (a -> b) -> Defaults s a -> Defaults s b
fmap :: forall a b. (a -> b) -> Defaults s a -> Defaults s b
$c<$ :: forall s a b. a -> Defaults s b -> Defaults s a
<$ :: forall a b. a -> Defaults s b -> Defaults s a
Functor, Functor (Defaults s)
Functor (Defaults s)
-> (forall a. a -> Defaults s a)
-> (forall a b.
    Defaults s (a -> b) -> Defaults s a -> Defaults s b)
-> (forall a b c.
    (a -> b -> c) -> Defaults s a -> Defaults s b -> Defaults s c)
-> (forall a b. Defaults s a -> Defaults s b -> Defaults s b)
-> (forall a b. Defaults s a -> Defaults s b -> Defaults s a)
-> Applicative (Defaults s)
forall s. Functor (Defaults s)
forall a. a -> Defaults s a
forall s a. a -> Defaults s a
forall a b. Defaults s a -> Defaults s b -> Defaults s a
forall a b. Defaults s a -> Defaults s b -> Defaults s b
forall a b. Defaults s (a -> b) -> Defaults s a -> Defaults s b
forall s a b. Defaults s a -> Defaults s b -> Defaults s a
forall s a b. Defaults s a -> Defaults s b -> Defaults s b
forall s a b. Defaults s (a -> b) -> Defaults s a -> Defaults s b
forall a b c.
(a -> b -> c) -> Defaults s a -> Defaults s b -> Defaults s c
forall s a b c.
(a -> b -> c) -> Defaults s a -> Defaults s b -> Defaults s c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall s a. a -> Defaults s a
pure :: forall a. a -> Defaults s a
$c<*> :: forall s a b. Defaults s (a -> b) -> Defaults s a -> Defaults s b
<*> :: forall a b. Defaults s (a -> b) -> Defaults s a -> Defaults s b
$cliftA2 :: forall s a b c.
(a -> b -> c) -> Defaults s a -> Defaults s b -> Defaults s c
liftA2 :: forall a b c.
(a -> b -> c) -> Defaults s a -> Defaults s b -> Defaults s c
$c*> :: forall s a b. Defaults s a -> Defaults s b -> Defaults s b
*> :: forall a b. Defaults s a -> Defaults s b -> Defaults s b
$c<* :: forall s a b. Defaults s a -> Defaults s b -> Defaults s a
<* :: forall a b. Defaults s a -> Defaults s b -> Defaults s a
Applicative, Applicative (Defaults s)
Applicative (Defaults s)
-> (forall a b.
    Defaults s a -> (a -> Defaults s b) -> Defaults s b)
-> (forall a b. Defaults s a -> Defaults s b -> Defaults s b)
-> (forall a. a -> Defaults s a)
-> Monad (Defaults s)
forall s. Applicative (Defaults s)
forall a. a -> Defaults s a
forall s a. a -> Defaults s a
forall a b. Defaults s a -> Defaults s b -> Defaults s b
forall a b. Defaults s a -> (a -> Defaults s b) -> Defaults s b
forall s a b. Defaults s a -> Defaults s b -> Defaults s b
forall s a b. Defaults s a -> (a -> Defaults s b) -> Defaults s b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall s a b. Defaults s a -> (a -> Defaults s b) -> Defaults s b
>>= :: forall a b. Defaults s a -> (a -> Defaults s b) -> Defaults s b
$c>> :: forall s a b. Defaults s a -> Defaults s b -> Defaults s b
>> :: forall a b. Defaults s a -> Defaults s b -> Defaults s b
$creturn :: forall s a. a -> Defaults s a
return :: forall a. a -> Defaults s a
Monad)


addImplSpecs :: String -> [ImplSpec s] -> Defaults s ()
addImplSpecs :: forall s. String -> [ImplSpec s] -> Defaults s ()
addImplSpecs String
f = Writer (Impls s) () -> Defaults s ()
forall s a. Writer (Impls s) a -> Defaults s a
Defaults (Writer (Impls s) () -> Defaults s ())
-> ([ImplSpec s] -> Writer (Impls s) ())
-> [ImplSpec s]
-> Defaults s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Impls s -> Writer (Impls s) ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (Impls s -> Writer (Impls s) ())
-> ([ImplSpec s] -> Impls s) -> [ImplSpec s] -> Writer (Impls s) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map String [ImplSpec s] -> Impls s
forall s. Map String [ImplSpec s] -> Impls s
Impls (Map String [ImplSpec s] -> Impls s)
-> ([ImplSpec s] -> Map String [ImplSpec s])
-> [ImplSpec s]
-> Impls s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [ImplSpec s] -> Map String [ImplSpec s]
forall k a. k -> a -> Map k a
M.singleton String
f

addImplSpec :: String -> ImplSpec s -> Defaults s ()
addImplSpec :: forall s. String -> ImplSpec s -> Defaults s ()
addImplSpec String
f = String -> [ImplSpec s] -> Defaults s ()
forall s. String -> [ImplSpec s] -> Defaults s ()
addImplSpecs String
f ([ImplSpec s] -> Defaults s ())
-> (ImplSpec s -> [ImplSpec s]) -> ImplSpec s -> Defaults s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImplSpec s -> [ImplSpec s] -> [ImplSpec s]
forall a. a -> [a] -> [a]
:[])

toProblem :: (Ord s, Monoid s) => Defaults s () -> Problem s
toProblem :: forall s. (Ord s, Monoid s) => Defaults s () -> Problem s
toProblem
    = ([ImplSpec s] -> [ImplSpec s])
-> Map String [ImplSpec s] -> Map String [ImplSpec s]
forall a b. (a -> b) -> Map String a -> Map String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ImplSpec s -> ImplSpec s -> Ordering)
-> [ImplSpec s] -> [ImplSpec s]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((ImplSpec s -> ImplSpec s -> Ordering)
-> ImplSpec s -> ImplSpec s -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((ImplSpec s -> s) -> ImplSpec s -> ImplSpec s -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ImplSpec s -> s
forall s. Monoid s => ImplSpec s -> s
scoreImplSpec)))
    (Map String [ImplSpec s] -> Map String [ImplSpec s])
-> (Defaults s () -> Map String [ImplSpec s])
-> Defaults s ()
-> Map String [ImplSpec s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Impls s -> Map String [ImplSpec s]
forall s. Impls s -> Map String [ImplSpec s]
unImpls 
    (Impls s -> Map String [ImplSpec s])
-> (Defaults s () -> Impls s)
-> Defaults s ()
-> Map String [ImplSpec s]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), Impls s) -> Impls s
forall a b. (a, b) -> b
snd 
    (((), Impls s) -> Impls s)
-> (Defaults s () -> ((), Impls s)) -> Defaults s () -> Impls s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Writer (Impls s) () -> ((), Impls s)
forall w a. Writer w a -> (a, w)
runWriter 
    (Writer (Impls s) () -> ((), Impls s))
-> (Defaults s () -> Writer (Impls s) ())
-> Defaults s ()
-> ((), Impls s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defaults s () -> Writer (Impls s) ()
forall s a. Defaults s a -> Writer (Impls s) a
unDefaults

-- |Map a function over all scores.  This function's name comes from the
-- following idiom (where 'Sum' is replaced by whatever monoid-constructor
-- you want to use to combine scores):
-- 
-- > foo = scoreBy Sum $ do
-- >    ...
scoreBy :: (a -> b) -> Defaults a t -> Defaults b t
scoreBy :: forall a b t. (a -> b) -> Defaults a t -> Defaults b t
scoreBy a -> b
f = Writer (Impls b) t -> Defaults b t
forall s a. Writer (Impls s) a -> Defaults s a
Defaults (Writer (Impls b) t -> Defaults b t)
-> (Defaults a t -> Writer (Impls b) t)
-> Defaults a t
-> Defaults b t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity (t, Impls a) -> Identity (t, Impls b))
-> WriterT (Impls a) Identity t -> Writer (Impls b) t
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT (((t, Impls a) -> (t, Impls b))
-> Identity (t, Impls a) -> Identity (t, Impls b)
forall a b. (a -> b) -> Identity a -> Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Impls a -> Impls b) -> (t, Impls a) -> (t, Impls b)
forall a b. (a -> b) -> (t, a) -> (t, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Impls a -> Impls b
forall a b. (a -> b) -> Impls a -> Impls b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f))) (WriterT (Impls a) Identity t -> Writer (Impls b) t)
-> (Defaults a t -> WriterT (Impls a) Identity t)
-> Defaults a t
-> Writer (Impls b) t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defaults a t -> WriterT (Impls a) Identity t
forall s a. Defaults s a -> Writer (Impls s) a
unDefaults

-- |A representation of a function for which one or more default
-- 'Implementation's exist.  Defined using the 'function' function.
newtype Function s a = Function (ReaderT String (Defaults s) a)
    deriving ((forall a b. (a -> b) -> Function s a -> Function s b)
-> (forall a b. a -> Function s b -> Function s a)
-> Functor (Function s)
forall a b. a -> Function s b -> Function s a
forall a b. (a -> b) -> Function s a -> Function s b
forall s a b. a -> Function s b -> Function s a
forall s a b. (a -> b) -> Function s a -> Function s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall s a b. (a -> b) -> Function s a -> Function s b
fmap :: forall a b. (a -> b) -> Function s a -> Function s b
$c<$ :: forall s a b. a -> Function s b -> Function s a
<$ :: forall a b. a -> Function s b -> Function s a
Functor, Functor (Function s)
Functor (Function s)
-> (forall a. a -> Function s a)
-> (forall a b.
    Function s (a -> b) -> Function s a -> Function s b)
-> (forall a b c.
    (a -> b -> c) -> Function s a -> Function s b -> Function s c)
-> (forall a b. Function s a -> Function s b -> Function s b)
-> (forall a b. Function s a -> Function s b -> Function s a)
-> Applicative (Function s)
forall s. Functor (Function s)
forall a. a -> Function s a
forall s a. a -> Function s a
forall a b. Function s a -> Function s b -> Function s a
forall a b. Function s a -> Function s b -> Function s b
forall a b. Function s (a -> b) -> Function s a -> Function s b
forall s a b. Function s a -> Function s b -> Function s a
forall s a b. Function s a -> Function s b -> Function s b
forall s a b. Function s (a -> b) -> Function s a -> Function s b
forall a b c.
(a -> b -> c) -> Function s a -> Function s b -> Function s c
forall s a b c.
(a -> b -> c) -> Function s a -> Function s b -> Function s c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall s a. a -> Function s a
pure :: forall a. a -> Function s a
$c<*> :: forall s a b. Function s (a -> b) -> Function s a -> Function s b
<*> :: forall a b. Function s (a -> b) -> Function s a -> Function s b
$cliftA2 :: forall s a b c.
(a -> b -> c) -> Function s a -> Function s b -> Function s c
liftA2 :: forall a b c.
(a -> b -> c) -> Function s a -> Function s b -> Function s c
$c*> :: forall s a b. Function s a -> Function s b -> Function s b
*> :: forall a b. Function s a -> Function s b -> Function s b
$c<* :: forall s a b. Function s a -> Function s b -> Function s a
<* :: forall a b. Function s a -> Function s b -> Function s a
Applicative, Applicative (Function s)
Applicative (Function s)
-> (forall a b.
    Function s a -> (a -> Function s b) -> Function s b)
-> (forall a b. Function s a -> Function s b -> Function s b)
-> (forall a. a -> Function s a)
-> Monad (Function s)
forall s. Applicative (Function s)
forall a. a -> Function s a
forall s a. a -> Function s a
forall a b. Function s a -> Function s b -> Function s b
forall a b. Function s a -> (a -> Function s b) -> Function s b
forall s a b. Function s a -> Function s b -> Function s b
forall s a b. Function s a -> (a -> Function s b) -> Function s b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall s a b. Function s a -> (a -> Function s b) -> Function s b
>>= :: forall a b. Function s a -> (a -> Function s b) -> Function s b
$c>> :: forall s a b. Function s a -> Function s b -> Function s b
>> :: forall a b. Function s a -> Function s b -> Function s b
$creturn :: forall s a. a -> Function s a
return :: forall a. a -> Function s a
Monad)

-- |Declare a function that must be implemented, and provide a description
-- of any default implementations which can be used.
function :: String -> Function s a -> Defaults s a
function :: forall s a. String -> Function s a -> Defaults s a
function String
f (Function ReaderT String (Defaults s) a
x) = do
    String -> Defaults s ()
forall s. String -> Defaults s ()
requireFunction String
f
    ReaderT String (Defaults s) a -> String -> Defaults s a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT String (Defaults s) a
x String
f

-- |State that a function must be implemented but has no default implementation.
requireFunction :: String -> Defaults s ()
requireFunction :: forall s. String -> Defaults s ()
requireFunction String
f = String -> [ImplSpec s] -> Defaults s ()
forall s. String -> [ImplSpec s] -> Defaults s ()
addImplSpecs String
f []

#if !MIN_VERSION_template_haskell(2,8,0)
data Inline = NoInline | Inline | Inlinable
    deriving (Eq, Show)
#endif

-- |A representation of a single possible implementation of a 'Function'.  Defined
-- using the 'implementation' function.
newtype Implementation s a = Implementation (State (Maybe s, S.Set String, Maybe Inline) a)
    deriving ((forall a b. (a -> b) -> Implementation s a -> Implementation s b)
-> (forall a b. a -> Implementation s b -> Implementation s a)
-> Functor (Implementation s)
forall a b. a -> Implementation s b -> Implementation s a
forall a b. (a -> b) -> Implementation s a -> Implementation s b
forall s a b. a -> Implementation s b -> Implementation s a
forall s a b. (a -> b) -> Implementation s a -> Implementation s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall s a b. (a -> b) -> Implementation s a -> Implementation s b
fmap :: forall a b. (a -> b) -> Implementation s a -> Implementation s b
$c<$ :: forall s a b. a -> Implementation s b -> Implementation s a
<$ :: forall a b. a -> Implementation s b -> Implementation s a
Functor, Functor (Implementation s)
Functor (Implementation s)
-> (forall a. a -> Implementation s a)
-> (forall a b.
    Implementation s (a -> b)
    -> Implementation s a -> Implementation s b)
-> (forall a b c.
    (a -> b -> c)
    -> Implementation s a -> Implementation s b -> Implementation s c)
-> (forall a b.
    Implementation s a -> Implementation s b -> Implementation s b)
-> (forall a b.
    Implementation s a -> Implementation s b -> Implementation s a)
-> Applicative (Implementation s)
forall s. Functor (Implementation s)
forall a. a -> Implementation s a
forall s a. a -> Implementation s a
forall a b.
Implementation s a -> Implementation s b -> Implementation s a
forall a b.
Implementation s a -> Implementation s b -> Implementation s b
forall a b.
Implementation s (a -> b)
-> Implementation s a -> Implementation s b
forall s a b.
Implementation s a -> Implementation s b -> Implementation s a
forall s a b.
Implementation s a -> Implementation s b -> Implementation s b
forall s a b.
Implementation s (a -> b)
-> Implementation s a -> Implementation s b
forall a b c.
(a -> b -> c)
-> Implementation s a -> Implementation s b -> Implementation s c
forall s a b c.
(a -> b -> c)
-> Implementation s a -> Implementation s b -> Implementation s c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall s a. a -> Implementation s a
pure :: forall a. a -> Implementation s a
$c<*> :: forall s a b.
Implementation s (a -> b)
-> Implementation s a -> Implementation s b
<*> :: forall a b.
Implementation s (a -> b)
-> Implementation s a -> Implementation s b
$cliftA2 :: forall s a b c.
(a -> b -> c)
-> Implementation s a -> Implementation s b -> Implementation s c
liftA2 :: forall a b c.
(a -> b -> c)
-> Implementation s a -> Implementation s b -> Implementation s c
$c*> :: forall s a b.
Implementation s a -> Implementation s b -> Implementation s b
*> :: forall a b.
Implementation s a -> Implementation s b -> Implementation s b
$c<* :: forall s a b.
Implementation s a -> Implementation s b -> Implementation s a
<* :: forall a b.
Implementation s a -> Implementation s b -> Implementation s a
Applicative, Applicative (Implementation s)
Applicative (Implementation s)
-> (forall a b.
    Implementation s a
    -> (a -> Implementation s b) -> Implementation s b)
-> (forall a b.
    Implementation s a -> Implementation s b -> Implementation s b)
-> (forall a. a -> Implementation s a)
-> Monad (Implementation s)
forall s. Applicative (Implementation s)
forall a. a -> Implementation s a
forall s a. a -> Implementation s a
forall a b.
Implementation s a -> Implementation s b -> Implementation s b
forall a b.
Implementation s a
-> (a -> Implementation s b) -> Implementation s b
forall s a b.
Implementation s a -> Implementation s b -> Implementation s b
forall s a b.
Implementation s a
-> (a -> Implementation s b) -> Implementation s b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall s a b.
Implementation s a
-> (a -> Implementation s b) -> Implementation s b
>>= :: forall a b.
Implementation s a
-> (a -> Implementation s b) -> Implementation s b
$c>> :: forall s a b.
Implementation s a -> Implementation s b -> Implementation s b
>> :: forall a b.
Implementation s a -> Implementation s b -> Implementation s b
$creturn :: forall s a. a -> Implementation s a
return :: forall a. a -> Implementation s a
Monad)

-- |Describe a default implementation of the current function
implementation :: Implementation s (Q [Dec]) -> Function s ()
implementation :: forall s. Implementation s (Q [Dec]) -> Function s ()
implementation (Implementation State (Maybe s, Set String, Maybe Inline) (Q [Dec])
x) = case State (Maybe s, Set String, Maybe Inline) (Q [Dec])
-> (Maybe s, Set String, Maybe Inline)
-> (Q [Dec], (Maybe s, Set String, Maybe Inline))
forall s a. State s a -> s -> (a, s)
runState State (Maybe s, Set String, Maybe Inline) (Q [Dec])
x (Maybe s
forall a. Maybe a
Nothing, Set String
forall a. Set a
S.empty, Maybe Inline
forall a. Maybe a
Nothing) of
    (Q [Dec]
dec, (Maybe s
s, Set String
deps, Maybe Inline
inl)) -> ReaderT String (Defaults s) () -> Function s ()
forall s a. ReaderT String (Defaults s) a -> Function s a
Function (ReaderT String (Defaults s) () -> Function s ())
-> ReaderT String (Defaults s) () -> Function s ()
forall a b. (a -> b) -> a -> b
$ do
        String
fName <- ReaderT String (Defaults s) String
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        (String -> Defaults s ()) -> ReaderT String (Defaults s) ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT (Defaults s () -> String -> Defaults s ()
forall a b. a -> b -> a
const (String -> ImplSpec s -> Defaults s ()
forall s. String -> ImplSpec s -> Defaults s ()
addImplSpec String
fName (Maybe s -> Set String -> Q [Dec] -> ImplSpec s
forall s. Maybe s -> Set String -> Q [Dec] -> ImplSpec s
ImplSpec Maybe s
s Set String
deps (String -> Maybe Inline -> Q [Dec] -> Q [Dec]
applyInline String
fName Maybe Inline
inl Q [Dec]
dec))))

applyInline :: String -> Maybe Inline -> Q [Dec] -> Q [Dec]
#if MIN_VERSION_template_haskell(2,8,0)
applyInline :: String -> Maybe Inline -> Q [Dec] -> Q [Dec]
applyInline String
n (Just Inline
inl) = ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Pragma -> Dec
PragmaD (Name -> Inline -> RuleMatch -> Phases -> Pragma
InlineP (String -> Name
mkName String
n) Inline
inl RuleMatch
FunLike Phases
AllPhases) Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:)
#elif MIN_VERSION_template_haskell(2,4,0)
applyInline n (Just inl)
    | inl /= Inlinable  = fmap (PragmaD (InlineP (mkName n) (InlineSpec (inl == Inline) False Nothing)) :)
#endif
applyInline String
_ Maybe Inline
_ = Q [Dec] -> Q [Dec]
forall a. a -> a
id


-- |Specify the score associated with the current implementation.  Only one 
-- invocation of either 'score' or 'cost' may be used per implementation.
score :: s -> Implementation s ()
score :: forall s. s -> Implementation s ()
score s
s = State (Maybe s, Set String, Maybe Inline) () -> Implementation s ()
forall s a.
State (Maybe s, Set String, Maybe Inline) a -> Implementation s a
Implementation (State (Maybe s, Set String, Maybe Inline) ()
 -> Implementation s ())
-> State (Maybe s, Set String, Maybe Inline) ()
-> Implementation s ()
forall a b. (a -> b) -> a -> b
$ do
    (Maybe s
oldS, Set String
deps, Maybe Inline
inl) <- StateT
  (Maybe s, Set String, Maybe Inline)
  Identity
  (Maybe s, Set String, Maybe Inline)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    case Maybe s
oldS of
        Maybe s
Nothing -> (Maybe s, Set String, Maybe Inline)
-> State (Maybe s, Set String, Maybe Inline) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (s -> Maybe s
forall a. a -> Maybe a
Just s
s, Set String
deps, Maybe Inline
inl)
        Just s
_  -> String -> State (Maybe s, Set String, Maybe Inline) ()
forall a. HasCallStack => String -> a
error String
"score: score was already set"

-- |Specify the cost (negated score) associated with the current implementation.
-- Only one invocation of either 'score' or 'cost' may be used per implementation.
cost :: Num s => s -> Implementation s ()
cost :: forall s. Num s => s -> Implementation s ()
cost = s -> Implementation s ()
forall s. s -> Implementation s ()
score (s -> Implementation s ()) -> (s -> s) -> s -> Implementation s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> s
forall a. Num a => a -> a
negate

-- |Specify that the current implementation must not be used unless the given
-- function is already defined.  If this implementation can be used
-- mutually-recursively with _ALL_ potential implementations of some other
-- function, then a dependency need not be declared on that function.
dependsOn :: String -> Implementation s ()
dependsOn :: forall s. String -> Implementation s ()
dependsOn String
dep = State (Maybe s, Set String, Maybe Inline) () -> Implementation s ()
forall s a.
State (Maybe s, Set String, Maybe Inline) a -> Implementation s a
Implementation (State (Maybe s, Set String, Maybe Inline) ()
 -> Implementation s ())
-> State (Maybe s, Set String, Maybe Inline) ()
-> Implementation s ()
forall a b. (a -> b) -> a -> b
$ do
    (Maybe s
s, Set String
deps, Maybe Inline
inl) <- StateT
  (Maybe s, Set String, Maybe Inline)
  Identity
  (Maybe s, Set String, Maybe Inline)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    (Maybe s, Set String, Maybe Inline)
-> State (Maybe s, Set String, Maybe Inline) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Maybe s
s, String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
S.insert String
dep Set String
deps, Maybe Inline
inl)

setInline :: Inline -> Implementation s ()
setInline :: forall s. Inline -> Implementation s ()
setInline Inline
inl = State (Maybe s, Set String, Maybe Inline) () -> Implementation s ()
forall s a.
State (Maybe s, Set String, Maybe Inline) a -> Implementation s a
Implementation (State (Maybe s, Set String, Maybe Inline) ()
 -> Implementation s ())
-> State (Maybe s, Set String, Maybe Inline) ()
-> Implementation s ()
forall a b. (a -> b) -> a -> b
$ do
    (Maybe s
s, Set String
deps, Maybe Inline
_) <- StateT
  (Maybe s, Set String, Maybe Inline)
  Identity
  (Maybe s, Set String, Maybe Inline)
forall (m :: * -> *) s. Monad m => StateT s m s
get
    (Maybe s, Set String, Maybe Inline)
-> State (Maybe s, Set String, Maybe Inline) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Maybe s
s, Set String
deps, Inline -> Maybe Inline
forall a. a -> Maybe a
Just Inline
inl)

-- |Specify that an 'Implementation' should be annotated with an INLINE pragma.
-- Under GHC versions earlier than 6.12 this is a no-op, because those Template
-- Haskell implementations do not support pragmas.
inline :: Implementation s ()

-- |Specify that an 'Implementation' should be annotated with an INLINEABLE pragma.
-- Under GHC versions earlier than 7.6 this is a no-op, because those Template
-- Haskell implementations do not support this pragma.
inlinable :: Implementation s ()

-- |Specify that an 'Implementation' should be annotated with a NOINLINE pragma.
-- Under GHC versions earlier than 6.12 this is a no-op, because those Template
-- Haskell implementations do not support pragmas.
noinline :: Implementation s ()

inline :: forall s. Implementation s ()
inline = Inline -> Implementation s ()
forall s. Inline -> Implementation s ()
setInline Inline
Inline
inlinable :: forall s. Implementation s ()
inlinable = Inline -> Implementation s ()
forall s. Inline -> Implementation s ()
setInline Inline
Inlinable
noinline :: forall s. Implementation s ()
noinline = Inline -> Implementation s ()
forall s. Inline -> Implementation s ()
setInline Inline
NoInline