{-# LANGUAGE NamedFieldPuns #-}

module Calligraphy.Phases.Search
  ( searchFiles,
    pSearchConfig,
    SearchConfig,
  )
where

import qualified Calligraphy.Compat.GHC as GHC
import Calligraphy.Compat.Lib
import Calligraphy.Prelude
import Control.Applicative
import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList)
import Options.Applicative hiding (str)
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory, makeAbsolute)
import System.FilePath (isExtensionOf, (</>))

searchFiles :: SearchConfig -> IO [GHC.HieFile]
searchFiles :: SearchConfig -> IO [HieFile]
searchFiles SearchConfig {Bool
searchDotPaths :: SearchConfig -> Bool
searchDotPaths :: Bool
searchDotPaths, Maybe (NonEmpty String)
searchRoots :: SearchConfig -> Maybe (NonEmpty String)
searchRoots :: Maybe (NonEmpty String)
searchRoots, Maybe (NonEmpty Pattern)
includePatterns :: SearchConfig -> Maybe (NonEmpty Pattern)
includePatterns :: Maybe (NonEmpty Pattern)
includePatterns, Maybe (NonEmpty Pattern)
excludePatterns :: SearchConfig -> Maybe (NonEmpty Pattern)
excludePatterns :: Maybe (NonEmpty Pattern)
excludePatterns} = do
  [HieFile]
hieFiles <- [String] -> IO [HieFile]
getHieFiles forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
searchHieFilePaths

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> Bool) -> [a] -> [a]
filter [HieFile]
hieFiles forall a b. (a -> b) -> a -> b
$ \HieFile
file ->
      let matches :: Pattern -> Bool
matches Pattern
pat =
            Pattern -> String -> Bool
matchPattern Pattern
pat (ModuleName -> String
GHC.moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall unit. GenModule unit -> ModuleName
GHC.moduleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. HieFile -> Module
GHC.hie_module forall a b. (a -> b) -> a -> b
$ HieFile
file)
              Bool -> Bool -> Bool
|| Pattern -> String -> Bool
matchPattern Pattern
pat (HieFile -> String
GHC.hie_hs_file HieFile
file)
       in forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pattern -> Bool
matches) Maybe (NonEmpty Pattern)
includePatterns Bool -> Bool -> Bool
&& forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Pattern -> Bool
matches) Maybe (NonEmpty Pattern)
excludePatterns
  where
    searchHieFilePaths :: IO [String]
searchHieFilePaths = do
      [String]
roots <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO String
makeAbsolute (forall b a. b -> (a -> b) -> Maybe a -> b
maybe [String
"./."] forall a. NonEmpty a -> [a]
toList Maybe (NonEmpty String)
searchRoots)
      forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap String -> IO [String]
go [String]
roots
      where
        go :: FilePath -> IO [FilePath]
        go :: String -> IO [String]
go String
path = do
          Bool
isFile <- String -> IO Bool
doesFileExist String
path
          if Bool
isFile Bool -> Bool -> Bool
&& String -> String -> Bool
isExtensionOf String
".hie" String
path
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure [String
path]
            else do
              Bool
isDir <- String -> IO Bool
doesDirectoryExist String
path
              if Bool
isDir
                then do
                  [String]
contents <- (if Bool
searchDotPaths then forall a. a -> a
id else forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
".")) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
path
                  forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (String -> IO [String]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
path String -> String -> String
</>)) [String]
contents
                else forall (f :: * -> *) a. Applicative f => a -> f a
pure []

data SearchConfig = SearchConfig
  { SearchConfig -> Maybe (NonEmpty Pattern)
includePatterns :: Maybe (NonEmpty Pattern),
    SearchConfig -> Maybe (NonEmpty Pattern)
excludePatterns :: Maybe (NonEmpty Pattern),
    SearchConfig -> Bool
searchDotPaths :: Bool,
    SearchConfig -> Maybe (NonEmpty String)
searchRoots :: Maybe (NonEmpty FilePath)
  }

newtype Pattern = Pattern String

matchPattern :: Pattern -> String -> Bool
matchPattern :: Pattern -> String -> Bool
matchPattern (Pattern String
matcher) = Bool -> String -> String -> Bool
go Bool
False String
matcher
  where
    go :: Bool -> String -> String -> Bool
go Bool
_ (Char
'*' : String
ms) String
cs = Bool -> String -> String -> Bool
go Bool
True String
ms String
cs
    go Bool
False (Char
m : String
ms) (Char
c : String
cs) = Char
m forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
&& Bool -> String -> String -> Bool
go Bool
False String
ms String
cs
    go Bool
True String
ms (Char
c : String
cs) = Bool -> String -> String -> Bool
go Bool
True String
ms String
cs Bool -> Bool -> Bool
|| Bool -> String -> String -> Bool
go Bool
False String
ms (Char
c forall a. a -> [a] -> [a]
: String
cs)
    go Bool
_ [] [] = Bool
True
    go Bool
_ String
_ String
_ = Bool
False

pSearchConfig :: Parser SearchConfig
pSearchConfig :: Parser SearchConfig
pSearchConfig =
  Maybe (NonEmpty Pattern)
-> Maybe (NonEmpty Pattern)
-> Bool
-> Maybe (NonEmpty String)
-> SearchConfig
SearchConfig
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f [a]
many)
      ( String -> Pattern
Pattern
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod ArgumentFields s -> Parser s
strArgument
            ( forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"MODULE"
                forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Name or filepath of a module to include in the call graph. Can contain '*' wildcards. Defaults to '*'."
            )
      )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f [a]
many)
      ( String -> Pattern
Pattern
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => Mod OptionFields s -> Parser s
strOption
            ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"exclude"
                forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'e'
                forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"MODULE"
                forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Name or filepath of a module to exclude in the call graph. Can contain '*' wildcards."
            )
      )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch (forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"hidden" forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Search paths with a leading period. Disabled by default.")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f [a]
many)
      ( forall s. IsString s => Mod OptionFields s -> Parser s
strOption
          ( forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"input"
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'i'
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"PATH"
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help String
"Filepaths to search for HIE files. If passed a file, it will be processed as is. If passed a directory, the directory will be searched recursively. Can be repeated. Defaults to './.'"
          )
      )