27ff2ee · hakyll · git.iko.soy

git.iko.soy/hakyll

Use Typeable instead of ADT

commit27ff2eef890d86001c0210dd2d20639d34fbd32c authorJasper Van der Jeugt <jaspervdj@gmail.com> dateTue 28 Dec 2010, 11:12 (16 years ago) parent6ffb83d

9 files changed+131−68

compare with master

unifiedsplit

src/Hakyll/Core/CompiledItem.hs+39 src/Hakyll/Core/Compiler.hs+18−11 src/Hakyll/Core/Rules.hs+26−13 src/Hakyll/Core/Run.hs+21−13 src/Hakyll/Core/Target.hs+2−3 src/Hakyll/Core/Target/Internal.hs+12−17 src/Hakyll/Web/FileType.hs+1−1 src/Hakyll/Web/Page.hs+3−1 src/Hakyll/Web/Pandoc.hs+9−9

src/Hakyll/Core/CompiledItem.hsnew file+39

@@ -0,0 +1,39 @@

1+-- | A module containing a box datatype representing a compiled item. This

2+-- item can be of any type, given that a few restrictions hold (e.g. we want

3+-- a 'Typeable' instance to perform type-safe casts).

4+--

5+{-# LANGUAGE ExistentialQuantification #-}

6+module Hakyll.Core.CompiledItem

7+ ( CompiledItem

8+ , compiledItem

9+ , unCompiledItem

10+ ) where

11+

12+import Data.Binary (Binary)

13+import Data.Typeable (Typeable, cast)

14+

15+import Hakyll.Core.Writable

16+

17+-- | Box type for a compiled item

18+--

19+data CompiledItem = forall a. (Binary a, Typeable a, Writable a)

20+ => CompiledItem a

21+

22+instance Writable CompiledItem where

23+ write p (CompiledItem x) = write p x

24+

25+-- | Box a value into a 'CompiledItem'

26+--

27+compiledItem :: (Binary a, Typeable a, Writable a)

28+ => a

29+ -> CompiledItem

30+compiledItem = CompiledItem

31+

32+-- | Unbox a value from a 'CompiledItem'

33+--

34+unCompiledItem :: (Binary a, Typeable a, Writable a)

35+ => CompiledItem

36+ -> a

37+unCompiledItem (CompiledItem x) = case cast x of

38+ Just x' -> x'

39+ Nothing -> error "unCompiledItem: Unsupported type"

src/Hakyll/Core/Compiler.hs+18−11

@@ -16,10 +16,14 @@ import Control.Monad.State (State, modify, runState)

1616import Control.Monad.Reader (ReaderT, ask, runReaderT)

1717import Data.Set (Set)

1818import qualified Data.Set as S

19+import Data.Typeable (Typeable)

20+import Data.Binary (Binary)

1921

2022import Hakyll.Core.Identifier

2123import Hakyll.Core.Target

2224import Hakyll.Core.Target.Internal

25+import Hakyll.Core.CompiledItem

26+import Hakyll.Core.Writable

2327

2428-- | A set of dependencies

2529--

@@ -27,7 +31,7 @@ type Dependencies = Set Identifier

2731

2832-- | Add one dependency

2933--

30−addDependency :: Identifier -> CompilerM a ()

34+addDependency :: Identifier -> CompilerM ()

3135addDependency dependency = CompilerM $ modify $ addDependency'

3236 where

3337 addDependency' x = x

@@ -36,8 +40,8 @@ addDependency dependency = CompilerM $ modify $ addDependency'

3640

3741-- | Environment in which a compiler runs

3842--

39−data CompilerEnvironment a = CompilerEnvironment

40− { compilerIdentifier :: Identifier -- ^ Target identifier

43+data CompilerEnvironment = CompilerEnvironment

44+ { compilerIdentifier :: Identifier -- ^ Target identifier

4145 }

4246

4347-- | State carried along by a compiler

@@ -48,18 +52,18 @@ data CompilerState = CompilerState

4852

4953-- | The compiler monad

5054--

51−newtype CompilerM a b = CompilerM

52− { unCompilerM :: ReaderT (CompilerEnvironment a) (State CompilerState) b

55+newtype CompilerM a = CompilerM

56+ { unCompilerM :: ReaderT CompilerEnvironment (State CompilerState) a

5357 } deriving (Monad, Functor, Applicative)

5458

5559-- | Simplified type for a compiler generating a target (which covers most

5660-- cases)

5761--

58−type Compiler a = CompilerM a (TargetM a a)

62+type Compiler a = CompilerM (TargetM a)

5963

6064-- | Run a compiler, yielding the resulting target and it's dependencies

6165--

62−runCompiler :: Compiler a -> Identifier -> (TargetM a a, Dependencies)

66+runCompiler :: Compiler a -> Identifier -> (TargetM a, Dependencies)

6367runCompiler compiler identifier = second compilerDependencies $

6468 runState (runReaderT (unCompilerM compiler) env) state

6569 where

@@ -69,15 +73,18 @@ runCompiler compiler identifier = second compilerDependencies $

6973-- | Require another target. Using this function ensures automatic handling of

7074-- dependencies

7175--

72−require :: Identifier

76+require :: (Binary a, Typeable a, Writable a)

77+ => Identifier

7378 -> Compiler a

7479require identifier = do

7580 addDependency identifier

76− return $ TargetM $ flip targetDependencyLookup identifier <$> ask

81+ return $ TargetM $ do

82+ lookup' <- targetDependencyLookup <$> ask

83+ return $ unCompiledItem $ lookup' identifier

7784

7885-- | Construct a target from a string, this string being the content of the

7986-- resource.

8087--

81−compileFromString :: (String -> TargetM a a) -- ^ Function to create the target

82− -> Compiler a -- ^ Resulting compiler

88+compileFromString :: (String -> TargetM a) -- ^ Function to create the target

89+ -> Compiler a -- ^ Resulting compiler

8390compileFromString = return . (getResourceString >>=)

src/Hakyll/Core/Rules.hs+26−13

@@ -15,57 +15,69 @@ module Hakyll.Core.Rules

1515import Control.Applicative (Applicative, (<$>))

1616import Control.Monad.Writer

1717import Control.Monad.Reader

18+import Control.Arrow (second)

19+

20+import Data.Typeable (Typeable)

21+import Data.Binary (Binary)

1822

1923import Hakyll.Core.ResourceProvider

2024import Hakyll.Core.Identifier

2125import Hakyll.Core.Identifier.Pattern

2226import Hakyll.Core.Compiler

2327import Hakyll.Core.Route

28+import Hakyll.Core.CompiledItem

29+import Hakyll.Core.Writable

2430

2531-- | A collection of rules for the compilation process

2632--

27−data RuleSet a = RuleSet

33+data RuleSet = RuleSet

2834 { rulesRoute :: Route

29− , rulesCompilers :: [(Identifier, Compiler a)]

35+ , rulesCompilers :: [(Identifier, Compiler CompiledItem)]

3036 }

3137

32−instance Monoid (RuleSet a) where

38+instance Monoid RuleSet where

3339 mempty = RuleSet mempty mempty

3440 mappend (RuleSet r1 c1) (RuleSet r2 c2) =

3541 RuleSet (mappend r1 r2) (mappend c1 c2)

3642

3743-- | The monad used to compose rules

3844--

39−newtype RulesM a b = RulesM

40− { unRulesM :: ReaderT ResourceProvider (Writer (RuleSet a)) b

45+newtype RulesM a = RulesM

46+ { unRulesM :: ReaderT ResourceProvider (Writer RuleSet) a

4147 } deriving (Monad, Functor, Applicative)

4248

4349-- | Simplification of the RulesM type; usually, it will not return any

4450-- result.

4551--

46−type Rules a = RulesM a ()

52+type Rules = RulesM ()

4753

4854-- | Run a Rules monad, resulting in a 'RuleSet'

4955--

50−runRules :: Rules a -> ResourceProvider -> RuleSet a

56+runRules :: Rules -> ResourceProvider -> RuleSet

5157runRules rules provider = execWriter $ runReaderT (unRulesM rules) provider

5258

5359-- | Add a route

5460--

55−addRoute :: Route -> Rules a

61+addRoute :: Route -> Rules

5662addRoute route' = RulesM $ tell $ RuleSet route' mempty

5763

5864-- | Add a number of compilers

5965--

60−addCompilers :: [(Identifier, Compiler a)] -> Rules a

61−addCompilers compilers = RulesM $ tell $ RuleSet mempty compilers

66+addCompilers :: (Binary a, Typeable a, Writable a)

67+ => [(Identifier, Compiler a)]

68+ -> Rules

69+addCompilers compilers = RulesM $ tell $ RuleSet mempty $

70+ map (second boxCompiler) compilers

71+ where

72+ boxCompiler = fmap (fmap compiledItem)

6273

6374-- | Add a compilation rule

6475--

6576-- This instructs all resources matching the given pattern to be compiled using

6677-- the given compiler

6778--

68−compile :: Pattern -> Compiler a -> Rules a

79+compile :: (Binary a, Typeable a, Writable a)

80+ => Pattern -> Compiler a -> Rules

6981compile pattern compiler = RulesM $ do

7082 identifiers <- matches pattern . resourceList <$> ask

7183 unRulesM $ addCompilers $ zip identifiers (repeat compiler)

@@ -74,10 +86,11 @@ compile pattern compiler = RulesM $ do

7486--

7587-- This sets a compiler for the given identifier

7688--

77−create :: Identifier -> Compiler a -> RulesM a ()

89+create :: (Binary a, Typeable a, Writable a)

90+ => Identifier -> Compiler a -> Rules

7891create identifier compiler = addCompilers [(identifier, compiler)]

7992

8093-- | Add a route

8194--

82−route :: Pattern -> Route -> RulesM a ()

95+route :: Pattern -> Route -> Rules

8396route pattern route' = addRoute $ ifMatch pattern route'

src/Hakyll/Core/Run.hs+21−13

@@ -5,6 +5,9 @@ module Hakyll.Core.Run where

55import Control.Arrow ((&&&))

66import Control.Monad (foldM, forM_)

77import qualified Data.Map as M

8+import Data.Monoid (mempty)

9+import Data.Typeable (Typeable)

10+import Data.Binary (Binary)

811

912import Hakyll.Core.Route

1013import Hakyll.Core.Compiler

@@ -16,14 +19,15 @@ import Hakyll.Core.DirectedGraph

1619import Hakyll.Core.DirectedGraph.DependencySolver

1720import Hakyll.Core.Writable

1821import Hakyll.Core.Store

22+import Hakyll.Core.CompiledItem

1923

20−hakyll :: Writable a => Rules a -> IO ()

24+hakyll :: Rules -> IO ()

2125hakyll rules = do

2226 store <- makeStore "_store"

2327 provider <- fileResourceProvider

2428 hakyllWith rules provider store

2529

26−hakyllWith :: Writable a => Rules a -> ResourceProvider -> Store -> IO ()

30+hakyllWith :: Rules -> ResourceProvider -> Store -> IO ()

2731hakyllWith rules provider store = do

2832 let -- Get the rule set

2933 ruleSet = runRules rules provider

@@ -48,22 +52,26 @@ hakyllWith rules provider store = do

4852 -- Join the order with the targets again

4953 orderedTargets = map (id &&& (targetMap M.!)) ordered

5054

55+ -- Fetch the routes

56+ route' = rulesRoute ruleSet

57+

5158 -- Generate all the targets in order

52− map' <- foldM addTarget M.empty orderedTargets

59+ _ <- foldM (addTarget route') M.empty orderedTargets

5360

54− let -- Fetch the routes

55− route' = rulesRoute ruleSet

61+ putStrLn "DONE."

62+ where

63+ addTarget route' map' (id', targ) = do

64+ compiled <- runTarget targ id' (dependencyLookup map') provider store

65+ putStrLn $ "Generated target: " ++ show id'

5666

57− forM_ (M.toList map') $ \(id', result) ->

5867 case runRoute route' id' of

5968 Nothing -> return ()

6069 Just r -> do

6170 putStrLn $ "Routing " ++ show id' ++ " to " ++ r

62− write r result

71+ write r compiled

6372

64− putStrLn "DONE."

65− where

66− addTarget map' (id', targ) = do

67− result <- runTarget targ id' (map' M.!) provider store

68− putStrLn $ "Generated target: " ++ show id'

69− return $ M.insert id' result map'

73+ return $ M.insert id' compiled map'

74+

75+ dependencyLookup map' id' = case M.lookup id' map' of

76+ Nothing -> error $ "dependencyLookup: " ++ show id' ++ " not found"

77+ Just d -> d

src/Hakyll/Core/Target.hs+2−3

@@ -4,7 +4,6 @@

44module Hakyll.Core.Target

55 ( DependencyLookup

66 , TargetM

7− , Target

87 , runTarget

98 , getIdentifier

109 , getResourceString

@@ -20,12 +19,12 @@ import Hakyll.Core.ResourceProvider

2019

2120-- | Get the current identifier

2221--

23−getIdentifier :: TargetM a Identifier

22+getIdentifier :: TargetM Identifier

2423getIdentifier = TargetM $ targetIdentifier <$> ask

2524

2625-- | Get the resource content as a string

2726--

28−getResourceString :: TargetM a String

27+getResourceString :: TargetM String

2928getResourceString = TargetM $ do

3029 provider <- targetResourceProvider <$> ask

3130 identifier <- unTargetM getIdentifier

src/Hakyll/Core/Target/Internal.hs+12−17

@@ -1,11 +1,10 @@

11-- | Internal structure of a Target, not exported outside of the library

22--

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3+{-# LANGUAGE GeneralizedNewtypeDeriving, Rank2Types #-}

44module Hakyll.Core.Target.Internal

55 ( DependencyLookup

66 , TargetEnvironment (..)

77 , TargetM (..)

8− , Target

98 , runTarget

109 ) where

1110

@@ -17,18 +16,19 @@ import Control.Monad.State (StateT, evalStateT)

1716import Hakyll.Core.Identifier

1817import Hakyll.Core.ResourceProvider

1918import Hakyll.Core.Store

19+import Hakyll.Core.CompiledItem

2020

2121-- | A lookup with which we can get dependencies

2222--

23−type DependencyLookup a = Identifier -> a

23+type DependencyLookup = Identifier -> CompiledItem

2424

2525-- | Environment for the target monad

2626--

27−data TargetEnvironment a = TargetEnvironment

28− { targetIdentifier :: Identifier -- ^ Identifier

29− , targetDependencyLookup :: DependencyLookup a -- ^ Dependency lookup

30− , targetResourceProvider :: ResourceProvider -- ^ To get resources

31− , targetStore :: Store -- ^ Store for caching

27+data TargetEnvironment = TargetEnvironment

28+ { targetIdentifier :: Identifier -- ^ Identifier

29+ , targetDependencyLookup :: DependencyLookup -- ^ Dependency lookup

30+ , targetResourceProvider :: ResourceProvider -- ^ To get resources

31+ , targetStore :: Store -- ^ Store for caching

3232 }

3333

3434-- | State for the target monad

@@ -40,20 +40,15 @@ data TargetState = TargetState

4040-- | Monad for targets. In this monad, the user can compose targets and describe

4141-- how they should be created.

4242--

43−newtype TargetM a b = TargetM

44− { unTargetM :: ReaderT (TargetEnvironment a) (StateT TargetState IO) b

43+newtype TargetM a = TargetM

44+ { unTargetM :: ReaderT TargetEnvironment (StateT TargetState IO) a

4545 } deriving (Monad, Functor, Applicative, MonadIO)

4646

47−-- | Simplification of the 'TargetM' type for concrete cases: the type of the

48−-- returned item should equal the type of the dependencies.

49−--

50−type Target a = TargetM a a

51−

5247-- | Run a target, yielding an actual result.

5348--

54−runTarget :: Target a

49+runTarget :: TargetM a

5550 -> Identifier

56− -> DependencyLookup a

51+ -> DependencyLookup

5752 -> ResourceProvider

5853 -> Store

5954 -> IO a

src/Hakyll/Web/FileType.hs+1−1

@@ -51,5 +51,5 @@ fileType = fileType' . takeExtension

5151

5252-- | Get the file type for the current file

5353--

54−getFileType :: TargetM a FileType

54+getFileType :: TargetM FileType

5555getFileType = fileType . toFilePath <$> getIdentifier

src/Hakyll/Web/Page.hs+3−1

@@ -2,6 +2,7 @@

22-- type 'String') and number of metadata fields. This type is used to represent

33-- pages on your website.

44--

5+{-# LANGUAGE DeriveDataTypeable #-}

56module Hakyll.Web.Page

67 ( Page (..)

78 , toMap

@@ -12,6 +13,7 @@ import Control.Applicative ((<$>), (<*>))

1213import Data.Map (Map)

1314import qualified Data.Map as M

1415import Data.Binary (Binary, get, put)

16+import Data.Typeable (Typeable)

1517

1618import Hakyll.Core.Writable

1719

@@ -20,7 +22,7 @@ import Hakyll.Core.Writable

2022data Page a = Page

2123 { pageMetadata :: Map String String

2224 , pageBody :: a

23− }

25+ } deriving (Show, Typeable)

2426

2527instance Functor Page where

2628 fmap f (Page m b) = Page m (f b)

src/Hakyll/Web/Pandoc.hs+9−9

@@ -29,9 +29,9 @@ import Hakyll.Web.Page

2929

3030-- | Read a string using pandoc, with the default options

3131--

32−readPandoc :: FileType -- ^ File type, determines how parsing happens

33− -> String -- ^ String to read

34− -> Pandoc -- ^ Resulting document

32+readPandoc :: FileType -- ^ File type, determines how parsing happens

33+ -> String -- ^ String to read

34+ -> Pandoc -- ^ Resulting document

3535readPandoc = readPandocWith defaultParserState

3636

3737-- | Read a string using pandoc, with the supplied options

@@ -51,8 +51,8 @@ readPandocWith state fileType' = case fileType' of

5151

5252-- | Write a document (as HTML) using pandoc, with the default options

5353--

54−writePandoc :: Pandoc -- ^ Document to write

55− -> String -- ^ Resulting HTML

54+writePandoc :: Pandoc -- ^ Document to write

55+ -> String -- ^ Resulting HTML

5656writePandoc = writePandocWith defaultWriterOptions

5757

5858-- | Write a document (as HTML) using pandoc, with the supplied options

@@ -64,19 +64,19 @@ writePandocWith = P.writeHtmlString

6464

6565-- | Read the resource using pandoc

6666--

67−pageReadPandoc :: Page String -> TargetM a (Page Pandoc)

67+pageReadPandoc :: Page String -> TargetM (Page Pandoc)

6868pageReadPandoc = pageReadPandocWith defaultParserState

6969

7070-- | Read the resource using pandoc

7171--

72−pageReadPandocWith :: P.ParserState -> Page String -> TargetM a (Page Pandoc)

72+pageReadPandocWith :: P.ParserState -> Page String -> TargetM (Page Pandoc)

7373pageReadPandocWith state page = do

7474 fileType' <- getFileType

7575 return $ readPandocWith state fileType' <$> page

7676

7777-- | Render the resource using pandoc

7878--

79−pageRenderPandoc :: Page String -> TargetM a (Page String)

79+pageRenderPandoc :: Page String -> TargetM (Page String)

8080pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions

8181

8282-- | Render the resource using pandoc

@@ -84,7 +84,7 @@ pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions

8484pageRenderPandocWith :: P.ParserState

8585 -> P.WriterOptions

8686 -> Page String

87− -> TargetM a (Page String)

87+ -> TargetM (Page String)

8888pageRenderPandocWith state options page = do

8989 pandoc <- pageReadPandocWith state page

9090 return $ writePandocWith options <$> pandoc