Locate.hs

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

instance FromJSON Pkgs where
  parseJSON (Object v) = Pkgs <$> v .:? "packages" .!= ["."]
  parseJSON _ = fail "could not read packages from stack.yaml"

stackYamlPkgs :: FilePath -> MaybeT IO [FilePath]
stackYamlPkgs p =
  liftIO $
    decodeFileEither (p </> "stack.yaml") >>= \case
      Right (Pkgs f) ->
        liftIO $
          map (p </>)
            <$> getDirectoryFiles p (map (</> "*.cabal") f)
      Left e -> fail $ show e

cabalPkgs :: FilePath -> MaybeT IO [FilePath]
cabalPkgs p = do
  cp <- cabalP "cabal.project"
  cl <- cabalP "cabal.project.local"
  case concat . rights $ map (parseOnly extractPkgs) $ rights [cp, cl] of
    [] ->
      liftIO (cfs p) >>= \case
        [] -> fail "no cabal files found"
        h : _ -> pure [p </> h]
    xs -> do
      cd <- liftIO $ map (p </>) <$> getDirectoryFiles p (map (matchDirs . T.unpack) xs)
      cf <-
        liftIO $
          mapM (\p -> if takeExtension p == ".cabal" then pure [p] else cfs p) cd
      pure $ concat cf
  where
    cabalP n = liftIO (try $ T.readFile $ p </> n :: IO (Either IOException T.Text))
    cfs d = filter ((".cabal" ==) . takeExtension) <$> listDirectory d
    matchDirs "." = "./*.cabal"
    matchDirs p | "/" `isSuffixOf` p || p == "." = p <> "*.cabal"
    matchDirs p | "*" `isSuffixOf` p || takeExtension p == "" = p <> "/*.cabal"
    matchDirs p = p

nestedPkg :: FilePath -> FilePath -> IO (Maybe Package)
nestedPkg parrent child = do
  f' <- T.readFile child
  case parsePackage' f' of
    Right (Package n cs) -> do
      let dir =
            fromJust $
              stripPrefix (splitDirectories parrent) $
                splitDirectories $
                  fst (splitFileName child)
          pkg =
            Package n $
              map
                ( \(Comp t n p) ->
                    Comp t n (T.pack $ joinPath dir </> T.unpack p)
                )
                cs
      pure $ Just pkg
    _ -> pure Nothing