module Diagrams.Util
(
with
, applyAll
, (#)
, (##)
, iterateN
, tau
, findHsFile
, findSandbox
, globalPackage
, 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.List.Lens
import Data.Maybe
import Data.Monoid
import System.Directory
import System.Environment
import System.FilePath
import System.FilePath.Lens
import System.Process
with :: Default d => d
with :: d
with = d
forall a. Default a => a
def
applyAll :: [a -> a] -> a -> a
applyAll :: [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 #
(#) :: a -> (a -> b) -> 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
($)
(##) :: AReview t b -> b -> t
## :: 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 :: Int -> (a -> a) -> a -> [a]
iterateN :: 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
tau :: Floating a => a
tau :: a
tau = a
2a -> a -> a
forall a. Num a => a -> a -> a
*a
forall a. Floating a => a
pi
foldB :: (a -> a -> a) -> a -> [a] -> a
foldB :: (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
findHsFile :: FilePath -> IO (Maybe FilePath)
findHsFile :: FilePath -> IO (Maybe FilePath)
findHsFile FilePath
file = MaybeT IO FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO FilePath -> IO (Maybe FilePath))
-> MaybeT IO FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ MaybeT IO FilePath
hs MaybeT IO FilePath -> MaybeT IO FilePath -> MaybeT IO FilePath
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO FilePath
lhs
where
hs :: MaybeT IO FilePath
hs = FilePath -> MaybeT IO FilePath
forall (t :: (* -> *) -> * -> *).
(Monad (t IO), MonadTrans t, Alternative (t IO)) =>
FilePath -> t IO FilePath
check (FilePath -> FilePath -> FilePath
addExtension FilePath
file FilePath
"hs")
lhs :: MaybeT IO FilePath
lhs = FilePath -> MaybeT IO FilePath
forall (t :: (* -> *) -> * -> *).
(Monad (t IO), MonadTrans t, Alternative (t IO)) =>
FilePath -> t IO FilePath
check (FilePath -> FilePath -> FilePath
addExtension FilePath
file FilePath
"lhs")
check :: FilePath -> t IO FilePath
check FilePath
f = do
IO Bool -> t IO Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (FilePath -> IO Bool
doesFileExist FilePath
f) t IO Bool -> (Bool -> t IO ()) -> t IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> t IO ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard
FilePath -> t IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
f
parseConfig :: FilePath -> MaybeT IO FilePath
parseConfig :: FilePath -> MaybeT IO FilePath
parseConfig FilePath
file = do
FilePath
config <- IO FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
IO a -> MaybeT m a
maybeIO (IO FilePath -> MaybeT IO FilePath)
-> IO FilePath -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readFile FilePath
file
Maybe FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe (Maybe FilePath -> MaybeT IO FilePath)
-> Maybe FilePath -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
config FilePath
-> Getting (First FilePath) FilePath FilePath -> Maybe FilePath
forall s a. s -> Getting (First a) s a -> Maybe a
^? Getting (First FilePath) FilePath FilePath
forall (f :: * -> *).
Applicative f =>
IndexedLensLike' Int f FilePath FilePath
lined Getting (First FilePath) FilePath FilePath
-> Getting (First FilePath) FilePath FilePath
-> Getting (First FilePath) FilePath FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Prism' FilePath FilePath
forall t. Prefixed t => t -> Prism' t t
prefixed FilePath
"package-db: "
configSearch :: FilePath -> MaybeT IO FilePath
configSearch :: FilePath -> MaybeT IO FilePath
configSearch FilePath
p0 = do
FilePath
p0' <- IO FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
IO a -> MaybeT m a
maybeIO (IO FilePath -> MaybeT IO FilePath)
-> IO FilePath -> MaybeT IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
canonicalizePath FilePath
p0
let mkPaths :: FilePath -> [FilePath]
mkPaths FilePath
p
| (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isPathSeparator FilePath
p Bool -> Bool -> Bool
|| FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"."
= []
| Bool
otherwise = (FilePath
p FilePath -> FilePath -> FilePath
</> FilePath
"cabal.sandbox.config")
FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath -> [FilePath]
mkPaths (FilePath
p FilePath -> Getting FilePath FilePath FilePath -> FilePath
forall s a. s -> Getting a s a -> a
^. Getting FilePath FilePath FilePath
Lens' FilePath FilePath
directory)
(FilePath -> MaybeT IO FilePath)
-> [FilePath] -> MaybeT IO FilePath
forall (m :: * -> *) a b.
Monad m =>
(a -> MaybeT m b) -> [a] -> MaybeT m b
foldMaybeT FilePath -> MaybeT IO FilePath
parseConfig (FilePath -> [FilePath]
mkPaths FilePath
p0')
isDB :: FilePath -> MaybeT IO FilePath
isDB :: FilePath -> MaybeT IO FilePath
isDB FilePath
path =
if FilePath -> Bool
isConf FilePath
path
then FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path
else IO [FilePath] -> MaybeT IO [FilePath]
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
IO a -> MaybeT m a
maybeIO (FilePath -> IO [FilePath]
getDirectoryContents FilePath
path) MaybeT IO [FilePath]
-> ([FilePath] -> MaybeT IO FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a. Monad m => Maybe a -> MaybeT m a
hoistMaybe (Maybe FilePath -> MaybeT IO FilePath)
-> ([FilePath] -> Maybe FilePath)
-> [FilePath]
-> MaybeT IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Bool) -> [FilePath] -> Maybe FilePath
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find FilePath -> Bool
isConf
where
isConf :: FilePath -> Bool
isConf = FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf FilePath
".conf.d"
findSandbox :: [FilePath] -> IO (Maybe FilePath)
findSandbox :: [FilePath] -> IO (Maybe FilePath)
findSandbox [FilePath]
paths = MaybeT IO FilePath -> IO (Maybe FilePath)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO FilePath -> IO (Maybe FilePath))
-> MaybeT IO FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ MaybeT IO FilePath
pathsTest MaybeT IO FilePath -> MaybeT IO FilePath -> MaybeT IO FilePath
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO FilePath
diaSB MaybeT IO FilePath -> MaybeT IO FilePath -> MaybeT IO FilePath
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO FilePath
envDB MaybeT IO FilePath -> MaybeT IO FilePath -> MaybeT IO FilePath
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MaybeT IO FilePath
wdConfig
where
lookEnv :: FilePath -> MaybeT IO FilePath
lookEnv = IO (Maybe FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe FilePath) -> MaybeT IO FilePath)
-> (FilePath -> IO (Maybe FilePath))
-> FilePath
-> MaybeT IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe FilePath -> Maybe FilePath)
-> IO (Maybe FilePath) -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe FilePath -> Maybe FilePath)
-> IO (Maybe FilePath) -> IO (Maybe FilePath))
-> ((FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath)
-> (FilePath -> FilePath)
-> IO (Maybe FilePath)
-> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ([FilePath] -> FilePath
forall a. [a] -> a
head ([FilePath] -> FilePath)
-> (FilePath -> [FilePath]) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
splitSearchPath) (IO (Maybe FilePath) -> IO (Maybe FilePath))
-> (FilePath -> IO (Maybe FilePath))
-> FilePath
-> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Maybe FilePath)
lookupEnv
envDB :: MaybeT IO FilePath
envDB = (FilePath -> MaybeT IO FilePath)
-> [FilePath] -> MaybeT IO FilePath
forall (m :: * -> *) a b.
Monad m =>
(a -> MaybeT m b) -> [a] -> MaybeT m b
foldMaybeT FilePath -> MaybeT IO FilePath
lookEnv [FilePath
"GHC_PACKAGE_PATH", FilePath
"HSENV", FilePath
"PACKAGE_DB_FOR_GHC"]
test :: FilePath -> MaybeT IO FilePath
test FilePath
x = FilePath -> MaybeT IO FilePath
isDB FilePath
x MaybeT IO FilePath -> MaybeT IO FilePath -> MaybeT IO FilePath
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FilePath -> MaybeT IO FilePath
configSearch FilePath
x
pathsTest :: MaybeT IO FilePath
pathsTest = (FilePath -> MaybeT IO FilePath)
-> [FilePath] -> MaybeT IO FilePath
forall (m :: * -> *) a b.
Monad m =>
(a -> MaybeT m b) -> [a] -> MaybeT m b
foldMaybeT FilePath -> MaybeT IO FilePath
test [FilePath]
paths
diaSB :: MaybeT IO FilePath
diaSB = FilePath -> MaybeT IO FilePath
lookEnv FilePath
"DIAGRAMS_SANDBOX" MaybeT IO FilePath
-> (FilePath -> MaybeT IO FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> MaybeT IO FilePath
test
wdConfig :: MaybeT IO FilePath
wdConfig = IO FilePath -> MaybeT IO FilePath
forall (m :: * -> *) a.
(MonadCatch m, MonadIO m) =>
IO a -> MaybeT m a
maybeIO IO FilePath
getCurrentDirectory MaybeT IO FilePath
-> (FilePath -> MaybeT IO FilePath) -> MaybeT IO FilePath
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> MaybeT IO FilePath
configSearch
globalPackage :: IO FilePath
globalPackage :: IO FilePath
globalPackage = do
[(FilePath, FilePath)]
info <- FilePath -> [(FilePath, FilePath)]
forall a. Read a => FilePath -> a
read (FilePath -> [(FilePath, FilePath)])
-> IO FilePath -> IO [(FilePath, FilePath)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"ghc" [FilePath
"--info"] FilePath
""
FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error FilePath
"Unable to parse ghc --info.")
(FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"Global Package DB" [(FilePath, FilePath)]
info)
maybeIO :: (MonadCatch m, MonadIO m) => IO a -> MaybeT m a
maybeIO :: IO a -> MaybeT m a
maybeIO IO a
io = 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.
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 (m :: * -> *) a. MonadPlus m => m a
mzero
hoistMaybe :: Monad m => Maybe a -> MaybeT m a
hoistMaybe :: Maybe a -> MaybeT m a
hoistMaybe = m (Maybe a) -> MaybeT m a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe a) -> MaybeT m a)
-> (Maybe a -> m (Maybe a)) -> Maybe a -> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return
foldMaybeT :: Monad m => (a -> MaybeT m b) -> [a] -> MaybeT m b
foldMaybeT :: (a -> MaybeT m b) -> [a] -> MaybeT m b
foldMaybeT a -> MaybeT m b
_ [] = MaybeT m b
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 (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)