{-# LANGUAGE NamedFieldPuns #-}

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

import qualified Calligraphy.Compat.GHC as GHC
import Calligraphy.Compat.Lib
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 './.'"
          )
      )