Use Typeable instead of ADT
This commit is contained in:
parent
6ffb83d46f
commit
27ff2eef89
9 changed files with 132 additions and 69 deletions
39
src/Hakyll/Core/CompiledItem.hs
Normal file
39
src/Hakyll/Core/CompiledItem.hs
Normal file
|
@ -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"
|
|
@ -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 >>=)
|
||||
|
|
|
@ -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'
|
||||
|
|
|
@ -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
|
||||
|
||||
-- Generate all the targets in order
|
||||
map' <- foldM addTarget M.empty orderedTargets
|
||||
|
||||
let -- Fetch the routes
|
||||
-- Fetch the routes
|
||||
route' = rulesRoute ruleSet
|
||||
|
||||
forM_ (M.toList map') $ \(id', result) ->
|
||||
-- Generate all the targets in order
|
||||
_ <- foldM (addTarget route') M.empty orderedTargets
|
||||
|
||||
putStrLn "DONE."
|
||||
where
|
||||
addTarget route' map' (id', targ) = do
|
||||
compiled <- runTarget targ id' (dependencyLookup map') provider store
|
||||
putStrLn $ "Generated target: " ++ show id'
|
||||
|
||||
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue