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 ++++++++++++---------------- src/Hakyll/Web/FileType.hs | 2 +- src/Hakyll/Web/Page.hs | 4 +++- src/Hakyll/Web/Pandoc.hs | 18 +++++++++--------- 9 files changed, 131 insertions(+), 68 deletions(-) create mode 100644 src/Hakyll/Core/CompiledItem.hs (limited to 'src/Hakyll') 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 diff --git a/src/Hakyll/Web/FileType.hs b/src/Hakyll/Web/FileType.hs index 4da1439..a958fed 100644 --- a/src/Hakyll/Web/FileType.hs +++ b/src/Hakyll/Web/FileType.hs @@ -51,5 +51,5 @@ fileType = fileType' . takeExtension -- | Get the file type for the current file -- -getFileType :: TargetM a FileType +getFileType :: TargetM FileType getFileType = fileType . toFilePath <$> getIdentifier diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs index 92303c1..78178cb 100644 --- a/src/Hakyll/Web/Page.hs +++ b/src/Hakyll/Web/Page.hs @@ -2,6 +2,7 @@ -- type 'String') and number of metadata fields. This type is used to represent -- pages on your website. -- +{-# LANGUAGE DeriveDataTypeable #-} module Hakyll.Web.Page ( Page (..) , toMap @@ -12,6 +13,7 @@ import Control.Applicative ((<$>), (<*>)) import Data.Map (Map) import qualified Data.Map as M import Data.Binary (Binary, get, put) +import Data.Typeable (Typeable) import Hakyll.Core.Writable @@ -20,7 +22,7 @@ import Hakyll.Core.Writable data Page a = Page { pageMetadata :: Map String String , pageBody :: a - } + } deriving (Show, Typeable) instance Functor Page where fmap f (Page m b) = Page m (f b) diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs index 57fd1ac..17cac81 100644 --- a/src/Hakyll/Web/Pandoc.hs +++ b/src/Hakyll/Web/Pandoc.hs @@ -29,9 +29,9 @@ import Hakyll.Web.Page -- | Read a string using pandoc, with the default options -- -readPandoc :: FileType -- ^ File type, determines how parsing happens - -> String -- ^ String to read - -> Pandoc -- ^ Resulting document +readPandoc :: FileType -- ^ File type, determines how parsing happens + -> String -- ^ String to read + -> Pandoc -- ^ Resulting document readPandoc = readPandocWith defaultParserState -- | Read a string using pandoc, with the supplied options @@ -51,8 +51,8 @@ readPandocWith state fileType' = case fileType' of -- | Write a document (as HTML) using pandoc, with the default options -- -writePandoc :: Pandoc -- ^ Document to write - -> String -- ^ Resulting HTML +writePandoc :: Pandoc -- ^ Document to write + -> String -- ^ Resulting HTML writePandoc = writePandocWith defaultWriterOptions -- | Write a document (as HTML) using pandoc, with the supplied options @@ -64,19 +64,19 @@ writePandocWith = P.writeHtmlString -- | Read the resource using pandoc -- -pageReadPandoc :: Page String -> TargetM a (Page Pandoc) +pageReadPandoc :: Page String -> TargetM (Page Pandoc) pageReadPandoc = pageReadPandocWith defaultParserState -- | Read the resource using pandoc -- -pageReadPandocWith :: P.ParserState -> Page String -> TargetM a (Page Pandoc) +pageReadPandocWith :: P.ParserState -> Page String -> TargetM (Page Pandoc) pageReadPandocWith state page = do fileType' <- getFileType return $ readPandocWith state fileType' <$> page -- | Render the resource using pandoc -- -pageRenderPandoc :: Page String -> TargetM a (Page String) +pageRenderPandoc :: Page String -> TargetM (Page String) pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions -- | Render the resource using pandoc @@ -84,7 +84,7 @@ pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions pageRenderPandocWith :: P.ParserState -> P.WriterOptions -> Page String - -> TargetM a (Page String) + -> TargetM (Page String) pageRenderPandocWith state options page = do pandoc <- pageReadPandocWith state page return $ writePandocWith options <$> pandoc -- cgit v1.2.3