content: {-# 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
  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 = 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 = appEndo . mconcat . map 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
  (#) = flip ($)
  
  -- | A replacement for lenses' 'Control.Lens.Review.#' operator.
  (##) :: AReview t b -> b -> 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 n f = take n . iterate 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 = 2*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 _ z [] = z
  foldB f _ as = foldB' as
    where foldB' [x] = x
          foldB' xs  = foldB' (go xs)
          go []         = []
          go [x]        = [x]
          go (x1:x2:xs) = f x1 x2 : go xs
  
  ------------------------------------------------------------------------
  -- Files
  ------------------------------------------------------------------------
  
  -- | Given some file (no extension or otherwise) try to find a haskell
  --   source file.
  findHsFile :: FilePath -> IO (Maybe FilePath)
  findHsFile file = runMaybeT $ hs <|> lhs
    where
      hs      = check (addExtension file "hs")
      lhs     = check (addExtension file "lhs")
      check f = do
        lift (doesFileExist f) >>= guard
        pure f
  
  ------------------------------------------------------------------------
  -- Sandbox
  ------------------------------------------------------------------------
  
  -- | Parse cabal config file to find the location of the package
  --   database.
  parseConfig :: FilePath -> MaybeT IO FilePath
  parseConfig file = do
    config <- maybeIO $ readFile file
    hoistMaybe $ config ^? lined . prefixed "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 p0 = do
    p0' <- maybeIO $ canonicalizePath p0
  
    let mkPaths p
          | all isPathSeparator p || p == "."
                      = []
          | otherwise = (p </> "cabal.sandbox.config")
                      : mkPaths (p ^. directory)
  
    foldMaybeT parseConfig (mkPaths 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 path =
    if isConf path
      then return path
      else maybeIO (getDirectoryContents path) >>= hoistMaybe . find isConf
      where
        isConf = isSuffixOf ".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 paths = runMaybeT $ pathsTest <|> diaSB <|> envDB <|> wdConfig
    where
      -- first path in environment
      lookEnv = MaybeT . (fmap . fmap) (head . splitSearchPath) . lookupEnv
      envDB   = foldMaybeT lookEnv ["GHC_PACKAGE_PATH", "HSENV", "PACKAGE_DB_FOR_GHC"]
  
      -- test if path points directly to db or contains a config file
      test x    = isDB x <|> configSearch x
      pathsTest = foldMaybeT test paths
      diaSB     = lookEnv "DIAGRAMS_SANDBOX" >>= test
      wdConfig  = maybeIO getCurrentDirectory >>= 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 = do
    info <- read <$> readProcess "ghc" ["--info"] ""
    return $ fromMaybe (error "Unable to parse ghc --info.")
                       (lookup "Global Package DB" 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 io = liftIO io `catchAll` const 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 _ []     = mzero
  foldMaybeT f (a:as) = MaybeT $ do
    x <- runMaybeT (f a)
    if isJust x
      then return x
      else runMaybeT (foldMaybeT f as)
  
  