diagrams-builder-0.7.0.3: src/Diagrams/Builder.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module : Diagrams.Builder
-- Copyright : (c) 2012 diagrams-lib team (see LICENSE)
-- License : BSD-style (see LICENSE)
-- Maintainer : diagrams-discuss@googlegroups.com
--
-- Tools for dynamically building diagrams, for /e.g./ creating
-- preprocessors to interpret diagrams code embedded in documents.
--
-----------------------------------------------------------------------------
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.Monad (guard, mplus, mzero)
import Control.Monad.Catch (MonadMask, 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)
-- for Typeable Any instance
import Data.Orphans
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 Diagrams.Builder.Modules
import Diagrams.Builder.Opts
import Diagrams.Prelude
import Language.Haskell.Interpreter.Unsafe (unsafeRunInterpreterWithArgs)
------------------------------------------------------------
-- Interpreting diagrams
------------------------------------------------------------
-- $interp
-- These functions constitute the internals of diagrams-builder. End
-- users should not usually need to call them directly; use
-- 'buildDiagram' instead.
-- | Set up the module to be interpreted, in the context of the
-- necessary imports.
setDiagramImports
:: 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.
-> m ()
setDiagramImports m imps = do
loadModules [m]
setTopLevelModules [takeBaseName m]
setImports $ [ "Prelude"
, "Diagrams.Prelude"
, "Diagrams.Core.Types"
, "Data.Monoid"
]
++ imps
-- | 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
-- | 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
)
=> BuildOpts b v n
-> FilePath
-> IO (Either InterpreterError (Result b v n))
interpretDiagram bopts m = do
runSandboxInterpreter $ 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
------------------------------------------------------------
-- 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
-- | 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.
hashLocalImports :: [ImportDecl] -> IO Hash
hashLocalImports
= fmap (foldl' hashWithSalt 0 . catMaybes)
. 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
-- a @.hs@ or @.lhs@ extension; if so, return its /pretty-printed/
-- contents (removing all comments, canonicalizing formatting, /etc./).
getLocalSource :: FilePath -> IO (Maybe String)
getLocalSource f = runMaybeT $ do
contents <- getLocal f
case (doModuleParse . unLit) contents of
Left _ -> mzero
Right m -> return (prettyPrint m)
-- | Given a relative path with no extension, like
-- @\"Foo\/Bar\/Baz\"@, check whether such a file exists with either a
-- @.hs@ or @.lhs@ extension; if so, return its contents.
getLocal :: FilePath -> MaybeT IO String
getLocal m = tryExt "hs" `mplus` tryExt "lhs"
where
tryExt ext = do
let f = m <.> ext
liftIO (doesFileExist f) >>= guard >> liftIO (readFile f)