{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Hie.Locate
  ( nestedPkg,
    stackYamlPkgs,
    cabalPkgs,
  )
where

import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Data.Attoparsec.Text (parseOnly)
import Data.Either
import Data.List
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Yaml
import Hie.Cabal.Parser
import System.Directory
import System.FilePath.Posix
import System.FilePattern.Directory (getDirectoryFiles)

newtype Pkgs = Pkgs [FilePath]
  deriving (Pkgs -> Pkgs -> Bool
(Pkgs -> Pkgs -> Bool) -> (Pkgs -> Pkgs -> Bool) -> Eq Pkgs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pkgs -> Pkgs -> Bool
$c/= :: Pkgs -> Pkgs -> Bool
== :: Pkgs -> Pkgs -> Bool
$c== :: Pkgs -> Pkgs -> Bool
Eq, Eq Pkgs
Eq Pkgs
-> (Pkgs -> Pkgs -> Ordering)
-> (Pkgs -> Pkgs -> Bool)
-> (Pkgs -> Pkgs -> Bool)
-> (Pkgs -> Pkgs -> Bool)
-> (Pkgs -> Pkgs -> Bool)
-> (Pkgs -> Pkgs -> Pkgs)
-> (Pkgs -> Pkgs -> Pkgs)
-> Ord Pkgs
Pkgs -> Pkgs -> Bool
Pkgs -> Pkgs -> Ordering
Pkgs -> Pkgs -> Pkgs
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Pkgs -> Pkgs -> Pkgs
$cmin :: Pkgs -> Pkgs -> Pkgs
max :: Pkgs -> Pkgs -> Pkgs
$cmax :: Pkgs -> Pkgs -> Pkgs
>= :: Pkgs -> Pkgs -> Bool
$c>= :: Pkgs -> Pkgs -> Bool
> :: Pkgs -> Pkgs -> Bool
$c> :: Pkgs -> Pkgs -> Bool
<= :: Pkgs -> Pkgs -> Bool
$c<= :: Pkgs -> Pkgs -> Bool
< :: Pkgs -> Pkgs -> Bool
$c< :: Pkgs -> Pkgs -> Bool
compare :: Pkgs -> Pkgs -> Ordering
$ccompare :: Pkgs -> Pkgs -> Ordering
$cp1Ord :: Eq Pkgs
Ord)

instance FromJSON Pkgs where
  parseJSON :: Value -> Parser Pkgs
parseJSON (Object Object
v) = [FilePath] -> Pkgs
Pkgs ([FilePath] -> Pkgs) -> Parser [FilePath] -> Parser Pkgs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser (Maybe [FilePath])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"packages" Parser (Maybe [FilePath]) -> [FilePath] -> Parser [FilePath]
forall a. Parser (Maybe a) -> a -> Parser a
.!= [FilePath
"."]
  parseJSON Value
_ = FilePath -> Parser Pkgs
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"could not read packages from stack.yaml"

stackYamlPkgs :: FilePath -> MaybeT IO [FilePath]
stackYamlPkgs :: FilePath -> MaybeT IO [FilePath]
stackYamlPkgs FilePath
p =
  IO [FilePath] -> MaybeT IO [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> MaybeT IO [FilePath])
-> IO [FilePath] -> MaybeT IO [FilePath]
forall a b. (a -> b) -> a -> b
$
    FilePath -> IO (Either ParseException Pkgs)
forall a. FromJSON a => FilePath -> IO (Either ParseException a)
decodeFileEither (FilePath
p FilePath -> FilePath -> FilePath
</> FilePath
"stack.yaml") IO (Either ParseException Pkgs)
-> (Either ParseException Pkgs -> IO [FilePath]) -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right (Pkgs [FilePath]
f) ->
        IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$
          (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
p FilePath -> FilePath -> FilePath
</>)
            ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> IO [FilePath]
getDirectoryFiles FilePath
p ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath -> FilePath
</> FilePath
"*.cabal") [FilePath]
f)
      Left ParseException
e -> FilePath -> IO [FilePath]
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO [FilePath]) -> FilePath -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ ParseException -> FilePath
forall a. Show a => a -> FilePath
show ParseException
e

cabalPkgs :: FilePath -> MaybeT IO [FilePath]
cabalPkgs :: FilePath -> MaybeT IO [FilePath]
cabalPkgs FilePath
p = do
  Either IOException Text
cp <- FilePath -> MaybeT IO (Either IOException Text)
forall (m :: * -> *).
MonadIO m =>
FilePath -> m (Either IOException Text)
cabalP FilePath
"cabal.project"
  Either IOException Text
cl <- FilePath -> MaybeT IO (Either IOException Text)
forall (m :: * -> *).
MonadIO m =>
FilePath -> m (Either IOException Text)
cabalP FilePath
"cabal.project.local"
  case [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text])
-> ([Either FilePath [Text]] -> [[Text]])
-> [Either FilePath [Text]]
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either FilePath [Text]] -> [[Text]]
forall a b. [Either a b] -> [b]
rights ([Either FilePath [Text]] -> [Text])
-> [Either FilePath [Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Either FilePath [Text])
-> [Text] -> [Either FilePath [Text]]
forall a b. (a -> b) -> [a] -> [b]
map (Parser [Text] -> Text -> Either FilePath [Text]
forall a. Parser a -> Text -> Either FilePath a
parseOnly Parser [Text]
extractPkgs) ([Text] -> [Either FilePath [Text]])
-> [Text] -> [Either FilePath [Text]]
forall a b. (a -> b) -> a -> b
$ [Either IOException Text] -> [Text]
forall a b. [Either a b] -> [b]
rights [Either IOException Text
cp, Either IOException Text
cl] of
    [] ->
      IO [FilePath] -> MaybeT IO [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO [FilePath]
cfs FilePath
p) MaybeT IO [FilePath]
-> ([FilePath] -> MaybeT IO [FilePath]) -> MaybeT IO [FilePath]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [] -> FilePath -> MaybeT IO [FilePath]
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"no cabal files found"
        FilePath
h : [FilePath]
_ -> [FilePath] -> MaybeT IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
p FilePath -> FilePath -> FilePath
</> FilePath
h]
    [Text]
xs -> do
      [FilePath]
cd <- IO [FilePath] -> MaybeT IO [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> MaybeT IO [FilePath])
-> IO [FilePath] -> MaybeT IO [FilePath]
forall a b. (a -> b) -> a -> b
$ (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath
p FilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> IO [FilePath]
getDirectoryFiles FilePath
p ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> FilePath
matchDirs (FilePath -> FilePath) -> (Text -> FilePath) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack) [Text]
xs)
      [[FilePath]]
cf <-
        IO [[FilePath]] -> MaybeT IO [[FilePath]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[FilePath]] -> MaybeT IO [[FilePath]])
-> IO [[FilePath]] -> MaybeT IO [[FilePath]]
forall a b. (a -> b) -> a -> b
$
          (FilePath -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\FilePath
p -> if FilePath -> FilePath
takeExtension FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".cabal" then [FilePath] -> IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FilePath
p] else FilePath -> IO [FilePath]
cfs FilePath
p) [FilePath]
cd
      [FilePath] -> MaybeT IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> MaybeT IO [FilePath])
-> [FilePath] -> MaybeT IO [FilePath]
forall a b. (a -> b) -> a -> b
$ [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath]]
cf
  where
    cabalP :: FilePath -> m (Either IOException Text)
cabalP FilePath
n = IO (Either IOException Text) -> m (Either IOException Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> IO (Either IOException Text)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Text -> IO (Either IOException Text))
-> IO Text -> IO (Either IOException Text)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
T.readFile (FilePath -> IO Text) -> FilePath -> IO Text
forall a b. (a -> b) -> a -> b
$ FilePath
p FilePath -> FilePath -> FilePath
</> FilePath
n :: IO (Either IOException T.Text))
    cfs :: FilePath -> IO [FilePath]
cfs FilePath
d = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath
".cabal" FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==) (FilePath -> Bool) -> (FilePath -> FilePath) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
takeExtension) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
listDirectory FilePath
d
    matchDirs :: FilePath -> FilePath
matchDirs FilePath
"." = FilePath
"./*.cabal"
    matchDirs FilePath
p | FilePath
"/" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
p Bool -> Bool -> Bool
|| FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"." = FilePath
p FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"*.cabal"
    matchDirs FilePath
p | FilePath
"*" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` FilePath
p Bool -> Bool -> Bool
|| FilePath -> FilePath
takeExtension FilePath
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"" = FilePath
p FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/*.cabal"
    matchDirs FilePath
p = FilePath
p

nestedPkg :: FilePath -> FilePath -> IO (Maybe Package)
nestedPkg :: FilePath -> FilePath -> IO (Maybe Package)
nestedPkg FilePath
parrent FilePath
child = do
  Text
f' <- FilePath -> IO Text
T.readFile FilePath
child
  case Text -> Either FilePath Package
parsePackage' Text
f' of
    Right (Package Text
n [Component]
cs) -> do
      let dir :: [FilePath]
dir =
            Maybe [FilePath] -> [FilePath]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [FilePath] -> [FilePath]) -> Maybe [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
              [FilePath] -> [FilePath] -> Maybe [FilePath]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (FilePath -> [FilePath]
splitDirectories FilePath
parrent) ([FilePath] -> Maybe [FilePath]) -> [FilePath] -> Maybe [FilePath]
forall a b. (a -> b) -> a -> b
$
                FilePath -> [FilePath]
splitDirectories (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$
                  (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst (FilePath -> (FilePath, FilePath)
splitFileName FilePath
child)
          pkg :: Package
pkg =
            Text -> [Component] -> Package
Package Text
n ([Component] -> Package) -> [Component] -> Package
forall a b. (a -> b) -> a -> b
$
              (Component -> Component) -> [Component] -> [Component]
forall a b. (a -> b) -> [a] -> [b]
map
                ( \(Comp CompType
t Text
n Text
p) ->
                    CompType -> Text -> Text -> Component
Comp CompType
t Text
n (FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
joinPath [FilePath]
dir FilePath -> FilePath -> FilePath
</> Text -> FilePath
T.unpack Text
p)
                )
                [Component]
cs
      Maybe Package -> IO (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Package -> IO (Maybe Package))
-> Maybe Package -> IO (Maybe Package)
forall a b. (a -> b) -> a -> b
$ Package -> Maybe Package
forall a. a -> Maybe a
Just Package
pkg
    Either FilePath Package
_ -> Maybe Package -> IO (Maybe Package)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Package
forall a. Maybe a
Nothing