{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Util
-- Copyright   :  (c) 2011-2015 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Some miscellaneous utilities provided by the diagrams-lib package.
--
-----------------------------------------------------------------------------

module Diagrams.Util
  ( -- * Utilities for users

    with
  , applyAll
  , (#)
  , (##)

  , iterateN

  , tau

    -- * Finding files
  , findHsFile

    -- * Finding sandboxes
  , findSandbox
  , globalPackage

    -- * Internal utilities
  , foldB

  ) where

import           Control.Applicative
import           Control.Lens              hiding (( # ))
import           Control.Monad
import           Control.Monad.Catch
import           Control.Monad.Trans
import           Control.Monad.Trans.Maybe
import           Data.Default.Class
import           Data.List
import           Data.Maybe
import           Data.Monoid
import           System.Directory
import           System.Environment
import           System.FilePath
import           System.FilePath.Lens
import           System.Process

-- | Several functions exported by the diagrams library take a number
--   of arguments giving the user control to \"tweak\" various aspects
--   of their behavior.  Rather than give such functions a long list
--   of arguments, and to make it possible for the user to selectively
--   override only certain arguments and use default values for
--   others, such sets of arguments are collected into a record with
--   named fields (see 'PolygonOpts' in "Diagrams.TwoD.Shapes" for an
--   example).  Such record types are made instances of the 'Default'
--   class, which provides a single record structure ('def')
--   collecting the \"default\" arguments to the function.  @with@ is
--   a synonym for 'def', which provides nice-looking syntax for
--   simulating optional, named arguments in Haskell.  For example,
--
--   @
--   polygon with {sides = 7, edgeSkip = 2}
--   @
--
--   calls the 'polygon' function with a single argument (note that
--   record update binds more tightly than function application!),
--   namely, 'with' (the record of default arguments) where the
--   @sides@ and @edgeSkip@ fields have been updated.
with :: Default d => d
with :: forall d. Default d => d
with = d
forall d. Default d => d
def

-- | @applyAll@ takes a list of functions and applies them all to a
--   value, in sequence from the last function in the list to the first.
--   For example, @applyAll [f1, f2, f3] a == f1 . f2 . f3 $ a@.
applyAll :: [a -> a] -> a -> a
applyAll :: forall a. [a -> a] -> a -> a
applyAll = Endo a -> a -> a
forall a. Endo a -> a -> a
appEndo (Endo a -> a -> a) -> ([a -> a] -> Endo a) -> [a -> a] -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Endo a] -> Endo a
forall a. Monoid a => [a] -> a
mconcat ([Endo a] -> Endo a)
-> ([a -> a] -> [Endo a]) -> [a -> a] -> Endo a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> a) -> Endo a) -> [a -> a] -> [Endo a]
forall a b. (a -> b) -> [a] -> [b]
map (a -> a) -> Endo a
forall a. (a -> a) -> Endo a
Endo

infixl 8 #

-- | Postfix function application, for conveniently applying
--   attributes.  Unlike @($)@, @(#)@ has a high precedence (8), so @d
--   \# foo \# bar@ can be combined with other things using operators
--   like @(|||)@ or @(\<\>)@ without needing parentheses.
(#) :: a -> (a -> b) -> b
# :: forall a b. a -> (a -> b) -> b
(#) = ((a -> b) -> a -> b) -> a -> (a -> b) -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)

-- | A replacement for lenses' 'Control.Lens.Review.#' operator.
(##) :: AReview t b -> b -> t
## :: forall t b. AReview t b -> b -> t
(##) = AReview t b -> b -> t
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review
{-# INLINE (##) #-}
infixr 8 ##


-- | @iterateN n f x@ returns the list of the first @n@ iterates of
--   @f@ starting at @x@, that is, the list @[x, f x, f (f x), ...]@
--   of length @n@. (Note that the last element of the list will be
--   @f@ applied to @x@ @(n-1)@ times.)
iterateN :: Int -> (a -> a) -> a -> [a]
iterateN :: forall a. Int -> (a -> a) -> a -> [a]
iterateN Int
n a -> a
f = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n ([a] -> [a]) -> (a -> [a]) -> a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> a -> [a]
forall a. (a -> a) -> a -> [a]
iterate a -> a
f

-- | The circle constant, the ratio of a circle's circumference to its
--   /radius/.  Note that @pi = tau/2@.
--
--   For more information and a well-reasoned argument why we should
--   all be using tau instead of pi, see /The Tau Manifesto/,
--   <http://tauday.com/>.
--
--   To hear what it sounds like (and to easily memorize the first 30
--   digits or so), try <http://youtu.be/3174T-3-59Q>.
tau :: Floating a => a
tau :: forall a. Floating a => a
tau = a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
forall a. Floating a => a
pi

-- | Given an associative binary operation and a default value to use
--   in the case of an empty list, perform a /balanced/ fold over a
--   list.  For example,
--
--   @
--   foldB (+) z [a,b,c,d,e,f] == ((a+b) + (c+d)) + (e+f)
--   @
--
foldB :: (a -> a -> a) -> a -> [a] -> a
foldB :: forall a. (a -> a -> a) -> a -> [a] -> a
foldB a -> a -> a
_ a
z [] = a
z
foldB a -> a -> a
f a
_ [a]
as = [a] -> a
foldB' [a]
as
  where foldB' :: [a] -> a
foldB' [a
x] = a
x
        foldB' [a]
xs  = [a] -> a
foldB' ([a] -> [a]
go [a]
xs)
        go :: [a] -> [a]
go []         = []
        go [a
x]        = [a
x]
        go (a
x1:a
x2:[a]
xs) = a -> a -> a
f a
x1 a
x2 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
go [a]
xs

------------------------------------------------------------------------
-- Files
------------------------------------------------------------------------

-- | Given some file (no extension or otherwise) try to find a haskell
--   source file.
findHsFile :: FilePath -> IO (Maybe FilePath)
findHsFile :: String -> IO (Maybe String)
findHsFile String
file = MaybeT IO String -> IO (Maybe String)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO String -> IO (Maybe String))
-> MaybeT IO String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ MaybeT IO String
hs MaybeT IO String -> MaybeT IO String -> MaybeT IO String
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO String
lhs
  where
    hs :: MaybeT IO String
hs      = String -> MaybeT IO String
forall {t :: (* -> *) -> * -> *}.
(Monad (t IO), MonadTrans t, Alternative (t IO)) =>
String -> t IO String
check (String -> String -> String
addExtension String
file String
"hs")
    lhs :: MaybeT IO String
lhs     = String -> MaybeT IO String
forall {t :: (* -> *) -> * -> *}.
(Monad (t IO), MonadTrans t, Alternative (t IO)) =>
String -> t IO String
check (String -> String -> String
addExtension String
file String
"lhs")
    check :: String -> t IO String
check String
f = do
      IO Bool -> t IO Bool
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> IO Bool
doesFileExist String
f) t IO Bool -> (Bool -> t IO ()) -> t IO ()
forall a b. t IO a -> (a -> t IO b) -> t IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> t IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
      String -> t IO String
forall a. a -> t IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
f

------------------------------------------------------------------------
-- Sandbox
------------------------------------------------------------------------

-- | Parse cabal config file to find the location of the package
--   database.
parseConfig :: FilePath -> MaybeT IO FilePath
parseConfig :: String -> MaybeT IO String
parseConfig String
file = do
  String
config <- IO String -> MaybeT IO String
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
IO a -> MaybeT m a
maybeIO (IO String -> MaybeT IO String) -> IO String -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
file
  Maybe String -> MaybeT IO String
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe (Maybe String -> MaybeT IO String)
-> Maybe String -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ String
config String -> Getting (First String) String String -> Maybe String
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First String) String String
forall (f :: * -> *).
Applicative f =>
IndexedLensLike' Int f String String
IndexedLensLike' Int (Const (First String)) String String
lined Getting (First String) String String
-> Getting (First String) String String
-> Getting (First String) String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Prism' String String
forall t. Prefixed t => t -> Prism' t t
prefixed String
"package-db: "

-- | Seach the given directory and all parent directories until a cabal
--   config file is found. First search for \"cabal.config\", then
--   \"cabal.sandbox.config\". Return the location of the package
--   database in the config file.
configSearch :: FilePath -> MaybeT IO FilePath
configSearch :: String -> MaybeT IO String
configSearch String
p0 = do
  String
p0' <- IO String -> MaybeT IO String
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
IO a -> MaybeT m a
maybeIO (IO String -> MaybeT IO String) -> IO String -> MaybeT IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
canonicalizePath String
p0

  let mkPaths :: String -> [String]
mkPaths String
p
        | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isPathSeparator String
p Bool -> Bool -> Bool
|| String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"."
                    = []
        | Bool
otherwise = (String
p String -> String -> String
</> String
"cabal.sandbox.config")
                    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
mkPaths (String
p String -> Getting String String String -> String
forall s a. s -> Getting a s a -> a
^. Getting String String String
Lens' String String
directory)

  (String -> MaybeT IO String) -> [String] -> MaybeT IO String
forall (m :: * -> *) a b.
Monad m =>
(a -> MaybeT m b) -> [a] -> MaybeT m b
foldMaybeT String -> MaybeT IO String
parseConfig (String -> [String]
mkPaths String
p0')

-- | Check if the folder is a database, or if it contains a database.
--   Returns the database location if it's found.
isDB :: FilePath -> MaybeT IO FilePath
isDB :: String -> MaybeT IO String
isDB String
path =
  if String -> Bool
isConf String
path
    then String -> MaybeT IO String
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
    else IO [String] -> MaybeT IO [String]
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
IO a -> MaybeT m a
maybeIO (String -> IO [String]
getDirectoryContents String
path) MaybeT IO [String]
-> ([String] -> MaybeT IO String) -> MaybeT IO String
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe String -> MaybeT IO String
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe (Maybe String -> MaybeT IO String)
-> ([String] -> Maybe String) -> [String] -> MaybeT IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find String -> Bool
isConf
    where
      isConf :: String -> Bool
isConf = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
".conf.d"

-- | Search for a sandbox in the following order:
--
--   * Test given FilePaths if they point directly to a database or
--     contain a cabal config file (or any parent directory containing a
--     config file).
--
--   * Same test for @DIAGRAMS_SANDBOX@ environment value
--
--   * Environment values of @GHC_PACKAGE_PATH@, @HSENV@ and
--     @PACKAGE_DB_FOR_GHC@ that point to a database.
--
--   * Test for config file (cabal.sandbox.config) in the current
--     directory and its parents.
--
findSandbox :: [FilePath] -> IO (Maybe FilePath)
findSandbox :: [String] -> IO (Maybe String)
findSandbox [String]
paths = MaybeT IO String -> IO (Maybe String)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO String -> IO (Maybe String))
-> MaybeT IO String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ MaybeT IO String
pathsTest MaybeT IO String -> MaybeT IO String -> MaybeT IO String
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO String
diaSB MaybeT IO String -> MaybeT IO String -> MaybeT IO String
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO String
envDB MaybeT IO String -> MaybeT IO String -> MaybeT IO String
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO String
wdConfig
  where
    -- first path in environment
    lookEnv :: String -> MaybeT IO String
lookEnv = IO (Maybe String) -> MaybeT IO String
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe String) -> MaybeT IO String)
-> (String -> IO (Maybe String)) -> String -> MaybeT IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe String -> Maybe String)
-> IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe String -> Maybe String)
 -> IO (Maybe String) -> IO (Maybe String))
-> ((String -> String) -> Maybe String -> Maybe String)
-> (String -> String)
-> IO (Maybe String)
-> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ([String] -> String
forall a. HasCallStack => [a] -> a
head ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitSearchPath) (IO (Maybe String) -> IO (Maybe String))
-> (String -> IO (Maybe String)) -> String -> IO (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe String)
lookupEnv
    envDB :: MaybeT IO String
envDB   = (String -> MaybeT IO String) -> [String] -> MaybeT IO String
forall (m :: * -> *) a b.
Monad m =>
(a -> MaybeT m b) -> [a] -> MaybeT m b
foldMaybeT String -> MaybeT IO String
lookEnv [String
"GHC_PACKAGE_PATH", String
"HSENV", String
"PACKAGE_DB_FOR_GHC"]

    -- test if path points directly to db or contains a config file
    test :: String -> MaybeT IO String
test String
x    = String -> MaybeT IO String
isDB String
x MaybeT IO String -> MaybeT IO String -> MaybeT IO String
forall a. MaybeT IO a -> MaybeT IO a -> MaybeT IO a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> MaybeT IO String
configSearch String
x
    pathsTest :: MaybeT IO String
pathsTest = (String -> MaybeT IO String) -> [String] -> MaybeT IO String
forall (m :: * -> *) a b.
Monad m =>
(a -> MaybeT m b) -> [a] -> MaybeT m b
foldMaybeT String -> MaybeT IO String
test [String]
paths
    diaSB :: MaybeT IO String
diaSB     = String -> MaybeT IO String
lookEnv String
"DIAGRAMS_SANDBOX" MaybeT IO String
-> (String -> MaybeT IO String) -> MaybeT IO String
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> MaybeT IO String
test
    wdConfig :: MaybeT IO String
wdConfig  = IO String -> MaybeT IO String
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
IO a -> MaybeT m a
maybeIO IO String
getCurrentDirectory MaybeT IO String
-> (String -> MaybeT IO String) -> MaybeT IO String
forall a b. MaybeT IO a -> (a -> MaybeT IO b) -> MaybeT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> MaybeT IO String
configSearch

-- -- | Use the given path for the sandbox in the @GHC_PACKAGE_PATH@
-- --   environment (appending the ghc global package database from @ghc
-- --   --info@. @GHC_PACKAGE_PATH@ if the variable ghc and other tools use
-- --   to find the package database. (This is what @cabal exec@ sets)
-- ghcPackagePath :: FilePath -> IO ()
-- ghcPackagePath db = do
--   gdb <- globalPackage
--   let dbs = intercalate [searchPathSeparator] [db,gdb]
--   setEnv "GHC_PACKAGE_PATH" dbs
-- -- setEnv is only in base > 4.7, either need to use setenv package or
-- -- -package-db flag

-- | Find ghc's global package database. Throws an error if it isn't
--   found.
globalPackage :: IO FilePath
globalPackage :: IO String
globalPackage = do
  [(String, String)]
info <- String -> [(String, String)]
forall a. Read a => String -> a
read (String -> [(String, String)])
-> IO String -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"ghc" [String
"--info"] String
""
  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> String
forall a. HasCallStack => String -> a
error String
"Unable to parse ghc --info.")
                     (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Global Package DB" [(String, String)]
info)

-- MaybeT utilities

-- | Lift an 'IO' action. If any exceptions are raised, return Nothing.
maybeIO :: (MonadCatch m, MonadIO m) => IO a -> MaybeT m a
maybeIO :: forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
IO a -> MaybeT m a
maybeIO IO a
io = IO a -> MaybeT m a
forall a. IO a -> MaybeT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io MaybeT m a -> (SomeException -> MaybeT m a) -> MaybeT m a
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAll` MaybeT m a -> SomeException -> MaybeT m a
forall a b. a -> b -> a
const MaybeT m a
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- hoistMaybe is exported from transformers as of version 0.6
#if MIN_VERSION_transformers(0,6,0)
#else
-- | Lift a maybe value to a MaybeT of any monad.
hoistMaybe :: Monad m => Maybe a -> MaybeT m a
hoistMaybe = MaybeT . return
#endif

-- | Fold a list of 'MaybeT's that short-circuits as soon as a Just value
--   is found (instead going through the whole list).
foldMaybeT :: Monad m => (a -> MaybeT m b) -> [a] -> MaybeT m b
foldMaybeT :: forall (m :: * -> *) a b.
Monad m =>
(a -> MaybeT m b) -> [a] -> MaybeT m b
foldMaybeT a -> MaybeT m b
_ []     = MaybeT m b
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
foldMaybeT a -> MaybeT m b
f (a
a:[a]
as) = m (Maybe b) -> MaybeT m b
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe b) -> MaybeT m b) -> m (Maybe b) -> MaybeT m b
forall a b. (a -> b) -> a -> b
$ do
  Maybe b
x <- MaybeT m b -> m (Maybe b)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (a -> MaybeT m b
f a
a)
  if Maybe b -> Bool
forall a. Maybe a -> Bool
isJust Maybe b
x
    then Maybe b -> m (Maybe b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
x
    else MaybeT m b -> m (Maybe b)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT ((a -> MaybeT m b) -> [a] -> MaybeT m b
forall (m :: * -> *) a b.
Monad m =>
(a -> MaybeT m b) -> [a] -> MaybeT m b
foldMaybeT a -> MaybeT m b
f [a]
as)