{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
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.Char (isAlphaNum)
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 [takeWhile isAlphaNum $ 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 (takeWhile isAlphaNum $ takeBaseName tmp) m
hPutStr h (prettyPrint m')
hClose h
compilation <- interpretDiagram (bopts' & backendOpts %~ upd) tmp
removeFile tmp
return $ either InterpErr (OK diaHash) compilation
Right m -> error $ "Diagrams.Builder.buildDiagram: weird module " ++ show m
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)