From 27ff2eef890d86001c0210dd2d20639d34fbd32c Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 28 Dec 2010 11:12:45 +0100 Subject: Use Typeable instead of ADT --- src/Hakyll/Core/CompiledItem.hs | 39 ++++++++++++++++++++++++++++++++++++++ src/Hakyll/Core/Compiler.hs | 29 +++++++++++++++++----------- src/Hakyll/Core/Rules.hs | 39 +++++++++++++++++++++++++------------- src/Hakyll/Core/Run.hs | 34 ++++++++++++++++++++------------- src/Hakyll/Core/Target.hs | 5 ++--- src/Hakyll/Core/Target/Internal.hs | 29 ++++++++++++---------------- 6 files changed, 118 insertions(+), 57 deletions(-) create mode 100644 src/Hakyll/Core/CompiledItem.hs (limited to 'src/Hakyll/Core') diff --git a/src/Hakyll/Core/CompiledItem.hs b/src/Hakyll/Core/CompiledItem.hs new file mode 100644 index 0000000..d191e2a --- /dev/null +++ b/src/Hakyll/Core/CompiledItem.hs @@ -0,0 +1,39 @@ +-- | A module containing a box datatype representing a compiled item. This +-- item can be of any type, given that a few restrictions hold (e.g. we want +-- a 'Typeable' instance to perform type-safe casts). +-- +{-# LANGUAGE ExistentialQuantification #-} +module Hakyll.Core.CompiledItem + ( CompiledItem + , compiledItem + , unCompiledItem + ) where + +import Data.Binary (Binary) +import Data.Typeable (Typeable, cast) + +import Hakyll.Core.Writable + +-- | Box type for a compiled item +-- +data CompiledItem = forall a. (Binary a, Typeable a, Writable a) + => CompiledItem a + +instance Writable CompiledItem where + write p (CompiledItem x) = write p x + +-- | Box a value into a 'CompiledItem' +-- +compiledItem :: (Binary a, Typeable a, Writable a) + => a + -> CompiledItem +compiledItem = CompiledItem + +-- | Unbox a value from a 'CompiledItem' +-- +unCompiledItem :: (Binary a, Typeable a, Writable a) + => CompiledItem + -> a +unCompiledItem (CompiledItem x) = case cast x of + Just x' -> x' + Nothing -> error "unCompiledItem: Unsupported type" diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index 4e8b642..60c8ecb 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -16,10 +16,14 @@ import Control.Monad.State (State, modify, runState) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Data.Set (Set) import qualified Data.Set as S +import Data.Typeable (Typeable) +import Data.Binary (Binary) import Hakyll.Core.Identifier import Hakyll.Core.Target import Hakyll.Core.Target.Internal +import Hakyll.Core.CompiledItem +import Hakyll.Core.Writable -- | A set of dependencies -- @@ -27,7 +31,7 @@ type Dependencies = Set Identifier -- | Add one dependency -- -addDependency :: Identifier -> CompilerM a () +addDependency :: Identifier -> CompilerM () addDependency dependency = CompilerM $ modify $ addDependency' where addDependency' x = x @@ -36,8 +40,8 @@ addDependency dependency = CompilerM $ modify $ addDependency' -- | Environment in which a compiler runs -- -data CompilerEnvironment a = CompilerEnvironment - { compilerIdentifier :: Identifier -- ^ Target identifier +data CompilerEnvironment = CompilerEnvironment + { compilerIdentifier :: Identifier -- ^ Target identifier } -- | State carried along by a compiler @@ -48,18 +52,18 @@ data CompilerState = CompilerState -- | The compiler monad -- -newtype CompilerM a b = CompilerM - { unCompilerM :: ReaderT (CompilerEnvironment a) (State CompilerState) b +newtype CompilerM a = CompilerM + { unCompilerM :: ReaderT CompilerEnvironment (State CompilerState) a } deriving (Monad, Functor, Applicative) -- | Simplified type for a compiler generating a target (which covers most -- cases) -- -type Compiler a = CompilerM a (TargetM a a) +type Compiler a = CompilerM (TargetM a) -- | Run a compiler, yielding the resulting target and it's dependencies -- -runCompiler :: Compiler a -> Identifier -> (TargetM a a, Dependencies) +runCompiler :: Compiler a -> Identifier -> (TargetM a, Dependencies) runCompiler compiler identifier = second compilerDependencies $ runState (runReaderT (unCompilerM compiler) env) state where @@ -69,15 +73,18 @@ runCompiler compiler identifier = second compilerDependencies $ -- | Require another target. Using this function ensures automatic handling of -- dependencies -- -require :: Identifier +require :: (Binary a, Typeable a, Writable a) + => Identifier -> Compiler a require identifier = do addDependency identifier - return $ TargetM $ flip targetDependencyLookup identifier <$> ask + return $ TargetM $ do + lookup' <- targetDependencyLookup <$> ask + return $ unCompiledItem $ lookup' identifier -- | Construct a target from a string, this string being the content of the -- resource. -- -compileFromString :: (String -> TargetM a a) -- ^ Function to create the target - -> Compiler a -- ^ Resulting compiler +compileFromString :: (String -> TargetM a) -- ^ Function to create the target + -> Compiler a -- ^ Resulting compiler compileFromString = return . (getResourceString >>=) diff --git a/src/Hakyll/Core/Rules.hs b/src/Hakyll/Core/Rules.hs index d15b3b9..021af5d 100644 --- a/src/Hakyll/Core/Rules.hs +++ b/src/Hakyll/Core/Rules.hs @@ -15,57 +15,69 @@ module Hakyll.Core.Rules import Control.Applicative (Applicative, (<$>)) import Control.Monad.Writer import Control.Monad.Reader +import Control.Arrow (second) + +import Data.Typeable (Typeable) +import Data.Binary (Binary) import Hakyll.Core.ResourceProvider import Hakyll.Core.Identifier import Hakyll.Core.Identifier.Pattern import Hakyll.Core.Compiler import Hakyll.Core.Route +import Hakyll.Core.CompiledItem +import Hakyll.Core.Writable -- | A collection of rules for the compilation process -- -data RuleSet a = RuleSet +data RuleSet = RuleSet { rulesRoute :: Route - , rulesCompilers :: [(Identifier, Compiler a)] + , rulesCompilers :: [(Identifier, Compiler CompiledItem)] } -instance Monoid (RuleSet a) where +instance Monoid RuleSet where mempty = RuleSet mempty mempty mappend (RuleSet r1 c1) (RuleSet r2 c2) = RuleSet (mappend r1 r2) (mappend c1 c2) -- | The monad used to compose rules -- -newtype RulesM a b = RulesM - { unRulesM :: ReaderT ResourceProvider (Writer (RuleSet a)) b +newtype RulesM a = RulesM + { unRulesM :: ReaderT ResourceProvider (Writer RuleSet) a } deriving (Monad, Functor, Applicative) -- | Simplification of the RulesM type; usually, it will not return any -- result. -- -type Rules a = RulesM a () +type Rules = RulesM () -- | Run a Rules monad, resulting in a 'RuleSet' -- -runRules :: Rules a -> ResourceProvider -> RuleSet a +runRules :: Rules -> ResourceProvider -> RuleSet runRules rules provider = execWriter $ runReaderT (unRulesM rules) provider -- | Add a route -- -addRoute :: Route -> Rules a +addRoute :: Route -> Rules addRoute route' = RulesM $ tell $ RuleSet route' mempty -- | Add a number of compilers -- -addCompilers :: [(Identifier, Compiler a)] -> Rules a -addCompilers compilers = RulesM $ tell $ RuleSet mempty compilers +addCompilers :: (Binary a, Typeable a, Writable a) + => [(Identifier, Compiler a)] + -> Rules +addCompilers compilers = RulesM $ tell $ RuleSet mempty $ + map (second boxCompiler) compilers + where + boxCompiler = fmap (fmap compiledItem) -- | Add a compilation rule -- -- This instructs all resources matching the given pattern to be compiled using -- the given compiler -- -compile :: Pattern -> Compiler a -> Rules a +compile :: (Binary a, Typeable a, Writable a) + => Pattern -> Compiler a -> Rules compile pattern compiler = RulesM $ do identifiers <- matches pattern . resourceList <$> ask unRulesM $ addCompilers $ zip identifiers (repeat compiler) @@ -74,10 +86,11 @@ compile pattern compiler = RulesM $ do -- -- This sets a compiler for the given identifier -- -create :: Identifier -> Compiler a -> RulesM a () +create :: (Binary a, Typeable a, Writable a) + => Identifier -> Compiler a -> Rules create identifier compiler = addCompilers [(identifier, compiler)] -- | Add a route -- -route :: Pattern -> Route -> RulesM a () +route :: Pattern -> Route -> Rules route pattern route' = addRoute $ ifMatch pattern route' diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index b5d6012..e2ff9f3 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -5,6 +5,9 @@ module Hakyll.Core.Run where import Control.Arrow ((&&&)) import Control.Monad (foldM, forM_) import qualified Data.Map as M +import Data.Monoid (mempty) +import Data.Typeable (Typeable) +import Data.Binary (Binary) import Hakyll.Core.Route import Hakyll.Core.Compiler @@ -16,14 +19,15 @@ import Hakyll.Core.DirectedGraph import Hakyll.Core.DirectedGraph.DependencySolver import Hakyll.Core.Writable import Hakyll.Core.Store +import Hakyll.Core.CompiledItem -hakyll :: Writable a => Rules a -> IO () +hakyll :: Rules -> IO () hakyll rules = do store <- makeStore "_store" provider <- fileResourceProvider hakyllWith rules provider store -hakyllWith :: Writable a => Rules a -> ResourceProvider -> Store -> IO () +hakyllWith :: Rules -> ResourceProvider -> Store -> IO () hakyllWith rules provider store = do let -- Get the rule set ruleSet = runRules rules provider @@ -48,22 +52,26 @@ hakyllWith rules provider store = do -- Join the order with the targets again orderedTargets = map (id &&& (targetMap M.!)) ordered + -- Fetch the routes + route' = rulesRoute ruleSet + -- Generate all the targets in order - map' <- foldM addTarget M.empty orderedTargets + _ <- foldM (addTarget route') M.empty orderedTargets - let -- Fetch the routes - route' = rulesRoute ruleSet + putStrLn "DONE." + where + addTarget route' map' (id', targ) = do + compiled <- runTarget targ id' (dependencyLookup map') provider store + putStrLn $ "Generated target: " ++ show id' - forM_ (M.toList map') $ \(id', result) -> case runRoute route' id' of Nothing -> return () Just r -> do putStrLn $ "Routing " ++ show id' ++ " to " ++ r - write r result + write r compiled - putStrLn "DONE." - where - addTarget map' (id', targ) = do - result <- runTarget targ id' (map' M.!) provider store - putStrLn $ "Generated target: " ++ show id' - return $ M.insert id' result map' + return $ M.insert id' compiled map' + + dependencyLookup map' id' = case M.lookup id' map' of + Nothing -> error $ "dependencyLookup: " ++ show id' ++ " not found" + Just d -> d diff --git a/src/Hakyll/Core/Target.hs b/src/Hakyll/Core/Target.hs index b8740bc..452fb57 100644 --- a/src/Hakyll/Core/Target.hs +++ b/src/Hakyll/Core/Target.hs @@ -4,7 +4,6 @@ module Hakyll.Core.Target ( DependencyLookup , TargetM - , Target , runTarget , getIdentifier , getResourceString @@ -20,12 +19,12 @@ import Hakyll.Core.ResourceProvider -- | Get the current identifier -- -getIdentifier :: TargetM a Identifier +getIdentifier :: TargetM Identifier getIdentifier = TargetM $ targetIdentifier <$> ask -- | Get the resource content as a string -- -getResourceString :: TargetM a String +getResourceString :: TargetM String getResourceString = TargetM $ do provider <- targetResourceProvider <$> ask identifier <- unTargetM getIdentifier diff --git a/src/Hakyll/Core/Target/Internal.hs b/src/Hakyll/Core/Target/Internal.hs index e68de33..62fb4fc 100644 --- a/src/Hakyll/Core/Target/Internal.hs +++ b/src/Hakyll/Core/Target/Internal.hs @@ -1,11 +1,10 @@ -- | Internal structure of a Target, not exported outside of the library -- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, Rank2Types #-} module Hakyll.Core.Target.Internal ( DependencyLookup , TargetEnvironment (..) , TargetM (..) - , Target , runTarget ) where @@ -17,18 +16,19 @@ import Control.Monad.State (StateT, evalStateT) import Hakyll.Core.Identifier import Hakyll.Core.ResourceProvider import Hakyll.Core.Store +import Hakyll.Core.CompiledItem -- | A lookup with which we can get dependencies -- -type DependencyLookup a = Identifier -> a +type DependencyLookup = Identifier -> CompiledItem -- | Environment for the target monad -- -data TargetEnvironment a = TargetEnvironment - { targetIdentifier :: Identifier -- ^ Identifier - , targetDependencyLookup :: DependencyLookup a -- ^ Dependency lookup - , targetResourceProvider :: ResourceProvider -- ^ To get resources - , targetStore :: Store -- ^ Store for caching +data TargetEnvironment = TargetEnvironment + { targetIdentifier :: Identifier -- ^ Identifier + , targetDependencyLookup :: DependencyLookup -- ^ Dependency lookup + , targetResourceProvider :: ResourceProvider -- ^ To get resources + , targetStore :: Store -- ^ Store for caching } -- | State for the target monad @@ -40,20 +40,15 @@ data TargetState = TargetState -- | Monad for targets. In this monad, the user can compose targets and describe -- how they should be created. -- -newtype TargetM a b = TargetM - { unTargetM :: ReaderT (TargetEnvironment a) (StateT TargetState IO) b +newtype TargetM a = TargetM + { unTargetM :: ReaderT TargetEnvironment (StateT TargetState IO) a } deriving (Monad, Functor, Applicative, MonadIO) --- | Simplification of the 'TargetM' type for concrete cases: the type of the --- returned item should equal the type of the dependencies. --- -type Target a = TargetM a a - -- | Run a target, yielding an actual result. -- -runTarget :: Target a +runTarget :: TargetM a -> Identifier - -> DependencyLookup a + -> DependencyLookup -> ResourceProvider -> Store -> IO a -- cgit v1.2.3