From 0152599eff1cb3c706a567257c956743391f5c23 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Fri, 5 Dec 2014 20:30:02 +0000 Subject: [PATCH 1/6] Very rough start to builder changes. --- diagrams-builder.cabal | 4 +- src/Diagrams/Builder.hs | 358 +++++++++++++++++++------------- src/Diagrams/Builder/Modules.hs | 2 +- src/Diagrams/Builder/Opts.hs | 105 +++++----- 4 files changed, 270 insertions(+), 199 deletions(-) diff --git a/diagrams-builder.cabal b/diagrams-builder.cabal index 9fed586..b6308c4 100644 --- a/diagrams-builder.cabal +++ b/diagrams-builder.cabal @@ -59,7 +59,9 @@ 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, + diagrams-pgf hs-source-dirs: src default-language: Haskell2010 other-extensions: StandaloneDeriving, diff --git a/src/Diagrams/Builder.hs b/src/Diagrams/Builder.hs index a009541..45d6c91 100644 --- a/src/Diagrams/Builder.hs +++ b/src/Diagrams/Builder.hs @@ -1,9 +1,13 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -17,62 +21,68 @@ -- preprocessors to interpret diagrams code embedded in documents. -- ----------------------------------------------------------------------------- -module Diagrams.Builder - ( -- * Building diagrams +module Diagrams.Builder where + -- ( -- * Building diagrams - -- ** Options - BuildOpts(..), mkBuildOpts, backendOpts, snippets, pragmas, imports, decideRegen, diaExpr, postProcess + -- -- ** Options + -- BuildOpts(..), mkBuildOpts, backendOpts, snippets, pragmas, imports, + -- diaExpr, postProcess - -- ** Regeneration decision functions and hashing - , alwaysRegenerate, hashedRegenerate - , hashToHexStr + -- -- ** Regeneration decision functions and hashing + -- -- , alwaysRegenerate, hashedRegenerate + -- -- , hashToHexStr - -- ** Building - , buildDiagram, BuildResult(..) - , ppInterpError + -- -- ** Building + -- , buildDiagram, BuildResult(..) + -- , ppInterpError - -- * Interpreting diagrams - -- $interp - , setDiagramImports - , interpretDiagram + -- -- * Interpreting diagrams + -- -- $interp + -- , setDiagramImports + -- , interpretDiagram - -- * Tools for creating standalone builder executables + -- -- * Tools for creating standalone builder executables - , Build(..) - , defaultBuildOpts + -- , Build(..) + -- , defaultBuildOpts - ) where + -- ) where -import Control.Lens ((^.)) -import Control.Monad (guard, mplus, mzero) -import Control.Monad.Catch (catchAll) -import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) +import Control.Lens (cons, (^.)) +import Control.Monad +import Control.Monad.Catch +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 +import Data.Foldable (Foldable) +import Data.Hashable (Hashable (..)) +import Data.List (foldl', nub) +import Data.List (find) +import Data.List.Split (splitOn) +import Data.Maybe +import Data.Traversable as T (Traversable, mapM) +import Data.Word (Word) +import Numeric (showHex) +import System.Directory (doesFileExist) +import System.Directory (getDirectoryContents) +import System.FilePath (takeBaseName, (<.>), ()) +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) deriving instance Typeable Any +-- Typeable1 is a depreciated synonym in ghc > 707 +#if __GLASGOW_HASKELL__ >= 707 +#define Typeable1 Typeable +#endif + ------------------------------------------------------------ -- Interpreting diagrams ------------------------------------------------------------ @@ -97,123 +107,163 @@ setDiagramImports -> 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 - ) + loadModules [m] + setTopLevelModules [takeBaseName m] + setImports $ [ "Prelude" + , "Diagrams.Prelude" + , "Diagrams.Core.Types" + , "Data.Monoid" + ] + ++ imps + +-- standardImports :: [ModuleName] +-- standardImports = +-- [ "Prelude" +-- , "Diagrams.Prelude" +-- , "Diagrams.Core.Types" +-- , "Data.Monoid" +-- ] + +-- 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) + +interpretDia + :: (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) + -> m (QDiagram b v n Any) +interpretDia bopts m = do + setDiagramImports m (bopts ^. imports) + interpDiagram (bopts ^. diaExpr) + +interpretResult + :: ( MonadInterpreter m + , Typeable b, Typeable1 v, HasLinearMap v, Metric v + , Typeable n, OrderedField n, Backend b v n) + => BuildOpts b v n + -> FilePath + -> m (Result b v n) +interpretResult bopts m = f `liftM` interpretDia bopts m + where + f d = renderDia (backendToken bopts) (bopts ^. backendOpts) ((bopts ^. postProcess) d) - -- Finally, call renderDia. - return $ renderDia (backendToken bopts) (bopts ^. backendOpts) ((bopts ^. postProcess) d) +interpretBuild + :: (MonadInterpreter m, BackendBuild b v n r + , Typeable b, Typeable1 v, HasLinearMap v, Metric v + , Typeable n, OrderedField n + ) + => BuildOpts b v n + -> FilePath -- ^ path to Module + -> r + -> FilePath -- ^ path to save diagram + -> m (Maybe String) +interpretBuild bopts m r outF = interpretDia bopts m >>= liftIO . f + where + f = buildDia' r outF (bopts ^. backendOpts) --- | 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 +-- | Interpret a @Diagram@ or @IO Diagram@ at the name of the function. +interpDiagram :: forall m b v n m'. (MonadInterpreter m, Typeable (QDiagram b v n m')) + => String -> m (QDiagram b v n m') +interpDiagram dExp = + interpret dExp (as :: QDiagram b v n m') `catchAll` + const (interpret dExp (as :: IO (QDiagram b v n m')) >>= liftIO) ------------------------------------------------------------- +------------------------------------------------------------------------ -- 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 +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 (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) + | OK Hash r -- ^ A successful build + deriving (Show, Functor, Foldable, Traversable) + +buildResult + :: (MonadInterpreter m, BackendBuild b v n r, Hashable (Options b v n ) + , Typeable b, Typeable1 v, HasLinearMap v, Metric v + , Typeable n, OrderedField 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 + => BuildOpts b v n + -> r + -> FilePath + -> m (BuildResult (Maybe String)) +buildResult opts r outF = do + d <- buildDiagram opts + liftIO $ buildDia' r outF (opts ^. backendOpts) `T.mapM` d + +buildDiagram + :: (MonadInterpreter m, Typeable (QDiagram b v n Any), Hashable (Options b v n)) + => BuildOpts b v n + -> m (BuildResult (QDiagram b v n Any)) +buildDiagram (prepareOpts -> bopts) = case createModule Nothing bopts of + Left err -> return (ParseError err) + Right m -> do + diaHash <- liftIO $ hashModule bopts m + case bopts ^. hashCache of + Nothing -> OK diaHash `liftM` buildDiagram' bopts m + Just path -> do + alreadyDone <- liftIO $ isJust <$> checkHash path diaHash + if alreadyDone + then return $ Skipped diaHash + else OK diaHash `liftM` buildDiagram' bopts m + +buildDiagram' + :: (MonadInterpreter m, Typeable (QDiagram b v n Any)) + => BuildOpts b v n + -> Module + -> m (QDiagram b v n Any) +buildDiagram' bopts m = tempModule m (interpretDia bopts) + +-- | Write a module to a tempory file and delete it when done. The +-- module name is replaced by the tempory 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 + liftIO $ putStrLn $ prettyPrint m' + f temp + +-- | 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 ((== hashHex 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" + +------------------------------------------------------------------------ +-- 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 @@ -223,7 +273,7 @@ buildDiagram bopts = do 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 +295,17 @@ 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 + +hashHex :: Hash -> String +hashHex h = showHex (fromIntegral h :: Word) "" 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..5d17b8d 100644 --- a/src/Diagrams/Builder/Opts.hs +++ b/src/Diagrams/Builder/Opts.hs @@ -20,19 +20,20 @@ module Diagrams.Builder.Opts ( -- * Options Hash - , BuildOpts(..), mkBuildOpts, backendOpts, snippets, pragmas, imports, decideRegen, diaExpr, postProcess + , BuildOpts(..), mkBuildOpts, backendOpts, snippets, pragmas, + imports, hashCache, diaExpr, postProcess -- * Rebuilding - , alwaysRegenerate, hashedRegenerate, hashToHexStr + -- , alwaysRegenerate, hashedRegenerate, hashToHexStr ) where import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, (&), (.~)) -import System.Directory (getDirectoryContents) -import System.FilePath (takeBaseName) -import Text.Printf +-- import System.Directory (getDirectoryContents) +-- import System.FilePath (takeBaseName) +-- import Text.Printf import Diagrams.Prelude (QDiagram, Options, Any) @@ -66,7 +67,8 @@ data BuildOpts b v n , _snippets :: [String] , _pragmas :: [String] , _imports :: [String] - , _decideRegen :: Hash -> IO (Maybe (Options b v n -> Options b v n)) + -- , _decideRegen :: Hash -> IO (Maybe (Options b v n -> Options b v n)) + , _hashCache :: Maybe FilePath , _diaExpr :: String , _postProcess :: QDiagram b v n Any -> QDiagram b v n Any } @@ -88,7 +90,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 +129,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 +148,45 @@ 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) +-- -- | 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) From ef9002646a21ea9ae07f307105efb8df9aa925c0 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Fri, 19 Dec 2014 04:00:25 +0000 Subject: [PATCH 2/6] More builder changes. --- src/Diagrams/Builder.hs | 150 ++++++++++++++++++++++++++++------------ 1 file changed, 105 insertions(+), 45 deletions(-) diff --git a/src/Diagrams/Builder.hs b/src/Diagrams/Builder.hs index 45d6c91..a92ff63 100644 --- a/src/Diagrams/Builder.hs +++ b/src/Diagrams/Builder.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -48,7 +49,7 @@ module Diagrams.Builder where -- ) where -import Control.Lens (cons, (^.)) +import Control.Lens (cons, (^.), (^?), Traversal', _Just) import Control.Monad import Control.Monad.Catch import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) @@ -62,9 +63,8 @@ import Data.Maybe import Data.Traversable as T (Traversable, mapM) import Data.Word (Word) import Numeric (showHex) -import System.Directory (doesFileExist) -import System.Directory (getDirectoryContents) -import System.FilePath (takeBaseName, (<.>), ()) +import System.Directory (getDirectoryContents, doesFileExist, copyFile) +import System.FilePath (takeBaseName, (<.>), (), takeExtension) import System.IO (hClose, hPutStr) import System.IO.Temp @@ -83,6 +83,10 @@ deriving instance Typeable Any #define Typeable1 Typeable #endif +type BuildBackend b v n = + (BackendBuild b v n, Hashable (Options b v n), Typeable b, Typeable1 v, + HasLinearMap v, Metric v, Typeable n, OrderedField n) + ------------------------------------------------------------ -- Interpreting diagrams ------------------------------------------------------------ @@ -132,6 +136,7 @@ setDiagramImports m imps = do -- _ -> hsenvArgv -- where hsenvArgv = words $ fromMaybe "" (lookup "PACKAGE_DB_FOR_GHC" env) +-- | Interpret the module and return the 'Diagram'. interpretDia :: (MonadInterpreter m, Typeable (QDiagram b v n Any)) => BuildOpts b v n @@ -141,6 +146,7 @@ interpretDia bopts m = do setDiagramImports m (bopts ^. imports) interpDiagram (bopts ^. diaExpr) +-- | Interpret the module and return the 'Result'. interpretResult :: ( MonadInterpreter m , Typeable b, Typeable1 v, HasLinearMap v, Metric v @@ -152,21 +158,20 @@ interpretResult bopts m = f `liftM` interpretDia bopts m where f d = renderDia (backendToken bopts) (bopts ^. backendOpts) ((bopts ^. postProcess) d) +-- | Interpret the module and save the diagram. interpretBuild - :: (MonadInterpreter m, BackendBuild b v n r - , Typeable b, Typeable1 v, HasLinearMap v, Metric v - , Typeable n, OrderedField n - ) + :: (MonadInterpreter m, BuildBackend b v n) => BuildOpts b v n -> FilePath -- ^ path to Module - -> r -> FilePath -- ^ path to save diagram - -> m (Maybe String) -interpretBuild bopts m r outF = interpretDia bopts m >>= liftIO . f + -> m () +interpretBuild bopts m outF = interpretDia bopts m >>= liftIO . f where - f = buildDia' r outF (bopts ^. backendOpts) + f = saveDia outF (bopts ^. backendOpts) -- | Interpret a @Diagram@ or @IO Diagram@ at the name of the function. +-- (This means the source should already be loaded by the +-- interpreter.) interpDiagram :: forall m b v n m'. (MonadInterpreter m, Typeable (QDiagram b v n m')) => String -> m (QDiagram b v n m') interpDiagram dExp = @@ -187,41 +192,94 @@ data BuildResult r | OK Hash r -- ^ A successful build deriving (Show, Functor, Foldable, Traversable) -buildResult - :: (MonadInterpreter m, BackendBuild b v n r, Hashable (Options b v n ) - , Typeable b, Typeable1 v, HasLinearMap v, Metric v - , Typeable n, OrderedField n - ) +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. +buildToHash + :: BuildBackend b v n + => BuildOpts b v n + -> String -- ^ extension + -> IO (BuildResult ()) +buildToHash opts ext = do + let dir = opts ^. hashCache . _Just + d <- buildDiagram 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 it's hash and copy it to file. +buildBuild + :: BuildBackend b v n => BuildOpts b v n - -> r -> FilePath - -> m (BuildResult (Maybe String)) -buildResult opts r outF = do + -> IO (BuildResult ()) +buildBuild opts outFile = do + let ext = takeExtension outFile + r <- buildToHash opts (takeExtension outFile) + case r ^? resultHash of + Just h -> copyFile (mkFile h ext) outFile + >> return r + Nothing -> return r + -- saveDia outFile (opts ^. backendOpts) `T.mapM` d + where + mkFile base ext = showHash base <.> ext + +buildResult + :: BuildBackend b v n + => BuildOpts b v n + -> IO (BuildResult (Result b v n)) +buildResult opts = do d <- buildDiagram opts - liftIO $ buildDia' r outF (opts ^. backendOpts) `T.mapM` d + return $ renderDia undefined (opts ^. backendOpts) <$> d +-- | Build a diagram. If the module hash is found, skip interpreting. buildDiagram - :: (MonadInterpreter m, Typeable (QDiagram b v n Any), Hashable (Options b v n)) + :: (Typeable (QDiagram b v n Any), Hashable (Options b v n), Typeable n, Typeable b, Typeable1 v) => BuildOpts b v n - -> m (BuildResult (QDiagram b v n Any)) + -> IO (BuildResult (QDiagram b v n Any)) buildDiagram (prepareOpts -> bopts) = case createModule Nothing bopts of Left err -> return (ParseError err) Right m -> do - diaHash <- liftIO $ hashModule bopts m + diaHash <- hashModule bopts m + + let getDia = do + d <- runInterpreter $ interpretDiaModule bopts m + return $ either InterpError (OK diaHash) d + case bopts ^. hashCache of - Nothing -> OK diaHash `liftM` buildDiagram' bopts m + Nothing -> getDia Just path -> do - alreadyDone <- liftIO $ isJust <$> checkHash path diaHash + alreadyDone <- isJust <$> checkHash path diaHash if alreadyDone then return $ Skipped diaHash - else OK diaHash `liftM` buildDiagram' bopts m - -buildDiagram' + else getDia + +-- buildDiagram +-- :: (MonadInterpreter m, Typeable (QDiagram b v n Any), Hashable (Options b v n)) +-- => BuildOpts b v n +-- -> IO (Either String (QDiagram b v n Any)) +-- buildDiagram (prepareOpts -> bopts) = case createModule Nothing bopts of +-- Left err -> return (ParseError err) +-- Right m -> do +-- diaHash <- liftIO $ hashModule bopts m +-- case bopts ^. hashCache of +-- Nothing -> OK diaHash `liftM` buildDiagram' bopts m +-- Just path -> do +-- alreadyDone <- liftIO $ isJust <$> checkHash path diaHash +-- if alreadyDone +-- then return $ Skipped diaHash +-- else OK diaHash `liftM` buildDiagram' bopts m + +interpretDiaModule :: (MonadInterpreter m, Typeable (QDiagram b v n Any)) => BuildOpts b v n -> Module -> m (QDiagram b v n Any) -buildDiagram' bopts m = tempModule m (interpretDia bopts) +interpretDiaModule bopts m = tempModule m (interpretDia bopts) -- | Write a module to a tempory file and delete it when done. The -- module name is replaced by the tempory file's name (\"Diagram\"). @@ -230,21 +288,8 @@ tempModule m f = withSystemTempFile "Diagram.hs" $ \temp h -> do let m' = replaceModuleName (takeBaseName temp) m liftIO $ hPutStr h (prettyPrint m') >> hClose h - liftIO $ putStrLn $ prettyPrint m' f temp --- | 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 ((== hashHex 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" - ------------------------------------------------------------------------ -- Hashing ------------------------------------------------------------------------ @@ -307,5 +352,20 @@ ppInterpError (WontCompile es) = unlines . nub . map errMsg $ es ppInterpError (NotAllowed err) = "NotAllowed: " ++ err ppInterpError (GhcException err) = "GhcException: " ++ err -hashHex :: Hash -> String -hashHex h = showHex (fromIntegral h :: Word) "" +-- 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" From 861677ec05a8a915fcfa9ac54ce54d305d1da672 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 19 Jan 2015 07:44:00 +0000 Subject: [PATCH 3/6] Cleanup. --- src/Diagrams/Builder.hs | 280 ++++++++++++++++++---------------------- 1 file changed, 126 insertions(+), 154 deletions(-) diff --git a/src/Diagrams/Builder.hs b/src/Diagrams/Builder.hs index a92ff63..642ae0d 100644 --- a/src/Diagrams/Builder.hs +++ b/src/Diagrams/Builder.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} @@ -8,7 +9,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ConstraintKinds #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- @@ -22,49 +22,59 @@ -- preprocessors to interpret diagrams code embedded in documents. -- ----------------------------------------------------------------------------- -module Diagrams.Builder where - -- ( -- * Building diagrams - - -- -- ** Options - -- BuildOpts(..), mkBuildOpts, backendOpts, snippets, pragmas, imports, - -- 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 (cons, (^.), (^?), Traversal', _Just) +module Diagrams.Builder + ( -- * 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' + + ) where + +import Control.Lens (Traversal', cons, (^.), (^?), + _Just) import Control.Monad import Control.Monad.Catch import Control.Monad.Trans.Maybe (MaybeT, runMaybeT) -import Data.Data import Data.Foldable (Foldable) import Data.Hashable (Hashable (..)) -import Data.List (foldl', nub) -import Data.List (find) +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 (getDirectoryContents, doesFileExist, copyFile) -import System.FilePath (takeBaseName, (<.>), (), takeExtension) +import System.Directory (copyFile, doesFileExist, + getDirectoryContents) +import System.FilePath (takeBaseName, takeExtension, + (<.>), ()) import System.IO (hClose, hPutStr) import System.IO.Temp @@ -73,7 +83,8 @@ import Diagrams.Builder.Modules import Diagrams.Builder.Opts import Diagrams.Prelude -import Language.Haskell.Exts (ImportDecl, Module (..), importModule, prettyPrint) +import Language.Haskell.Exts (ImportDecl, Module (..), + importModule, prettyPrint) import Language.Haskell.Interpreter hiding (ModuleName) deriving instance Typeable Any @@ -83,10 +94,16 @@ deriving instance Typeable Any #define Typeable1 Typeable #endif -type BuildBackend b v n = +-- 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) + ------------------------------------------------------------ -- Interpreting diagrams ------------------------------------------------------------ @@ -94,89 +111,59 @@ type BuildBackend b v n = -- $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 +setDiaImports m imps = do loadModules [m] setTopLevelModules [takeBaseName m] setImports $ [ "Prelude" , "Diagrams.Prelude" - , "Diagrams.Core.Types" - , "Data.Monoid" ] ++ imps --- standardImports :: [ModuleName] --- standardImports = --- [ "Prelude" --- , "Diagrams.Prelude" --- , "Diagrams.Core.Types" --- , "Data.Monoid" --- ] - --- 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 the module and return the 'Diagram'. -interpretDia +-- | 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 -> m (QDiagram b v n Any) -interpretDia bopts m = do - setDiagramImports m (bopts ^. imports) - interpDiagram (bopts ^. diaExpr) - --- | Interpret the module and return the 'Result'. -interpretResult - :: ( MonadInterpreter m - , Typeable b, Typeable1 v, HasLinearMap v, Metric v - , Typeable n, OrderedField n, Backend b v n) - => BuildOpts b v n - -> FilePath - -> m (Result b v n) -interpretResult bopts m = f `liftM` interpretDia bopts m - where - f d = renderDia (backendToken bopts) (bopts ^. backendOpts) ((bopts ^. postProcess) d) +interpretDiaWithOpts bopts m = do + setDiaImports m (bopts ^. imports) + (bopts ^. postProcess) `liftM` interpretDia (bopts ^. diaExpr) --- | Interpret the module and save the diagram. -interpretBuild - :: (MonadInterpreter m, BuildBackend b v n) +-- | 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) + +-- | 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 - -> FilePath -- ^ path to Module - -> FilePath -- ^ path to save diagram - -> m () -interpretBuild bopts m outF = interpretDia bopts m >>= liftIO . f - where - f = saveDia outF (bopts ^. backendOpts) + -> 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.) -interpDiagram :: forall m b v n m'. (MonadInterpreter m, Typeable (QDiagram b v n m')) - => String -> m (QDiagram b v n m') -interpDiagram dExp = - interpret dExp (as :: QDiagram b v n m') `catchAll` - const (interpret dExp (as :: IO (QDiagram b v n m')) >>= liftIO) +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) ------------------------------------------------------------------------ -- Build a diagram using a temporary file @@ -184,64 +171,73 @@ interpDiagram dExp = -- | Potential results of a dynamic diagram building operation. data BuildResult r - = ParseError String -- ^ Parsing of the code failed. + = 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 + -- 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. -buildToHash - :: BuildBackend b v n +-- | 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 ()) -buildToHash opts ext = do +buildDiaToHash opts ext = do let dir = opts ^. hashCache . _Just - d <- buildDiagram opts + 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 it's hash and copy it to file. -buildBuild - :: BuildBackend b v n +-- | 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 ()) -buildBuild opts outFile = do +buildDiaToFile bopts outFile = do let ext = takeExtension outFile - r <- buildToHash opts (takeExtension outFile) - case r ^? resultHash of - Just h -> copyFile (mkFile h ext) outFile - >> return r - Nothing -> return r - -- saveDia outFile (opts ^. backendOpts) `T.mapM` d - where - mkFile base ext = showHash base <.> ext - -buildResult - :: BuildBackend b v n + 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)) -buildResult opts = do - d <- buildDiagram opts - return $ renderDia undefined (opts ^. backendOpts) <$> d +buildDiaResult opts = do + d <- buildDia opts + return $ diaResult opts <$> d -- | Build a diagram. If the module hash is found, skip interpreting. -buildDiagram - :: (Typeable (QDiagram b v n Any), Hashable (Options b v n), Typeable n, Typeable b, Typeable1 v) +buildDia + :: (Hashable (Options b v n), Typeable b, Typeable1 v, Typeable n) => BuildOpts b v n -> IO (BuildResult (QDiagram b v n Any)) -buildDiagram (prepareOpts -> bopts) = case createModule Nothing bopts of +buildDia (prepareOpts -> bopts) = case createModule Nothing bopts of Left err -> return (ParseError err) Right m -> do diaHash <- hashModule bopts m @@ -258,31 +254,8 @@ buildDiagram (prepareOpts -> bopts) = case createModule Nothing bopts of then return $ Skipped diaHash else getDia --- buildDiagram --- :: (MonadInterpreter m, Typeable (QDiagram b v n Any), Hashable (Options b v n)) --- => BuildOpts b v n --- -> IO (Either String (QDiagram b v n Any)) --- buildDiagram (prepareOpts -> bopts) = case createModule Nothing bopts of --- Left err -> return (ParseError err) --- Right m -> do --- diaHash <- liftIO $ hashModule bopts m --- case bopts ^. hashCache of --- Nothing -> OK diaHash `liftM` buildDiagram' bopts m --- Just path -> do --- alreadyDone <- liftIO $ isJust <$> checkHash path diaHash --- if alreadyDone --- then return $ Skipped diaHash --- else OK diaHash `liftM` buildDiagram' bopts m - -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 (interpretDia bopts) - --- | Write a module to a tempory file and delete it when done. The --- module name is replaced by the tempory file's name (\"Diagram\"). +-- | 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 @@ -314,7 +287,7 @@ hashModule bopts m@(Module _ _ _ _ _ srcImps _) = do -- 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) @@ -357,7 +330,6 @@ ppInterpError (GhcException err) = "GhcException: " ++ err 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) From 7c02b31a581f8d5e23e64e0d3c3897c8c3344651 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Mon, 19 Jan 2015 07:47:40 +0000 Subject: [PATCH 4/6] Cabal file changes. --- diagrams-builder.cabal | 49 +++++++++++++++++++----------------------- 1 file changed, 22 insertions(+), 27 deletions(-) diff --git a/diagrams-builder.cabal b/diagrams-builder.cabal index b6308c4..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 @@ -60,8 +56,7 @@ library lens >= 4.0 && < 4.7, hashable >= 1.1 && < 1.3, exceptions >= 0.3 && < 0.7, - temporary >= 1.2 && < 1.3, - diagrams-pgf + temporary >= 1.2 && < 1.3 hs-source-dirs: src default-language: Haskell2010 other-extensions: StandaloneDeriving, From c0767aa6112e262608c8ff747bf712bd3441fa1c Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Sun, 25 Jan 2015 19:46:00 +0000 Subject: [PATCH 5/6] Cleanup. --- src/Diagrams/Builder.hs | 15 ++++- src/Diagrams/Builder/Opts.hs | 106 +++++++++-------------------------- 2 files changed, 39 insertions(+), 82 deletions(-) diff --git a/src/Diagrams/Builder.hs b/src/Diagrams/Builder.hs index 642ae0d..b391c12 100644 --- a/src/Diagrams/Builder.hs +++ b/src/Diagrams/Builder.hs @@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- -- | -- 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 -- @@ -53,7 +53,7 @@ module Diagrams.Builder , interpretDia -- * Type aliases - , Backend', BackendBuild' + , Backend', BackendBuild', Hash ) where @@ -104,6 +104,17 @@ 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 ------------------------------------------------------------ diff --git a/src/Diagrams/Builder/Opts.hs b/src/Diagrams/Builder/Opts.hs index 5d17b8d..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,61 +17,49 @@ -- ----------------------------------------------------------------------------- module Diagrams.Builder.Opts - ( -- * Options + ( -- * Options + BuildOpts(..) + , mkBuildOpts + , backendOpts + , snippets + , pragmas + , + imports + , hashCache + , diaExpr + , postProcess - Hash - , BuildOpts(..), mkBuildOpts, backendOpts, snippets, pragmas, - imports, hashCache, 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)) - , _hashCache :: Maybe FilePath - , _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 @@ -148,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) From 5ddfcc71e85cd9e0a3ea1661b5575d1c89886926 Mon Sep 17 00:00:00 2001 From: Christopher Chalmers Date: Wed, 28 Jan 2015 23:37:48 +0000 Subject: [PATCH 6/6] Added sandbox support. --- src/Diagrams/Builder.hs | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/src/Diagrams/Builder.hs b/src/Diagrams/Builder.hs index b391c12..249c97f 100644 --- a/src/Diagrams/Builder.hs +++ b/src/Diagrams/Builder.hs @@ -86,6 +86,7 @@ import Diagrams.Prelude import Language.Haskell.Exts (ImportDecl, Module (..), importModule, prettyPrint) import Language.Haskell.Interpreter hiding (ModuleName) +import Language.Haskell.Interpreter.Unsafe deriving instance Typeable Any @@ -152,11 +153,6 @@ interpretDiaWithOpts bopts m = do setDiaImports m (bopts ^. imports) (bopts ^. postProcess) `liftM` interpretDia (bopts ^. diaExpr) --- | 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) - -- | Same as 'interpretDiaWithOpts' but save 'Module' to a temporary file -- and import it. interpretDiaModule @@ -176,6 +172,11 @@ 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 ------------------------------------------------------------------------ @@ -254,7 +255,7 @@ buildDia (prepareOpts -> bopts) = case createModule Nothing bopts of diaHash <- hashModule bopts m let getDia = do - d <- runInterpreter $ interpretDiaModule bopts m + d <- runSandboxInterpreter $ interpretDiaModule bopts m return $ either InterpError (OK diaHash) d case bopts ^. hashCache of @@ -265,6 +266,16 @@ buildDia (prepareOpts -> bopts) = case createModule Nothing bopts of 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 @@ -332,7 +343,7 @@ getLocal m = tryExt "hs" `mplus` tryExt "lhs" -- | Pretty-print an @InterpreterError@. ppInterpError :: InterpreterError -> String ppInterpError (UnknownError err) = "UnknownError: " ++ err -ppInterpError (WontCompile es) = unlines . nub . map errMsg $ es +ppInterpError (WontCompile es) = unlines . nub $ map errMsg es ppInterpError (NotAllowed err) = "NotAllowed: " ++ err ppInterpError (GhcException err) = "GhcException: " ++ err