6268e4a · hakyll · git.iko.soy

git.iko.soy/hakyll

on master help sign in

Experimental arrow-based approach

6268e4aJasper Van der Jeugt16 years ago

src/Hakyll/Core/Compiler.hs+69−35

compare with master

unifiedsplit

@@ -4,26 +4,32 @@

4module Hakyll.Core.Compiler

5 ( Dependencies

6 , CompilerM

7− , Compiler

7+ , Compiler (..)

8 , runCompiler

9+ , getIdentifier

10+ , getResourceString

9 , require

11 , require

10− , requireAll

12+ -- , requireAll

11− , compileFromString

13+ -- , compileFromString

12 ) where

14 ) where

16+import Prelude hiding ((.), id)

14−import Control.Arrow (second)

17+import Control.Arrow (second, (>>>))

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

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

16import Control.Monad.State (State, modify, runState)

19import Control.Monad.State (State, modify, runState)

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

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

21+import Control.Monad.Trans (liftIO)

22+import Control.Monad ((<=<))

18import Data.Set (Set)

23import Data.Set (Set)

19import qualified Data.Set as S

24import qualified Data.Set as S

20−import Data.Typeable (Typeable)

25+import Control.Category (Category, (.), id)

26+import Control.Arrow (Arrow, arr, first)

27+

21import Data.Binary (Binary)

28import Data.Binary (Binary)

29+import Data.Typeable (Typeable)

23import Hakyll.Core.Identifier

31import Hakyll.Core.Identifier

24import Hakyll.Core.Identifier.Pattern

32import Hakyll.Core.Identifier.Pattern

25−import Hakyll.Core.Target

26−import Hakyll.Core.Target.Internal

27import Hakyll.Core.CompiledItem

33import Hakyll.Core.CompiledItem

28import Hakyll.Core.Writable

34import Hakyll.Core.Writable

29import Hakyll.Core.ResourceProvider

35import Hakyll.Core.ResourceProvider

@@ -32,65 +38,92 @@ import Hakyll.Core.ResourceProvider

32--

38--

33type Dependencies = Set Identifier

39type Dependencies = Set Identifier

35−-- | Add one dependency

41+-- | A lookup with which we can get dependencies

36--

42--

37−addDependency :: Identifier -> CompilerM ()

43+type DependencyLookup = Identifier -> CompiledItem

38−addDependency dependency = CompilerM $ modify $ addDependency'

39− where

40− addDependency' x = x

41− { compilerDependencies = S.insert dependency $ compilerDependencies x

42− }

44-- | Environment in which a compiler runs

45-- | Environment in which a compiler runs

45--

46--

46data CompilerEnvironment = CompilerEnvironment

47data CompilerEnvironment = CompilerEnvironment

47 { compilerIdentifier :: Identifier -- ^ Target identifier

48 { compilerIdentifier :: Identifier -- ^ Target identifier

48 , compilerResourceProvider :: ResourceProvider -- ^ Resource provider

49 , compilerResourceProvider :: ResourceProvider -- ^ Resource provider

49− }

50+ , compilerDependencyLookup :: DependencyLookup -- ^ Dependency lookup

50−

51−-- | State carried along by a compiler

52−--

53−data CompilerState = CompilerState

54− { compilerDependencies :: Dependencies

55 }

51 }

57-- | The compiler monad

53-- | The compiler monad

58--

54--

59newtype CompilerM a = CompilerM

55newtype CompilerM a = CompilerM

60− { unCompilerM :: ReaderT CompilerEnvironment (State CompilerState) a

56+ { unCompilerM :: ReaderT CompilerEnvironment IO a

61 } deriving (Monad, Functor, Applicative)

57 } deriving (Monad, Functor, Applicative)

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

59+-- | The compiler arrow

64−-- cases)

65--

60--

66−type Compiler a = CompilerM (TargetM a)

61+data Compiler a b = Compiler

62+ { -- TODO: Reader ResourceProvider Dependencies

63+ compilerDependencies :: Dependencies

64+ , compilerJob :: a -> CompilerM b

65+ }

66+

67+instance Category Compiler where

68+ id = Compiler S.empty return

69+ (Compiler d1 j1) . (Compiler d2 j2) =

70+ Compiler (d1 `S.union` d2) (j1 <=< j2)

71+

72+instance Arrow Compiler where

73+ arr f = Compiler S.empty (return . f)

74+ first (Compiler d j) = Compiler d $ \(x, y) -> do

75+ x' <- j x

76+ return (x', y)

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

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

69--

79--

70−runCompiler :: Compiler a -> Identifier -> ResourceProvider

80+runCompiler :: Compiler () a

71− -> (TargetM a, Dependencies)

81+ -> Identifier

82+ -> ResourceProvider

83+ -> DependencyLookup

84+ -> IO a

72−runCompiler compiler identifier provider = second compilerDependencies $

85+runCompiler compiler identifier provider lookup' =

73− runState (runReaderT (unCompilerM compiler) env) state

86+ runReaderT (unCompilerM $ compilerJob compiler ()) env

74 where

87 where

75− state = CompilerState S.empty

76 env = CompilerEnvironment

88 env = CompilerEnvironment

77 { compilerIdentifier = identifier

89 { compilerIdentifier = identifier

78 , compilerResourceProvider = provider

90 , compilerResourceProvider = provider

91+ , compilerDependencyLookup = lookup'

79 }

92 }

94+addDependency :: Identifier

95+ -> Compiler b b

96+addDependency id' = Compiler (S.singleton id') return

97+

98+fromCompilerM :: (a -> CompilerM b)

99+ -> Compiler a b

100+fromCompilerM = Compiler S.empty

101+

102+getIdentifier :: Compiler () Identifier

103+getIdentifier = fromCompilerM $ const $ CompilerM $

104+ compilerIdentifier <$> ask

105+

106+getResourceString :: Compiler () String

107+getResourceString = getIdentifier >>> getResourceString'

108+ where

109+ getResourceString' = fromCompilerM $ \id' -> CompilerM $ do

110+ provider <- compilerResourceProvider <$> ask

111+ liftIO $ resourceString provider id'

112

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

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

83-- dependencies

114-- dependencies

84--

115--

85require :: (Binary a, Typeable a, Writable a)

116require :: (Binary a, Typeable a, Writable a)

86 => Identifier

117 => Identifier

118+ -> (a -> b -> c)

87− -> Compiler a

119+ -> Compiler b c

88−require identifier = do

89− addDependency identifier

120+require identifier f = addDependency identifier >>> fromCompilerM require'

90− return $ TargetM $ do

121+ where

91− lookup' <- targetDependencyLookup <$> ask

122+ require' x = CompilerM $ do

123+ lookup' <- compilerDependencyLookup <$> ask

92− return $ unCompiledItem $ lookup' identifier

124+ return $ f (unCompiledItem $ lookup' identifier) x

125

126+{-

94-- | Require a number of targets. Using this function ensures automatic handling

127-- | Require a number of targets. Using this function ensures automatic handling

95-- of dependencies

128-- of dependencies

96--

129--

@@ -108,3 +141,4 @@ requireAll pattern = CompilerM $ do

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

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

109 -> Compiler a -- ^ Resulting compiler

142 -> Compiler a -- ^ Resulting compiler

110compileFromString = return . (getResourceString >>=)

143compileFromString = return . (getResourceString >>=)

144+-}

src/Hakyll/Core/Rules.hs+6−6

@@ -15,7 +15,7 @@ module Hakyll.Core.Rules

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

16import Control.Monad.Writer

17import Control.Monad.Reader

18−import Control.Arrow (second)

18+import Control.Arrow (second, (>>>), arr)

20import Data.Typeable (Typeable)

21import Data.Binary (Binary)

@@ -32,7 +32,7 @@ import Hakyll.Core.Writable

32--

33data RuleSet = RuleSet

34 { rulesRoute :: Route

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

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

36 }

38instance Monoid RuleSet where

@@ -64,12 +64,12 @@ addRoute route' = RulesM $ tell $ RuleSet route' mempty

64-- | Add a number of compilers

65--

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

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

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

68 -> Rules

69addCompilers compilers = RulesM $ tell $ RuleSet mempty $

70 map (second boxCompiler) compilers

71 where

72− boxCompiler = fmap (fmap compiledItem)

72+ boxCompiler = (>>> arr compiledItem)

74-- | Add a compilation rule

75--

@@ -77,7 +77,7 @@ addCompilers compilers = RulesM $ tell $ RuleSet mempty $

77-- the given compiler

78--

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

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

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

81compile pattern compiler = RulesM $ do

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

83 unRulesM $ addCompilers $ zip identifiers (repeat compiler)

@@ -87,7 +87,7 @@ compile pattern compiler = RulesM $ do

87-- This sets a compiler for the given identifier

88--

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

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

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

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

93-- | Add a route

src/Hakyll/Core/Run.hs+14−16

@@ -11,12 +11,12 @@ import Data.Binary (Binary)

11import System.FilePath ((</>))

13import Hakyll.Core.Route

14+import Hakyll.Core.Identifier

14import Hakyll.Core.Util.File

15import Hakyll.Core.Util.File

15import Hakyll.Core.Compiler

16import Hakyll.Core.Compiler

16import Hakyll.Core.ResourceProvider

17import Hakyll.Core.ResourceProvider

17import Hakyll.Core.ResourceProvider.FileResourceProvider

18import Hakyll.Core.ResourceProvider.FileResourceProvider

18import Hakyll.Core.Rules

19import Hakyll.Core.Rules

19−import Hakyll.Core.Target

20import Hakyll.Core.DirectedGraph

21import Hakyll.Core.DirectedGraph.Dot

22import Hakyll.Core.DirectedGraph.DependencySolver

@@ -38,22 +38,20 @@ hakyllWith rules provider store = do

38 -- Get all identifiers and compilers

39 compilers = rulesCompilers ruleSet

41− -- Get all targets

41+ -- Get all dependencies

42− targets = flip map compilers $ \(id', compiler) ->

42+ dependencies = flip map compilers $ \(id', compiler) ->

43− let (targ, deps) = runCompiler compiler id' provider

43+ let deps = compilerDependencies compiler

44− in (id', targ, deps)

44+ in (id', deps)

46− -- Map mapping every identifier to it's target

46+ -- Create a compiler map

47− targetMap = M.fromList $ map (\(i, t, _) -> (i, t)) targets

47+ compilerMap = M.fromList compilers

49− -- Create a dependency graph

50− graph = fromList $ map (\(i, _, d) -> (i, d)) targets

51−

52− -- Solve the graph, creating a target order

49+ -- Create and solve the graph, creating a compiler order

50+ graph = fromList dependencies

53 ordered = solveDependencies graph

51 ordered = solveDependencies graph

55− -- Join the order with the targets again

53+ -- Join the order with the compilers again

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

54+ orderedCompilers = map (id &&& (compilerMap M.!)) ordered

58 -- Fetch the routes

56 -- Fetch the routes

59 route' = rulesRoute ruleSet

57 route' = rulesRoute ruleSet

@@ -62,12 +60,12 @@ hakyllWith rules provider store = do

62 writeDot "dependencies.dot" show graph

60 writeDot "dependencies.dot" show graph

64 -- Generate all the targets in order

62 -- Generate all the targets in order

65− _ <- foldM (addTarget route') M.empty orderedTargets

63+ _ <- foldM (addTarget route') M.empty orderedCompilers

67 putStrLn "DONE."

65 putStrLn "DONE."

68 where

66 where

69− addTarget route' map' (id', targ) = do

67+ addTarget route' map' (id', comp) = do

70− compiled <- runTarget targ id' (dependencyLookup map') provider store

68+ compiled <- runCompiler comp id' provider (dependencyLookup map')

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

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

73 case runRoute route' id' of

71 case runRoute route' id' of

src/Hakyll/Core/Target.hsdeleted−31

@@ -1,31 +0,0 @@

1−-- | A target represents one compilation unit, e.g. a blog post, a CSS file...

2−--

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4−module Hakyll.Core.Target

5− ( DependencyLookup

6− , TargetM

7− , runTarget

8− , getIdentifier

9− , getResourceString

10− ) where

11−

12−import Control.Applicative ((<$>))

13−import Control.Monad.Reader (ask)

14−import Control.Monad.Trans (liftIO)

15−

16−import Hakyll.Core.Identifier

17−import Hakyll.Core.Target.Internal

18−import Hakyll.Core.ResourceProvider

19−

20−-- | Get the current identifier

21−--

22−getIdentifier :: TargetM Identifier

23−getIdentifier = TargetM $ targetIdentifier <$> ask

24−

25−-- | Get the resource content as a string

26−--

27−getResourceString :: TargetM String

28−getResourceString = TargetM $ do

29− provider <- targetResourceProvider <$> ask

30− identifier <- unTargetM getIdentifier

31− liftIO $ resourceString provider identifier

src/Hakyll/Core/Target/Internal.hsdeleted−66

@@ -1,66 +0,0 @@

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

2−--

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

4−module Hakyll.Core.Target.Internal

5− ( DependencyLookup

6− , TargetEnvironment (..)

7− , TargetM (..)

8− , runTarget

9− ) where

10−

11−import Control.Applicative (Applicative)

12−import Control.Monad.Trans (MonadIO)

13−import Control.Monad.Reader (ReaderT, runReaderT)

14−import Control.Monad.State (StateT, evalStateT)

15−

16−import Hakyll.Core.Identifier

17−import Hakyll.Core.ResourceProvider

18−import Hakyll.Core.Store

19−import Hakyll.Core.CompiledItem

20−

21−-- | A lookup with which we can get dependencies

22−--

23−type DependencyLookup = Identifier -> CompiledItem

24−

25−-- | Environment for the target monad

26−--

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

32− }

33−

34−-- | State for the target monad

35−--

36−data TargetState = TargetState

37− { targetSnapshot :: Int -- ^ Snapshot ID

38− }

39−

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

41−-- how they should be created.

42−--

43−newtype TargetM a = TargetM

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

45− } deriving (Monad, Functor, Applicative, MonadIO)

46−

47−-- | Run a target, yielding an actual result.

48−--

49−runTarget :: TargetM a

50− -> Identifier

51− -> DependencyLookup

52− -> ResourceProvider

53− -> Store

54− -> IO a

55−runTarget target id' lookup' provider store =

56− evalStateT (runReaderT (unTargetM target) env) state

57− where

58− env = TargetEnvironment

59− { targetIdentifier = id'

60− , targetDependencyLookup = lookup'

61− , targetResourceProvider = provider

62− , targetStore = store

63− }

64− state = TargetState

65− { targetSnapshot = 0

66− }

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

@@ -7,10 +7,10 @@ module Hakyll.Web.FileType

7 ) where

9import System.FilePath (takeExtension)

10−import Control.Applicative ((<$>))

10+import Control.Arrow ((>>>), arr)

12import Hakyll.Core.Identifier

13−import Hakyll.Core.Target

13+import Hakyll.Core.Compiler

15-- | Datatype to represent the different file types Hakyll can deal with by

16-- default

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

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

53--

54−getFileType :: TargetM FileType

54+getFileType :: Compiler () FileType

55−getFileType = fileType . toFilePath <$> getIdentifier

55+getFileType = getIdentifier >>> arr (fileType . toFilePath)

src/Hakyll/Web/Pandoc.hs+5−1

@@ -8,10 +8,12 @@ module Hakyll.Web.Pandoc

8 , writePandocWith

10 -- * Functions working on pages/targets

11+ {-

11 , pageReadPandoc

12 , pageReadPandoc

12 , pageReadPandocWith

13 , pageReadPandocWith

13 , pageRenderPandoc

14 , pageRenderPandoc

14 , pageRenderPandocWith

15 , pageRenderPandocWith

16+ -}

16 -- * Default options

18 -- * Default options

17 , defaultParserState

19 , defaultParserState

@@ -23,7 +25,7 @@ import Control.Applicative ((<$>))

23import Text.Pandoc (Pandoc)

25import Text.Pandoc (Pandoc)

24import qualified Text.Pandoc as P

26import qualified Text.Pandoc as P

26−import Hakyll.Core.Target

28+import Hakyll.Core.Compiler

27import Hakyll.Web.FileType

29import Hakyll.Web.FileType

28import Hakyll.Web.Page

30import Hakyll.Web.Page

@@ -62,6 +64,7 @@ writePandocWith :: P.WriterOptions -- ^ Writer options for pandoc

62 -> String -- ^ Resulting HTML

64 -> String -- ^ Resulting HTML

63writePandocWith = P.writeHtmlString

65writePandocWith = P.writeHtmlString

67+{-

65-- | Read the resource using pandoc

68-- | Read the resource using pandoc

66--

69--

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

70pageReadPandoc :: Page String -> TargetM (Page Pandoc)

@@ -88,6 +91,7 @@ pageRenderPandocWith :: P.ParserState

88pageRenderPandocWith state options page = do

91pageRenderPandocWith state options page = do

89 pandoc <- pageReadPandocWith state page

92 pandoc <- pageReadPandocWith state page

90 return $ writePandocWith options <$> pandoc

93 return $ writePandocWith options <$> pandoc

94+-}

92-- | The default reader options for pandoc parsing in hakyll

96-- | The default reader options for pandoc parsing in hakyll

93--

97--