diff --git a/diagrams-builder.cabal b/diagrams-builder.cabal index 9fed586..d8a4ad4 100644 --- a/diagrams-builder.cabal +++ b/diagrams-builder.cabal @@ -2,31 +2,27 @@ name: diagrams-builder version: 0.6.0.1 synopsis: hint-based build service for the diagrams graphics EDSL. -description: @diagrams-builder@ provides backend-agnostic tools for - dynamically turning code into rendered diagrams, - using the @hint@ wrapper to the GHC API. It - supports conditional recompilation using hashing - of diagrams source code, to avoid recompiling - code that has not changed. It is useful for - creating tools which compile diagrams code - embedded in other documents. For example, it is - used by the @BlogLiterately-diagrams@ package (a - plugin for @BlogLiterately@) to compile diagrams - embedded in Markdown-formatted blog posts. - . - Executables specific to the cairo, SVG, and postscript - backends are included (more executables specific - to other backends may be included in the future). - All take an input file and an expression to - render, and output an image file. If you want - these executables you must explicitly enable the - @-fcairo@, @-fsvg@, or @-fps@ flags. - . - A LaTeX package, @diagrams-latex.sty@, is also - provided in the @latex/@ directory of the source - distribution, which renders diagrams code found - within @diagram@ environments. Note that - @diagrams-latex.sty@ is licensed under the GPL. +description: + @diagrams-builder@ provides backend-agnostic tools for dynamically + turning code into rendered diagrams, using the @hint@ wrapper to the + GHC API. It supports conditional recompilation using hashing of + diagrams source code, to avoid recompiling code that has not changed. + It is useful for creating tools which compile diagrams code embedded + in other documents. For example, it is used by the + @BlogLiterately-diagrams@ package (a plugin for @BlogLiterately@) to + compile diagrams embedded in Markdown-formatted blog posts. + . + Executables specific to the cairo, SVG, and postscript backends are + included (more executables specific to other backends may be included + in the future). All take an input file and an expression to render, + and output an image file. If you want these executables you must + explicitly enable the @-fcairo@, @-fsvg@, or @-fps@ flags. + . + A LaTeX package, @diagrams-latex.sty@, is also provided in the + @latex/@ directory of the source distribution, which renders diagrams + code found within @diagram@ environments. Note that + @diagrams-latex.sty@ is licensed under the GPL. + homepage: http://projects.haskell.org/diagrams license: BSD3 license-file: LICENSE @@ -59,7 +55,8 @@ library cmdargs >= 0.6 && < 0.11, lens >= 4.0 && < 4.7, hashable >= 1.1 && < 1.3, - exceptions >= 0.3 && < 0.7 + exceptions >= 0.3 && < 0.7, + temporary >= 1.2 && < 1.3 hs-source-dirs: src default-language: Haskell2010 other-extensions: StandaloneDeriving, diff --git a/src/Diagrams/Builder.hs b/src/Diagrams/Builder.hs index a009541..249c97f 100644 --- a/src/Diagrams/Builder.hs +++ b/src/Diagrams/Builder.hs @@ -1,15 +1,20 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Builder --- Copyright : (c) 2012 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2012-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -18,61 +23,99 @@ -- ----------------------------------------------------------------------------- module Diagrams.Builder - ( -- * Building diagrams - - -- ** Options - BuildOpts(..), mkBuildOpts, backendOpts, snippets, pragmas, imports, decideRegen, diaExpr, postProcess - - -- ** Regeneration decision functions and hashing - , alwaysRegenerate, hashedRegenerate - , hashToHexStr - - -- ** Building - , buildDiagram, BuildResult(..) - , ppInterpError - - -- * Interpreting diagrams - -- $interp - , setDiagramImports - , interpretDiagram - - -- * Tools for creating standalone builder executables - - , Build(..) - , defaultBuildOpts - - ) where - -import Control.Lens ((^.)) -import Control.Monad (guard, mplus, mzero) -import Control.Monad.Catch (catchAll) -import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) -import Data.Data -import Data.Hashable (Hashable (..)) -import Data.List (foldl', nub) -import Data.List.Split (splitOn) -import Data.Maybe (catMaybes, fromMaybe) -import System.Directory (doesFileExist, - getTemporaryDirectory, - removeFile) -import System.FilePath (takeBaseName, (<.>), - ()) -import System.IO (hClose, hPutStr, - openTempFile) - -import Language.Haskell.Exts (ImportDecl, Module (..), - importModule, prettyPrint) -import Language.Haskell.Interpreter hiding (ModuleName) - -import Diagrams.Builder.CmdLine + ( -- * Building diagrams + + -- ** Options + BuildOpts (..) + + -- *** Lenses + , mkBuildOpts + , backendOpts + , snippets + , pragmas + , imports + , diaExpr + , postProcess + , hashCache + + -- ** Building + , BuildResult (..) + , buildDia + , buildDiaResult + , buildDiaToFile + , buildDiaToHash + , ppInterpError + , showHash + + -- * Interpreting diagrams + -- $interp + , setDiaImports + , interpretDia + + -- * Type aliases + , Backend', BackendBuild', Hash + + ) where + +import Control.Lens (Traversal', cons, (^.), (^?), + _Just) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) +import Data.Foldable (Foldable) +import Data.Hashable (Hashable (..)) +import Data.List (find, foldl', nub) +import Data.List.Split (splitOn) +import Data.Maybe +import Data.Traversable as T (Traversable, mapM) +import Data.Typeable +import Data.Word (Word) +import Numeric (showHex) +import System.Directory (copyFile, doesFileExist, + getDirectoryContents) +import System.FilePath (takeBaseName, takeExtension, + (<.>), ()) +import System.IO (hClose, hPutStr) +import System.IO.Temp + +import Diagrams.Backend.Build import Diagrams.Builder.Modules import Diagrams.Builder.Opts import Diagrams.Prelude -import Language.Haskell.Interpreter.Unsafe (unsafeRunInterpreterWithArgs) -import System.Environment (getEnvironment) + +import Language.Haskell.Exts (ImportDecl, Module (..), + importModule, prettyPrint) +import Language.Haskell.Interpreter hiding (ModuleName) +import Language.Haskell.Interpreter.Unsafe deriving instance Typeable Any +-- Typeable1 is a depreciated synonym in ghc > 707 +#if __GLASGOW_HASKELL__ >= 707 +#define Typeable1 Typeable +#endif + +-- Type synonyms for saner type signatures. + +type BackendBuild' b v n = + (BackendBuild b v n, Hashable (Options b v n), Typeable b, Typeable1 v, + HasLinearMap v, Metric v, Typeable n, OrderedField n) + +type Backend' b v n = + (Typeable b, Typeable1 v, HasLinearMap v, Metric v, + Typeable n, OrderedField n, Backend b v n) + +-- | Synonym for more perspicuous types. +-- +-- We use @Int@ values for hashes because that's what the @Hashable@ +-- package uses. Assuming diagram hashes are uniformly distributed, +-- on a 64-bit system one needs to build on the order of billions of +-- diagrams before the probability of a hash collision exceeds 1/2, +-- and for anything up to tens of millions of diagrams the +-- probability of a collision is under 0.1%. On 32-bit systems +-- those become tens of thousands and thousands, respectively. +type Hash = Int + ------------------------------------------------------------ -- Interpreting diagrams ------------------------------------------------------------ @@ -80,150 +123,197 @@ deriving instance Typeable Any -- $interp -- These functions constitute the internals of diagrams-builder. End -- users should not usually need to call them directly; use --- 'buildDiagram' instead. +-- 'buildDia' instead. -- | Set up the module to be interpreted, in the context of the -- necessary imports. -setDiagramImports +setDiaImports :: MonadInterpreter m - => String - -- ^ Filename of the module containing the diagrams - - -> [String] - -- ^ Additional necessary imports. @Prelude@, @Diagrams.Prelude@, - -- @Diagrams.Core.Types@, and @Data.Monoid@ are included by - -- default. - + => String -- ^ Filename of the module containing the diagrams + -> [String] -- ^ Additional necessary imports. @Prelude@ and + -- @Diagrams.Prelude@ are included by default. -> m () -setDiagramImports m imps = do - loadModules [m] - setTopLevelModules [takeBaseName m] - setImports $ [ "Prelude" - , "Diagrams.Prelude" - , "Diagrams.Core.Types" - , "Data.Monoid" - ] - ++ imps - -getHsenvArgv :: IO [String] -getHsenvArgv = do - env <- getEnvironment - return $ case lookup "HSENV" env of - Nothing -> [] - _ -> hsenvArgv - where hsenvArgv = words $ fromMaybe "" (lookup "PACKAGE_DB_FOR_GHC" env) - --- | Interpret a diagram expression based on the contents of a given --- source file, using some backend to produce a result. The --- expression can be of type @Diagram b v n@ or @IO (Diagram b v n)@. -interpretDiagram - :: forall b v n. - ( Typeable b -#if __GLASGOW_HASKELL__ > 707 - , Typeable v -#else - , Typeable1 v -#endif - , HasLinearMap v, Data (v n), Data n - , Metric v, OrderedField n, Backend b v n - ) +setDiaImports m imps = do + loadModules [m] + setTopLevelModules [takeBaseName m] + setImports $ [ "Prelude" + , "Diagrams.Prelude" + ] + ++ imps + +-- | Interpret the module, set imports from 'BuildOpts' and return the +-- 'Diagram' with the 'postProcess' applied. +interpretDiaWithOpts + :: (MonadInterpreter m, Typeable (QDiagram b v n Any)) => BuildOpts b v n -> FilePath - -> IO (Either InterpreterError (Result b v n)) -interpretDiagram bopts m = do - - -- use an hsenv sandbox, if one is enabled. - args <- liftIO getHsenvArgv - unsafeRunInterpreterWithArgs args $ do - - setDiagramImports m (bopts ^. imports) - let dexp = bopts ^. diaExpr - - -- Try interpreting the diagram expression at two types: Diagram - -- b v and IO (Diagram b v). Take whichever one typechecks, - -- running the IO action in the second case to produce a - -- diagram. - d <- interpret dexp (as :: QDiagram b v n Any) `catchAll` const (interpret dexp (as :: IO (QDiagram b v n Any)) >>= liftIO) - - -- Finally, call renderDia. - return $ renderDia (backendToken bopts) (bopts ^. backendOpts) ((bopts ^. postProcess) d) - --- | Pretty-print an @InterpreterError@. -ppInterpError :: InterpreterError -> String -ppInterpError (UnknownError err) = "UnknownError: " ++ err -ppInterpError (WontCompile es) = unlines . nub . map errMsg $ es -ppInterpError (NotAllowed err) = "NotAllowed: " ++ err -ppInterpError (GhcException err) = "GhcException: " ++ err - ------------------------------------------------------------- + -> m (QDiagram b v n Any) +interpretDiaWithOpts bopts m = do + setDiaImports m (bopts ^. imports) + (bopts ^. postProcess) `liftM` interpretDia (bopts ^. diaExpr) + +-- | Same as 'interpretDiaWithOpts' but save 'Module' to a temporary file +-- and import it. +interpretDiaModule + :: (MonadInterpreter m, Typeable (QDiagram b v n Any)) + => BuildOpts b v n + -> Module + -> m (QDiagram b v n Any) +interpretDiaModule bopts m = tempModule m (interpretDiaWithOpts bopts) + +-- | Interpret a @Diagram@ or @IO Diagram@ at the name of the function. +-- (This means the source should already be loaded by the +-- interpreter.) +interpretDia + :: forall m b v n. (MonadInterpreter m, Typeable (QDiagram b v n Any)) + => String -> m (QDiagram b v n Any) +interpretDia dExp = + interpret dExp (as :: QDiagram b v n Any) `catchAll` + const (interpret dExp (as :: IO (QDiagram b v n Any)) >>= liftIO) + +-- | Convenient function to turn a 'QDiagram' to its 'Result' using +-- 'BuildOpts'. The 'postProcess' is not applied. +diaResult :: Backend' b v n => BuildOpts b v n -> QDiagram b v n Any -> Result b v n +diaResult bopts = renderDia (backendToken bopts) (bopts ^. backendOpts) + +------------------------------------------------------------------------ -- Build a diagram using a temporary file ------------------------------------------------------------- +------------------------------------------------------------------------ -- | Potential results of a dynamic diagram building operation. -data BuildResult b v n = - ParseErr String -- ^ Parsing of the code failed. - | InterpErr InterpreterError -- ^ Interpreting the code - -- failed. See 'ppInterpError'. - | Skipped Hash -- ^ This diagram did not need to be - -- regenerated; includes the hash. - | OK Hash (Result b v n) -- ^ A successful build, yielding the - -- hash and a backend-specific result. - --- | Build a diagram by writing the given source code to a temporary --- module and interpreting the given expression, which can be of --- type @Diagram b v@ or @IO (Diagram b v)@. Can return either a --- parse error if the source does not parse, an interpreter error, --- or the final result. -buildDiagram - :: ( Typeable b, Data (v n), Data n - , Metric v, HasLinearMap v -#if __GLASGOW_HASKELL__ > 707 - , Typeable v -#else - , Typeable1 v -#endif - , OrderedField n, Backend b v n - , Hashable (Options b v n) - ) - => BuildOpts b v n -> IO (BuildResult b v n) -buildDiagram bopts = do - let bopts' = bopts - & snippets %~ map unLit - & pragmas %~ ("NoMonomorphismRestriction" :) - & imports %~ ("Diagrams.Prelude" :) - case createModule Nothing bopts' of - Left err -> return (ParseErr err) - Right m@(Module _ _ _ _ _ srcImps _) -> do - liHash <- hashLocalImports srcImps - let diaHash - = 0 `hashWithSalt` prettyPrint m - `hashWithSalt` (bopts ^. diaExpr) - `hashWithSalt` (bopts ^. backendOpts) - `hashWithSalt` liHash - regen <- (bopts ^. decideRegen) diaHash - case regen of - Nothing -> return $ Skipped diaHash - Just upd -> do - tmpDir <- getTemporaryDirectory - (tmp, h) <- openTempFile tmpDir "Diagram.hs" - let m' = replaceModuleName (takeBaseName tmp) m - hPutStr h (prettyPrint m') - hClose h - - compilation <- interpretDiagram (bopts' & backendOpts %~ upd) tmp - removeFile tmp - return $ either InterpErr (OK diaHash) compilation +data BuildResult r + = ParseError String -- ^ Parsing of the code failed. + | InterpError InterpreterError -- ^ Interpreting the code + -- failed. See 'ppInterpError'. + | Skipped Hash -- ^ This diagram did not need to be + -- regenerated; includes the hash. + | OK Hash r -- ^ A successful build + deriving (Show, Functor, Foldable, Traversable) + +-- | Traversal over the 'Hash' of a 'BuildResult' if no error occurred. +resultHash :: Traversal' (BuildResult r) Hash +resultHash f (Skipped h) = Skipped <$> f h +resultHash f (OK h r) = OK <$> f h <*> pure r +resultHash _ err = pure err + +-- | Build a diagram and save it to it's hash. If no directory is +-- specified for the hash use the current directory. +buildDiaToHash + :: BackendBuild' b v n + => BuildOpts b v n + -> String -- ^ extension + -> IO (BuildResult ()) +buildDiaToHash opts ext = do + let dir = opts ^. hashCache . _Just + d <- buildDia opts + case d of + OK h dia -> saveDia (dir showHash h <.> ext) (opts ^. backendOpts) dia + >> return (OK h ()) + _ -> return (() <$ d) + +-- | Build a diagram and save it to the given 'FilePath'. The +-- 'hashCache' is used if it is present. +buildDiaToFile + :: BackendBuild' b v n + => BuildOpts b v n + -> FilePath + -> IO (BuildResult ()) +buildDiaToFile bopts outFile = do + let ext = takeExtension outFile + case bopts ^. hashCache of + Just dir -> do + r <- buildDiaToHash bopts (takeExtension outFile) + case r ^? resultHash of + Just h -> copyFile (dir showHash h <.> ext) outFile + >> return r + Nothing -> return r + + Nothing -> do + d <- buildDia bopts + case d of + OK h dia -> saveDia outFile (bopts ^. backendOpts) dia + >> return (OK h ()) + _ -> return (() <$ d) + +buildDiaResult + :: BackendBuild' b v n + => BuildOpts b v n + -> IO (BuildResult (Result b v n)) +buildDiaResult opts = do + d <- buildDia opts + return $ diaResult opts <$> d + +-- | Build a diagram. If the module hash is found, skip interpreting. +buildDia + :: (Hashable (Options b v n), Typeable b, Typeable1 v, Typeable n) + => BuildOpts b v n + -> IO (BuildResult (QDiagram b v n Any)) +buildDia (prepareOpts -> bopts) = case createModule Nothing bopts of + Left err -> return (ParseError err) + Right m -> do + diaHash <- hashModule bopts m + + let getDia = do + d <- runSandboxInterpreter $ interpretDiaModule bopts m + return $ either InterpError (OK diaHash) d + + case bopts ^. hashCache of + Nothing -> getDia + Just path -> do + alreadyDone <- isJust <$> checkHash path diaHash + if alreadyDone + then return $ Skipped diaHash + else getDia + +-- | Run an interpretor using sandbox from 'findSandbox'. +runSandboxInterpreter :: (MonadMask m, MonadIO m, Functor m) + => InterpreterT m a -> m (Either InterpreterError a) +runSandboxInterpreter i = do + mSandbox <- liftIO $ findSandbox [] + case mSandbox of + Just sandbox -> let args = ["-package-db", sandbox] + in unsafeRunInterpreterWithArgs args i + Nothing -> runInterpreter i + +-- | Write a module to a temporary file and delete it when done. The +-- module name is replaced by the temporary file's name (\"Diagram\"). +tempModule :: (MonadIO m, MonadMask m) => Module -> (FilePath -> m a) -> m a +tempModule m f = + withSystemTempFile "Diagram.hs" $ \temp h -> do + let m' = replaceModuleName (takeBaseName temp) m + liftIO $ hPutStr h (prettyPrint m') >> hClose h + f temp + +------------------------------------------------------------------------ +-- Hashing +------------------------------------------------------------------------ + +-- | Make a hash from BuildOpts and the Module. The hash includes any +-- local imports the module has. +hashModule :: Hashable (Options b v n) => BuildOpts b v n -> Module -> IO Hash +hashModule bopts m@(Module _ _ _ _ _ srcImps _) = do + liHash <- hashLocalImports srcImps + return (0 `hashWithSalt` prettyPrint m + `hashWithSalt` (bopts ^. diaExpr) + `hashWithSalt` (bopts ^. backendOpts) + `hashWithSalt` liHash) + +------------------------ +-- Hashing local imports +------------------------ + +-- We hash local imports in case they've changed. -- | Take a list of imports, and return a hash of the contents of -- those imports which are local. Note, this only finds imports -- which exist relative to the current directory, which is not as -- general as it probably should be --- we could be calling --- 'buildDiagram' on source code which lives anywhere. +-- 'buildDia' on source code which lives anywhere. hashLocalImports :: [ImportDecl] -> IO Hash hashLocalImports = fmap (foldl' hashWithSalt 0 . catMaybes) - . mapM (getLocalSource . foldr1 () . splitOn "." . getModuleName . importModule) + . T.mapM (getLocalSource . foldr1 () . splitOn "." . getModuleName . importModule) -- | Given a relative path with no extension, like -- @\"Foo\/Bar\/Baz\"@, check whether such a file exists with either @@ -245,3 +335,31 @@ getLocal m = tryExt "hs" `mplus` tryExt "lhs" tryExt ext = do let f = m <.> ext liftIO (doesFileExist f) >>= guard >> liftIO (readFile f) + +------------------------------------------------------------------------ +-- Utilities +------------------------------------------------------------------------ + +-- | Pretty-print an @InterpreterError@. +ppInterpError :: InterpreterError -> String +ppInterpError (UnknownError err) = "UnknownError: " ++ err +ppInterpError (WontCompile es) = unlines . nub $ map errMsg es +ppInterpError (NotAllowed err) = "NotAllowed: " ++ err +ppInterpError (GhcException err) = "GhcException: " ++ err + +-- Turn a Hash into a hex with no leading 0x. Hash is converted to a +-- word to avoid negative values. +showHash :: Hash -> String +showHash h = showHex (fromIntegral h :: Word) "" + +-- | Check for an existing rendered diagram in the directory that +-- matches the hash. +checkHash :: FilePath -> Hash -> IO (Maybe FilePath) +checkHash dir diaHash = do + files <- getDirectoryContents dir + return $ find ((== showHash diaHash) . takeBaseName) files + +prepareOpts :: BuildOpts b v n -> BuildOpts b v n +prepareOpts o = o & snippets %~ map unLit + & pragmas %~ cons "NoMonomorphismRestriction" + & imports %~ cons "Diagrams.Prelude" diff --git a/src/Diagrams/Builder/Modules.hs b/src/Diagrams/Builder/Modules.hs index 8f045c3..0f3d03a 100644 --- a/src/Diagrams/Builder/Modules.hs +++ b/src/Diagrams/Builder/Modules.hs @@ -56,7 +56,7 @@ doModuleParse :: String -> Either String Module doModuleParse src = case parseFileContentsWithMode parseMode src of ParseFailed sloc err -> Left (prettyPrint sloc ++ ": " ++ err) - ParseOk m -> return m + ParseOk m -> return m where parseMode = defaultParseMode diff --git a/src/Diagrams/Builder/Opts.hs b/src/Diagrams/Builder/Opts.hs index 29618fc..6209aa4 100644 --- a/src/Diagrams/Builder/Opts.hs +++ b/src/Diagrams/Builder/Opts.hs @@ -9,7 +9,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Builder.Opts --- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- @@ -17,59 +17,49 @@ -- ----------------------------------------------------------------------------- module Diagrams.Builder.Opts - ( -- * Options + ( -- * Options + BuildOpts(..) + , mkBuildOpts + , backendOpts + , snippets + , pragmas + , + imports + , hashCache + , diaExpr + , postProcess - Hash - , BuildOpts(..), mkBuildOpts, backendOpts, snippets, pragmas, imports, decideRegen, diaExpr, postProcess - - -- * Rebuilding - - , alwaysRegenerate, hashedRegenerate, hashToHexStr ) where import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, (&), (.~)) -import System.Directory (getDirectoryContents) -import System.FilePath (takeBaseName) -import Text.Printf import Diagrams.Prelude (QDiagram, Options, Any) --- | Synonym for more perspicuous types. --- --- We use @Int@ values for hashes because that's what the @Hashable@ --- package uses. Assuming diagram hashes are uniformly distributed, --- on a 64-bit system one needs to build on the order of billions of --- diagrams before the probability of a hash collision exceeds 1/2, --- and for anything up to tens of millions of diagrams the --- probability of a collision is under 0.1%. On 32-bit systems --- those become tens of thousands and thousands, respectively. -type Hash = Int -- | Options to control the behavior of @buildDiagram@. Create one -- with 'mkBuildOpts' followed by using the provided lenses to -- override more fields; for example, -- -- @ --- mkBuildOpts SVG zeroV (Options ...) +-- mkBuildOpts SVG zero (Options ...) -- & imports .~ [\"Foo.Bar\", \"Baz.Quux\"] -- & diaExpr .~ \"square 6 # fc green\" -- @ -data BuildOpts b v n - = BuildOpts - { backendToken :: b - -- ^ Backend token - , vectorToken :: v n - -- ^ Dummy vector argument to fix the vector space type - , _backendOpts :: Options b v n - , _snippets :: [String] - , _pragmas :: [String] - , _imports :: [String] - , _decideRegen :: Hash -> IO (Maybe (Options b v n -> Options b v n)) - , _diaExpr :: String - , _postProcess :: QDiagram b v n Any -> QDiagram b v n Any - } +data BuildOpts b v n = BuildOpts + { backendToken :: b + -- ^ Backend token + , vectorToken :: v n + -- ^ Dummy vector argument to fix the vector space type + , _backendOpts :: Options b v n + , _snippets :: [String] + , _pragmas :: [String] + , _imports :: [String] + , _hashCache :: Maybe FilePath + , _diaExpr :: String + , _postProcess :: QDiagram b v n Any -> QDiagram b v n Any + } makeLensesWith (lensRules & generateSignatures .~ False) ''BuildOpts @@ -88,7 +78,7 @@ makeLensesWith (lensRules & generateSignatures .~ False) ''BuildOpts -- * no postprocessing mkBuildOpts :: b -> v n -> Options b v n -> BuildOpts b v n mkBuildOpts b v opts - = BuildOpts b v opts [] [] [] alwaysRegenerate "circle 1" id + = BuildOpts b v opts [] [] [] Nothing "circle 1" id -- | Backend-specific options to use. backendOpts :: Lens' (BuildOpts b v n) (Options b v n) @@ -127,7 +117,10 @@ imports :: Lens' (BuildOpts b v n) [String] -- and always decides to regenerate the diagram; -- 'hashedRegenerate' creates a hash of the diagram source and -- looks for a file with that name in a given directory. -decideRegen :: Lens' (BuildOpts b v n) (Hash -> IO (Maybe (Options b v n -> Options b v n))) +-- decideRegen :: Lens' (BuildOpts b v n) (Hash -> IO (Maybe (Options b v n -> Options b v n))) + +-- | Only rebuild the diagram if the hash has changed. +hashCache :: Lens' (BuildOpts b v n) (Maybe FilePath) -- | The diagram expression to interpret. All the given import sand -- snippets will be in scope, with the given LANGUAGE pragmas @@ -143,45 +136,3 @@ diaExpr :: Lens' (BuildOpts b v n) String -- represents a diagram or an IO action. postProcess :: Lens' (BuildOpts b v n) (QDiagram b v n Any -> QDiagram b v n Any) --- | Convenience function suitable to be given as the final argument --- to 'buildDiagram'. It implements the simple policy of always --- rebuilding every diagram. -alwaysRegenerate :: Hash -> IO (Maybe (a -> a)) -alwaysRegenerate _ = return (Just id) - --- | Convenience function suitable to be given as the final argument --- to 'buildDiagram'. It works by converting the hash value to a --- zero-padded hexadecimal string and looking in the specified --- directory for any file whose base name is equal to the hash. If --- there is such a file, it specifies that the diagram should not be --- rebuilt. Otherwise, it specifies that the diagram should be --- rebuilt, and uses the provided function to update the rendering --- options based on the generated hash string. (Most likely, one --- would want to set the requested output file to the hash followed --- by some extension.) -hashedRegenerate - :: (String -> a -> a) - -- ^ A function for computing an update to rendering options, - -- given a new base filename computed from a hash of the - -- diagram source. - - -> FilePath - -- ^ The directory in which to look for generated files - - -> Hash - -- ^ The hash - - -> IO (Maybe (a -> a)) - -hashedRegenerate upd d hash = do - let fileBase = hashToHexStr hash - files <- getDirectoryContents d - case any ((fileBase==) . takeBaseName) files of - True -> return Nothing - False -> return $ Just (upd fileBase) - -hashToHexStr :: Hash -> String -hashToHexStr n = printf "%016x" n' - where - n' :: Integer - n' = fromIntegral n - fromIntegral (minBound :: Int)