summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJasper Van der Jeugt <jaspervdj@gmail.com>2010-12-28 11:12:45 +0100
committerJasper Van der Jeugt <jaspervdj@gmail.com>2010-12-28 11:12:45 +0100
commit27ff2eef890d86001c0210dd2d20639d34fbd32c (patch)
tree8a6c7fcce735ce99d49e7511f8bac0b8829a70a2
parent6ffb83d46f0e1e82c38fa959464a98f6087f417f (diff)
downloadhakyll-27ff2eef890d86001c0210dd2d20639d34fbd32c.tar.gz
Use Typeable instead of ADT
-rw-r--r--src/Hakyll/Core/CompiledItem.hs39
-rw-r--r--src/Hakyll/Core/Compiler.hs29
-rw-r--r--src/Hakyll/Core/Rules.hs39
-rw-r--r--src/Hakyll/Core/Run.hs34
-rw-r--r--src/Hakyll/Core/Target.hs5
-rw-r--r--src/Hakyll/Core/Target/Internal.hs29
-rw-r--r--src/Hakyll/Web/FileType.hs2
-rw-r--r--src/Hakyll/Web/Page.hs4
-rw-r--r--src/Hakyll/Web/Pandoc.hs18
9 files changed, 131 insertions, 68 deletions
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