module Language.Haskell.TH.FlexibleDefaults.DSL where
import Control.Applicative
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State
import Control.Monad.Trans.Writer
import Data.List
import Data.Monoid
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 Impls s = Impls { unImpls :: M.Map String [ImplSpec s] }
instance Functor Impls where
fmap f (Impls m) = Impls (M.map (map (fmap f)) m)
instance Monoid (Impls s) where
mempty = Impls mempty
mappend (Impls x) (Impls y) = Impls (M.unionWith mappend x y)
newtype Defaults s a = Defaults { unDefaults :: Writer (Impls s) a }
deriving (Functor, Applicative, Monad)
addImplSpecs :: String -> [ImplSpec s] -> Defaults s ()
addImplSpecs f = Defaults . tell . Impls . M.singleton f
addImplSpec :: String -> ImplSpec s -> Defaults s ()
addImplSpec f = addImplSpecs f . (:[])
toProblem :: (Ord s, Monoid s) => Defaults s () -> Problem s
toProblem
= fmap (sortBy (flip (comparing scoreImplSpec)))
. unImpls
. snd
. runWriter
. unDefaults
scoreBy :: (a -> b) -> Defaults a t -> Defaults b t
scoreBy f = Defaults . mapWriterT (fmap (fmap (fmap f))) . unDefaults
newtype Function s a = Function (ReaderT String (Defaults s) a)
deriving (Functor, Applicative, Monad)
function :: String -> Function s a -> Defaults s a
function f (Function x) = do
requireFunction f
runReaderT x f
requireFunction :: String -> Defaults s ()
requireFunction f = addImplSpecs f []
#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 612
type InlineSpec = ()
#endif
newtype Implementation s a = Implementation (State (Maybe s, S.Set String, Maybe InlineSpec) a)
deriving (Functor, Applicative, Monad)
implementation :: Implementation s (Q [Dec]) -> Function s ()
implementation (Implementation x) = case runState x (Nothing, S.empty, Nothing) of
(dec, (s, deps, inl)) -> Function $ do
fName <- ask
ReaderT (const (addImplSpec fName (ImplSpec s deps (applyInline fName inl dec))))
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612
applyInline :: String -> Maybe InlineSpec -> Q [Dec] -> Q [Dec]
applyInline _ Nothing = id
applyInline n (Just inl) = fmap (PragmaD (InlineP (mkName n) inl) :)
#else
applyInline :: String -> Maybe InlineSpec -> Q [Dec] -> Q [Dec]
applyInline _ _ = id
#endif
score :: s -> Implementation s ()
score s = Implementation $ do
(oldS, deps, inl) <- get
case oldS of
Nothing -> put (Just s, deps, inl)
Just _ -> fail "score: score was already set"
cost :: Num s => s -> Implementation s ()
cost = score . negate
dependsOn :: String -> Implementation s ()
dependsOn dep = Implementation $ do
(s, deps, inl) <- get
put (s, S.insert dep deps, inl)
setInline :: InlineSpec -> Implementation s ()
setInline inl = Implementation $ do
(s, deps, _) <- get
put (s, deps, Just inl)
inline :: Implementation s ()
noinline :: Implementation s ()
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612
inline = setInline (InlineSpec True False Nothing)
noinline = setInline (InlineSpec False False Nothing)
#else
inline = return ()
noinline = return ()
#endif