Use Typeable instead of ADT

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