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