{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# 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, qimports, 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.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)
-- 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.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)

------------------------------------------------------------
-- 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, Maybe String)]
     -- ^ Additional necessary imports, along with qualified names.
     --   @Prelude@, @Diagrams.Prelude@, @Diagrams.Core.Types@, and
     --   @Data.Monoid@ are included (unqualified) by default.

  -> m ()

setDiagramImports :: forall (m :: * -> *).
MonadInterpreter m =>
String -> [(String, Maybe String)] -> m ()
setDiagramImports String
m [(String, Maybe String)]
imps = do
    forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
loadModules [String
m]
    forall (m :: * -> *). MonadInterpreter m => [String] -> m ()
setTopLevelModules [forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isAlphaNum forall a b. (a -> b) -> a -> b
$ String -> String
takeBaseName String
m]
    forall (m :: * -> *).
MonadInterpreter m =>
[(String, Maybe String)] -> m ()
setImportsQ forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map (, forall a. Maybe a
Nothing)
        [ String
"Prelude"
        , String
"Diagrams.Prelude"
        , String
"Data.Monoid"
        ]
        forall a. [a] -> [a] -> [a]
++ [(String, Maybe String)]
imps

-- | Run an interpretor using sandbox from 'findSandbox'.
runSandboxInterpreter :: (MonadMask m, MonadIO m, Functor m)
                      => InterpreterT m a -> m (Either InterpreterError a)
runSandboxInterpreter :: forall (m :: * -> *) a.
(MonadMask m, MonadIO m, Functor m) =>
InterpreterT m a -> m (Either InterpreterError a)
runSandboxInterpreter InterpreterT m a
i = do
  Maybe String
mSandbox <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [String] -> IO (Maybe String)
findSandbox []
  case Maybe String
mSandbox of
    Just String
sandbox -> let args :: [String]
args = [String
"-package-db", String
sandbox]
                    in  forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
[String] -> InterpreterT m a -> m (Either InterpreterError a)
unsafeRunInterpreterWithArgs [String]
args InterpreterT m a
i
    Maybe String
Nothing      -> forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InterpreterT m a -> m (Either InterpreterError a)
runInterpreter InterpreterT m a
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 :: forall b (v :: * -> *) n.
(Typeable b, Typeable v, HasLinearMap v, Data (v n), Data n,
 Metric v, OrderedField n, Backend b v n) =>
BuildOpts b v n
-> String -> IO (Either InterpreterError (Result b v n))
interpretDiagram BuildOpts b v n
bopts String
m = do

  forall (m :: * -> *) a.
(MonadMask m, MonadIO m, Functor m) =>
InterpreterT m a -> m (Either InterpreterError a)
runSandboxInterpreter forall a b. (a -> b) -> a -> b
$ do

    forall (m :: * -> *).
MonadInterpreter m =>
String -> [(String, Maybe String)] -> m ()
setDiagramImports String
m forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map (,forall a. Maybe a
Nothing) (BuildOpts b v n
bopts forall s a. s -> Getting a s a -> a
^. forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [String]
imports) forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. a -> Maybe a
Just) (BuildOpts b v n
bopts forall s a. s -> Getting a s a -> a
^. forall b (v :: * -> *) n.
Lens' (BuildOpts b v n) [(String, String)]
qimports)
    let dexp :: String
dexp = BuildOpts b v n
bopts forall s a. s -> Getting a s a -> a
^. forall b (v :: * -> *) n. Lens' (BuildOpts b v n) String
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.
    QDiagram b v n Any
d <- forall (m :: * -> *) a.
(MonadInterpreter m, Typeable a) =>
String -> a -> m a
interpret String
dexp (forall a. Typeable a => a
as :: QDiagram b v n Any) forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAll` forall a b. a -> b -> a
const (forall (m :: * -> *) a.
(MonadInterpreter m, Typeable a) =>
String -> a -> m a
interpret String
dexp (forall a. Typeable a => a
as :: IO (QDiagram b v n Any)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO)

    -- Finally, call renderDia.
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b (v :: * -> *) n m.
(Backend b v n, HasLinearMap v, Metric v, Typeable n,
 OrderedField n, Monoid' m) =>
b -> Options b v n -> QDiagram b v n m -> Result b v n
renderDia (forall b (v :: * -> *) n. BuildOpts b v n -> b
backendToken BuildOpts b v n
bopts) (BuildOpts b v n
bopts forall s a. s -> Getting a s a -> a
^. forall b (v :: * -> *) n. Lens' (BuildOpts b v n) (Options b v n)
backendOpts) ((BuildOpts b v n
bopts forall s a. s -> Getting a s a -> a
^. forall b (v :: * -> *) n.
Lens' (BuildOpts b v n) (QDiagram b v n Any -> QDiagram b v n Any)
postProcess) QDiagram b v n Any
d)

-- | Pretty-print an @InterpreterError@.
ppInterpError :: InterpreterError -> String
ppInterpError :: InterpreterError -> String
ppInterpError (UnknownError String
err) = String
"UnknownError: " forall a. [a] -> [a] -> [a]
++ String
err
ppInterpError (WontCompile  [GhcError]
es)  = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map GhcError -> String
errMsg forall a b. (a -> b) -> a -> b
$ [GhcError]
es
ppInterpError (NotAllowed   String
err) = String
"NotAllowed: "   forall a. [a] -> [a] -> [a]
++ String
err
ppInterpError (GhcException String
err) = String
"GhcException: " forall a. [a] -> [a] -> [a]
++ String
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 :: forall b (v :: * -> *) n.
(Typeable b, Data (v n), Data n, Metric v, HasLinearMap v,
 Typeable v, OrderedField n, Backend b v n,
 Hashable (Options b v n)) =>
BuildOpts b v n -> IO (BuildResult b v n)
buildDiagram BuildOpts b v n
bopts = do
  let bopts' :: BuildOpts b v n
bopts' = BuildOpts b v n
bopts
             forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [String]
snippets forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a b. (a -> b) -> [a] -> [b]
map String -> String
unLit
             forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [String]
pragmas  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([String
"NoMonomorphismRestriction", String
"TypeFamilies", String
"FlexibleContexts"] forall a. [a] -> [a] -> [a]
++)
             forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n. Lens' (BuildOpts b v n) [String]
imports  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (String
"Diagrams.Prelude" forall a. a -> [a] -> [a]
:)
  case forall b (v :: * -> *) n.
Maybe String -> BuildOpts b v n -> Either String Module
createModule forall a. Maybe a
Nothing BuildOpts b v n
bopts' of
    Left  String
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b (v :: * -> *) n. String -> BuildResult b v n
ParseErr String
err)
    Right m :: Module
m@(Module Maybe ModuleHead
_ [ModulePragma]
_ [ImportDecl]
srcImps [Decl]
_) -> do
      Hash
liHash <- [ImportDecl] -> IO Hash
hashLocalImports [ImportDecl]
srcImps
      let diaHash :: Hash
diaHash
            = Hash
0 forall a. Hashable a => Hash -> a -> Hash
`hashWithSalt` forall a. Pretty a => a -> String
prettyPrint Module
m
                forall a. Hashable a => Hash -> a -> Hash
`hashWithSalt` (BuildOpts b v n
bopts forall s a. s -> Getting a s a -> a
^. forall b (v :: * -> *) n. Lens' (BuildOpts b v n) String
diaExpr)
                forall a. Hashable a => Hash -> a -> Hash
`hashWithSalt` (BuildOpts b v n
bopts forall s a. s -> Getting a s a -> a
^. forall b (v :: * -> *) n. Lens' (BuildOpts b v n) (Options b v n)
backendOpts)
                forall a. Hashable a => Hash -> a -> Hash
`hashWithSalt` Hash
liHash
      Maybe (Options b v n -> Options b v n)
regen    <- (BuildOpts b v n
bopts forall s a. s -> Getting a s a -> a
^. forall b (v :: * -> *) n.
Lens'
  (BuildOpts b v n)
  (Hash -> IO (Maybe (Options b v n -> Options b v n)))
decideRegen) Hash
diaHash
      case Maybe (Options b v n -> Options b v n)
regen of
        Maybe (Options b v n -> Options b v n)
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b (v :: * -> *) n. Hash -> BuildResult b v n
Skipped Hash
diaHash
        Just Options b v n -> Options b v n
upd -> do
          String
tmpDir   <- IO String
getTemporaryDirectory
          (String
tmp, Handle
h) <- String -> String -> IO (String, Handle)
openTempFile String
tmpDir String
"Diagram.hs"
          let m' :: Module
m' = String -> Module -> Module
replaceModuleName (forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
isAlphaNum forall a b. (a -> b) -> a -> b
$ String -> String
takeBaseName String
tmp) Module
m
          Handle -> String -> IO ()
hPutStr Handle
h (forall a. Pretty a => a -> String
prettyPrint Module
m')
          Handle -> IO ()
hClose Handle
h

          Either InterpreterError (Result b v n)
compilation <- forall b (v :: * -> *) n.
(Typeable b, Typeable v, HasLinearMap v, Data (v n), Data n,
 Metric v, OrderedField n, Backend b v n) =>
BuildOpts b v n
-> String -> IO (Either InterpreterError (Result b v n))
interpretDiagram (BuildOpts b v n
bopts' forall a b. a -> (a -> b) -> b
& forall b (v :: * -> *) n. Lens' (BuildOpts b v n) (Options b v n)
backendOpts forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Options b v n -> Options b v n
upd) String
tmp
          String -> IO ()
removeFile String
tmp
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall b (v :: * -> *) n. InterpreterError -> BuildResult b v n
InterpErr (forall b (v :: * -> *) n. Hash -> Result b v n -> BuildResult b v n
OK Hash
diaHash) Either InterpreterError (Result b v n)
compilation
    Right Module
m -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Diagrams.Builder.buildDiagram: weird module " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Module
m

-- | 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 :: [ImportDecl] -> IO Hash
hashLocalImports
  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Hashable a => Hash -> a -> Hash
hashWithSalt Hash
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO (Maybe String)
getLocalSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 String -> String -> String
(</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> String
getModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImportDecl -> ModuleName
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 :: String -> IO (Maybe String)
getLocalSource String
f = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
  String
contents <- String -> MaybeT IO String
getLocal String
f
  case (String -> Either String Module
doModuleParse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
unLit) String
contents of
    Left String
_  -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
    Right Module
m -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Pretty a => a -> String
prettyPrint Module
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 :: String -> MaybeT IO String
getLocal String
m = String -> MaybeT IO String
tryExt String
"hs" forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` String -> MaybeT IO String
tryExt String
"lhs"
  where
    tryExt :: String -> MaybeT IO String
tryExt String
ext = do
      let f :: String
f = String
m String -> String -> String
<.> String
ext
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO Bool
doesFileExist String
f) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO String
readFile String
f)