{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-}
module Language.Haskell.TH.FlexibleDefaults.DSL where
#if !(MIN_VERSION_base(4,8,0))
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 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 Semigroup.Semigroup (Impls s) where
(<>) (Impls x) (Impls y) = Impls (M.unionWith mappend x y)
instance Monoid (Impls s) where
mempty = Impls mempty
mappend = (Semigroup.<>)
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 !MIN_VERSION_template_haskell(2,8,0)
data Inline = NoInline | Inline | Inlinable
deriving (Eq, Show)
#endif
newtype Implementation s a = Implementation (State (Maybe s, S.Set String, Maybe Inline) 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))))
applyInline :: String -> Maybe Inline -> Q [Dec] -> Q [Dec]
#if MIN_VERSION_template_haskell(2,8,0)
applyInline n (Just inl) = fmap (PragmaD (InlineP (mkName n) inl FunLike AllPhases) :)
#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 _ _ = id
score :: s -> Implementation s ()
score s = Implementation $ do
(oldS, deps, inl) <- get
case oldS of
Nothing -> put (Just s, deps, inl)
Just _ -> error "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 :: Inline -> Implementation s ()
setInline inl = Implementation $ do
(s, deps, _) <- get
put (s, deps, Just inl)
inline :: Implementation s ()
inlinable :: Implementation s ()
noinline :: Implementation s ()
inline = setInline Inline
inlinable = setInline Inlinable
noinline = setInline NoInline