{-# 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
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
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
Ord)

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

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

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

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