module Diagrams.Builder
(
BuildOpts(..), mkBuildOpts, backendOpts, snippets, pragmas, imports, decideRegen, diaExpr, postProcess
, alwaysRegenerate, hashedRegenerate
, hashToHexStr
, buildDiagram, BuildResult(..)
, ppInterpError
, setDiagramImports
, interpretDiagram
, 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 Data.Typeable (Typeable)
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 hiding ((<.>))
import Language.Haskell.Interpreter.Unsafe (unsafeRunInterpreterWithArgs)
import System.Environment (getEnvironment)
deriving instance Typeable Any
setDiagramImports
:: MonadInterpreter m
=> String
-> [String]
-> 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)
interpretDiagram
:: forall b v.
( Typeable b, Typeable v, Data v, Data (Scalar v)
, InnerSpace v, OrderedField (Scalar v), Backend b v
)
=> BuildOpts b v
-> FilePath
-> IO (Either InterpreterError (Result b v))
interpretDiagram bopts m = do
args <- liftIO getHsenvArgv
unsafeRunInterpreterWithArgs args $ do
setDiagramImports m (bopts ^. imports)
let dexp = bopts ^. diaExpr
d <- interpret dexp (as :: Diagram b v) `catchAll` const (interpret dexp (as :: IO (Diagram b v)) >>= 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 =
ParseErr String
| InterpErr InterpreterError
| Skipped Hash
| OK Hash (Result b v)
buildDiagram
:: ( Typeable b, Typeable v, Data v, Data (Scalar v)
, InnerSpace v, OrderedField (Scalar v), Backend b v
, Hashable (Options b v)
)
=> BuildOpts b v -> IO (BuildResult b v)
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
hashLocalImports :: [ImportDecl] -> IO Hash
hashLocalImports
= fmap (foldl' hashWithSalt 0 . catMaybes)
. mapM getLocalSource
. map (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)