module Diagrams.Builder
(
BuildOpts(..), mkBuildOpts, backendOpts, snippets, pragmas, imports, qimports, decideRegen, diaExpr, postProcess
, alwaysRegenerate, hashedRegenerate
, hashToHexStr
, buildDiagram, BuildResult(..)
, ppInterpError
, setDiagramImports
, interpretDiagram
, Build(..)
, defaultBuildOpts
) where
import Control.Arrow (second)
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)
import Data.Orphans ()
import System.Directory (doesFileExist,
getTemporaryDirectory,
removeFile)
import System.FilePath (takeBaseName, (<.>),
(</>))
import System.IO (hClose, hPutStr,
openTempFile)
import Language.Haskell.Exts.Simple
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)
setDiagramImports
:: MonadInterpreter m
=> String
-> [(String, Maybe String)]
-> m ()
setDiagramImports m imps = do
loadModules [m]
setTopLevelModules [takeBaseName m]
setImportsQ $
map (, Nothing)
[ "Prelude"
, "Diagrams.Prelude"
, "Data.Monoid"
]
++ imps
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
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 $
map (,Nothing) (bopts ^. imports) ++ map (second Just) (bopts ^. qimports)
let dexp = bopts ^. diaExpr
d <- interpret dexp (as :: QDiagram b v n Any) `catchAll` const (interpret dexp (as :: IO (QDiagram b v n Any)) >>= liftIO)
return $ renderDia (backendToken bopts) (bopts ^. backendOpts) ((bopts ^. postProcess) d)
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
data BuildResult b v n =
ParseErr String
| InterpErr InterpreterError
| Skipped Hash
| OK Hash (Result b v n)
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", "TypeFamilies", "FlexibleContexts"] ++)
& 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
hashLocalImports :: [ImportDecl] -> IO Hash
hashLocalImports
= fmap (foldl' hashWithSalt 0 . catMaybes)
. mapM (getLocalSource . foldr1 (</>) . splitOn "." . getModuleName . importModule)
getLocalSource :: FilePath -> IO (Maybe String)
getLocalSource f = runMaybeT $ do
contents <- getLocal f
case (doModuleParse . unLit) contents of
Left _ -> mzero
Right m -> return (prettyPrint m)
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)