{-# LANGUAGE ScopedTypeVariables #-}

module Scrappy.Grep.Config
  ( runParserViaGhc
  , ConfigError(..)
  ) where

import System.Process (readProcessWithExitCode)
import System.Directory (doesFileExist, getTemporaryDirectory, removeFile)
import System.FilePath ((</>), takeDirectory, takeBaseName)
import System.Exit (ExitCode(..))
import Control.Exception (try, catch, SomeException)

data ConfigError
  = ConfigFileNotFound FilePath
  | GhcRunFailed String
  | ParseResultFailed String
  deriving (Int -> ConfigError -> ShowS
[ConfigError] -> ShowS
ConfigError -> String
(Int -> ConfigError -> ShowS)
-> (ConfigError -> String)
-> ([ConfigError] -> ShowS)
-> Show ConfigError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigError -> ShowS
showsPrec :: Int -> ConfigError -> ShowS
$cshow :: ConfigError -> String
show :: ConfigError -> String
$cshowList :: [ConfigError] -> ShowS
showList :: [ConfigError] -> ShowS
Show, ConfigError -> ConfigError -> Bool
(ConfigError -> ConfigError -> Bool)
-> (ConfigError -> ConfigError -> Bool) -> Eq ConfigError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConfigError -> ConfigError -> Bool
== :: ConfigError -> ConfigError -> Bool
$c/= :: ConfigError -> ConfigError -> Bool
/= :: ConfigError -> ConfigError -> Bool
Eq)

-- | Run a named parser from the import file via runghc
-- Returns the matches as a list of (line, col, matchText)
runParserViaGhc
  :: FilePath           -- ^ Import file path (Parsers.hs)
  -> String             -- ^ Parser name (e.g., "email")
  -> String             -- ^ Content to search
  -> IO (Either ConfigError [(Int, Int, String)])
runParserViaGhc :: String
-> String -> String -> IO (Either ConfigError [(Int, Int, String)])
runParserViaGhc String
importPath String
parserName String
content = do
  Bool
exists <- String -> IO Bool
doesFileExist String
importPath
  if Bool -> Bool
not Bool
exists
    then Either ConfigError [(Int, Int, String)]
-> IO (Either ConfigError [(Int, Int, String)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConfigError [(Int, Int, String)]
 -> IO (Either ConfigError [(Int, Int, String)]))
-> Either ConfigError [(Int, Int, String)]
-> IO (Either ConfigError [(Int, Int, String)])
forall a b. (a -> b) -> a -> b
$ ConfigError -> Either ConfigError [(Int, Int, String)]
forall a b. a -> Either a b
Left (ConfigError -> Either ConfigError [(Int, Int, String)])
-> ConfigError -> Either ConfigError [(Int, Int, String)]
forall a b. (a -> b) -> a -> b
$ String -> ConfigError
ConfigFileNotFound String
importPath
    else do
      String
tmpDir <- IO String
getTemporaryDirectory
      let runnerPath :: String
runnerPath = String
tmpDir String -> ShowS
</> String
"PgrepRunner.hs"
          moduleName :: String
moduleName = ShowS
takeBaseName String
importPath
          importDir :: String
importDir = ShowS
takeDirectory String
importPath

      -- Write the runner script
      String -> String -> IO ()
writeFile String
runnerPath (ShowS
generateRunner String
moduleName)

      -- Run it (need to expose parsec and containers packages via --ghc-arg)
      Either SomeException (ExitCode, String, String)
result <- IO (ExitCode, String, String)
-> IO (Either SomeException (ExitCode, String, String))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (ExitCode, String, String)
 -> IO (Either SomeException (ExitCode, String, String)))
-> IO (ExitCode, String, String)
-> IO (Either SomeException (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode
        String
"runghc"
        [ String
"--ghc-arg=-package", String
"--ghc-arg=parsec"
        , String
"--ghc-arg=-package", String
"--ghc-arg=containers"
        , String
"--ghc-arg=-i" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
importDir
        , String
runnerPath
        , String
parserName
        ]
        String
content

      -- Clean up
      String -> IO ()
removeFile String
runnerPath IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(SomeException
_ :: SomeException) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

      case Either SomeException (ExitCode, String, String)
result of
        Left (SomeException
e :: SomeException) ->
          Either ConfigError [(Int, Int, String)]
-> IO (Either ConfigError [(Int, Int, String)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConfigError [(Int, Int, String)]
 -> IO (Either ConfigError [(Int, Int, String)]))
-> Either ConfigError [(Int, Int, String)]
-> IO (Either ConfigError [(Int, Int, String)])
forall a b. (a -> b) -> a -> b
$ ConfigError -> Either ConfigError [(Int, Int, String)]
forall a b. a -> Either a b
Left (ConfigError -> Either ConfigError [(Int, Int, String)])
-> ConfigError -> Either ConfigError [(Int, Int, String)]
forall a b. (a -> b) -> a -> b
$ String -> ConfigError
GhcRunFailed (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
        Right (ExitCode
ExitSuccess, String
stdout, String
_) ->
          Either ConfigError [(Int, Int, String)]
-> IO (Either ConfigError [(Int, Int, String)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConfigError [(Int, Int, String)]
 -> IO (Either ConfigError [(Int, Int, String)]))
-> Either ConfigError [(Int, Int, String)]
-> IO (Either ConfigError [(Int, Int, String)])
forall a b. (a -> b) -> a -> b
$ [(Int, Int, String)] -> Either ConfigError [(Int, Int, String)]
forall a b. b -> Either a b
Right ([(Int, Int, String)] -> Either ConfigError [(Int, Int, String)])
-> [(Int, Int, String)] -> Either ConfigError [(Int, Int, String)]
forall a b. (a -> b) -> a -> b
$ String -> [(Int, Int, String)]
parseOutput String
stdout
        Right (ExitFailure Int
_, String
_, String
stderr) ->
          Either ConfigError [(Int, Int, String)]
-> IO (Either ConfigError [(Int, Int, String)])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ConfigError [(Int, Int, String)]
 -> IO (Either ConfigError [(Int, Int, String)]))
-> Either ConfigError [(Int, Int, String)]
-> IO (Either ConfigError [(Int, Int, String)])
forall a b. (a -> b) -> a -> b
$ ConfigError -> Either ConfigError [(Int, Int, String)]
forall a b. a -> Either a b
Left (ConfigError -> Either ConfigError [(Int, Int, String)])
-> ConfigError -> Either ConfigError [(Int, Int, String)]
forall a b. (a -> b) -> a -> b
$ String -> ConfigError
GhcRunFailed String
stderr

-- | Generate the runner Haskell script
generateRunner :: String -> String
generateRunner :: ShowS
generateRunner String
moduleName = [String] -> String
unlines
  [ String
"module Main where"
  , String
""
  , String
"import " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
moduleName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (parsers)"
  , String
"import Text.Parsec"
  , String
"import Text.Parsec.String"
  , String
"import qualified Data.Map as Map"
  , String
"import System.Environment (getArgs)"
  , String
"import System.Exit (exitFailure)"
  , String
"import System.IO (hPutStrLn, stderr)"
  , String
""
  , String
"main :: IO ()"
  , String
"main = do"
  , String
"  args <- getArgs"
  , String
"  case args of"
  , String
"    [parserName] -> do"
  , String
"      content <- getContents"
  , String
"      case Map.lookup parserName parsers of"
  , String
"        Nothing -> do"
  , String
"          hPutStrLn stderr $ \"Unknown parser: \" ++ parserName"
  , String
"          exitFailure"
  , String
"        Just p -> mapM_ printMatch (findAll p content)"
  , String
"    _ -> do"
  , String
"      hPutStrLn stderr \"Usage: runner <parserName>\""
  , String
"      exitFailure"
  , String
""
  , String
"findAll :: Parser String -> String -> [(Int, Int, String)]"
  , String
"findAll p = go 1 1"
  , String
"  where"
  , String
"    go _ _ [] = []"
  , String
"    go line col input@(c:cs) ="
  , String
"      case parse p \"\" input of"
  , String
"        Right match ->"
  , String
"          let len = length match"
  , String
"              newlines = length (filter (=='\\n') match)"
  , String
"              (newLine, newCol) ="
  , String
"                if newlines > 0"
  , String
"                then (line + newlines, length (takeWhile (/='\\n') (reverse match)) + 1)"
  , String
"                else (line, col + len)"
  , String
"          in (line, col, match) : go newLine newCol (drop len input)"
  , String
"        Left _ ->"
  , String
"          if c == '\\n'"
  , String
"          then go (line + 1) 1 cs"
  , String
"          else go line (col + 1) cs"
  , String
""
  , String
"printMatch :: (Int, Int, String) -> IO ()"
  , String
"printMatch (l, c, m) = putStrLn $ show l ++ \":\" ++ show c ++ \":\" ++ escape m"
  , String
"  where"
  , String
"    escape = concatMap (\\x -> if x == '\\n' then \"\\\\n\" else [x])"
  ]

-- | Parse the output from runghc (LINE:COL:MATCH per line)
parseOutput :: String -> [(Int, Int, String)]
parseOutput :: String -> [(Int, Int, String)]
parseOutput = (String -> (Int, Int, String)) -> [String] -> [(Int, Int, String)]
forall a b. (a -> b) -> [a] -> [b]
map String -> (Int, Int, String)
forall {a} {b}. (Read a, Read b) => String -> (a, b, String)
parseLine ([String] -> [(Int, Int, String)])
-> (String -> [String]) -> String -> [(Int, Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
  where
    parseLine :: String -> (a, b, String)
parseLine String
s =
      let (String
lineStr, String
rest1) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') String
s
          (String
colStr, String
rest2) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
rest1)
          matchText :: String
matchText = ShowS
unescape (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
rest2)
      in (String -> a
forall a. Read a => String -> a
read String
lineStr, String -> b
forall a. Read a => String -> a
read String
colStr, String
matchText)

    unescape :: ShowS
unescape [] = []
    unescape (Char
'\\':Char
'n':String
rest) = Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
unescape String
rest
    unescape (Char
c:String
rest) = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
unescape String
rest