-- |Utilities for parsing imports from Haskell source files.
module Data.Prune.ImportParser where

import Prelude

import Control.Applicative ((<|>), optional, some)
import Control.Monad (void)
import Data.List (isPrefixOf)
import Data.Map (Map)
import Data.Set (Set)
import Data.Text (pack)
import Data.Traversable (for)
import Data.Void (Void)
import Text.Megaparsec (Parsec, between, oneOf, parse)
import Text.Megaparsec.Char (alphaNumChar, char, space, string, symbolChar)
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Data.Prune.Types as T

type Parser = Parsec Void String

padded :: Parser a -> Parser a
padded :: Parser a -> Parser a
padded = ParsecT Void String Identity ()
-> ParsecT Void String Identity () -> Parser a -> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

quoted :: Parser a -> Parser a
quoted :: Parser a -> Parser a
quoted = ParsecT Void String Identity String
-> ParsecT Void String Identity String -> Parser a -> Parser a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> ParsecT Void String Identity String
ptoken String
"\"") (String -> ParsecT Void String Identity String
ptoken String
"\"")

ptoken :: String -> Parser String
ptoken :: String -> ParsecT Void String Identity String
ptoken = ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall a. Parser a -> Parser a
padded (ParsecT Void String Identity String
 -> ParsecT Void String Identity String)
-> (String -> ParsecT Void String Identity String)
-> String
-> ParsecT Void String Identity String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParsecT Void String Identity String
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string

operator :: Parser String
operator :: ParsecT Void String Identity String
operator = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> ParsecT Void String Identity [String]
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ParsecT Void String Identity String]
-> ParsecT Void String Identity [String]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [String -> ParsecT Void String Identity String
ptoken String
"(", ParsecT Void String Identity String
symbolChars, String -> ParsecT Void String Identity String
ptoken String
")"]

symbolChars :: Parser String
symbolChars :: ParsecT Void String Identity String
symbolChars = ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ([Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf (String
"!#$%&*+./<=>?@^|-~:\\" :: String)) ParsecT Void String Identity String
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT Void String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
symbolChar

symbol :: Parser String
symbol :: ParsecT Void String Identity String
symbol = ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall a. Parser a -> Parser a
padded (ParsecT Void String Identity String
 -> ParsecT Void String Identity String)
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall a b. (a -> b) -> a -> b
$ ParsecT Void String Identity String
operator ParsecT Void String Identity String
-> ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ParsecT Void String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Token String] -> ParsecT Void String Identity (Token String)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf (String
"._'" :: String))

pkgName :: Parser String
pkgName :: ParsecT Void String Identity String
pkgName = ParsecT Void String Identity Char
-> ParsecT Void String Identity String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ParsecT Void String Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
-> ParsecT Void String Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'-')

oneImport :: Parser T.ModuleName
oneImport :: Parser ModuleName
oneImport = ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"import") ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  ParsecT Void String Identity ()
-> ParsecT Void String Identity (Maybe ())
-> ParsecT Void String Identity (Maybe ())
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity ()
-> ParsecT Void String Identity (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"qualified") ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space)
  ParsecT Void String Identity (Maybe ())
-> ParsecT Void String Identity (Maybe ())
-> ParsecT Void String Identity (Maybe ())
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity ()
-> ParsecT Void String Identity (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall a. Parser a -> Parser a
padded (ParsecT Void String Identity String
-> ParsecT Void String Identity String
forall a. Parser a -> Parser a
quoted ParsecT Void String Identity String
pkgName)) ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space)
  ParsecT Void String Identity (Maybe ())
-> Parser ModuleName -> Parser ModuleName
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> ModuleName
T.ModuleName (Text -> ModuleName) -> (String -> Text) -> String -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> ModuleName)
-> ParsecT Void String Identity String -> Parser ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void String Identity String
symbol ParsecT Void String Identity String
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space))

exposedModules :: Parser (Set T.ModuleName)
exposedModules :: Parser (Set ModuleName)
exposedModules = ParsecT Void String Identity String
-> ParsecT Void String Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens String
"exposed-modules:") ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
-> ParsecT Void String Identity ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void String Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space
  ParsecT Void String Identity ()
-> Parser (Set ModuleName) -> Parser (Set ModuleName)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList ([ModuleName] -> Set ModuleName)
-> ParsecT Void String Identity [ModuleName]
-> Parser (Set ModuleName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ModuleName -> ParsecT Void String Identity [ModuleName]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Text -> ModuleName
T.ModuleName (Text -> ModuleName) -> (String -> Text) -> String -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> ModuleName)
-> ParsecT Void String Identity String -> Parser ModuleName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity String
symbol))

-- |Parse a Haskell source file's imports.
parseFileImports :: FilePath -> IO (Set T.ModuleName)
parseFileImports :: String -> IO (Set ModuleName)
parseFileImports String
fp = do
  (ParseErrorBundle String Void -> IO (Set ModuleName))
-> ([ModuleName] -> IO (Set ModuleName))
-> Either (ParseErrorBundle String Void) [ModuleName]
-> IO (Set ModuleName)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> IO (Set ModuleName)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Set ModuleName))
-> (ParseErrorBundle String Void -> String)
-> ParseErrorBundle String Void
-> IO (Set ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Failed to parse imports due to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> (ParseErrorBundle String Void -> String)
-> ParseErrorBundle String Void
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle String Void -> String
forall a. Show a => a -> String
show) (Set ModuleName -> IO (Set ModuleName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set ModuleName -> IO (Set ModuleName))
-> ([ModuleName] -> Set ModuleName)
-> [ModuleName]
-> IO (Set ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModuleName] -> Set ModuleName
forall a. Ord a => [a] -> Set a
Set.fromList) (Either (ParseErrorBundle String Void) [ModuleName]
 -> IO (Set ModuleName))
-> (String -> Either (ParseErrorBundle String Void) [ModuleName])
-> String
-> IO (Set ModuleName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Either (ParseErrorBundle String Void) ModuleName)
-> [String] -> Either (ParseErrorBundle String Void) [ModuleName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Parser ModuleName
-> String
-> String
-> Either (ParseErrorBundle String Void) ModuleName
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parser ModuleName
oneImport String
fp) ([String] -> Either (ParseErrorBundle String Void) [ModuleName])
-> (String -> [String])
-> String
-> Either (ParseErrorBundle String Void) [ModuleName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"import ") ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    (String -> IO (Set ModuleName)) -> IO String -> IO (Set ModuleName)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
readFile String
fp

-- |Parse exposed modules from the `ghc-pkg` field description.
parseExposedModules :: String -> IO (Set T.ModuleName)
parseExposedModules :: String -> IO (Set ModuleName)
parseExposedModules String
input =
  if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
input
    then Set ModuleName -> IO (Set ModuleName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set ModuleName
forall a. Monoid a => a
mempty
    else (ParseErrorBundle String Void -> IO (Set ModuleName))
-> (Set ModuleName -> IO (Set ModuleName))
-> Either (ParseErrorBundle String Void) (Set ModuleName)
-> IO (Set ModuleName)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ParseErrorBundle String Void
e -> String -> IO (Set ModuleName)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO (Set ModuleName)) -> String -> IO (Set ModuleName)
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse exposed modules due to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ParseErrorBundle String Void -> String
forall a. Show a => a -> String
show ParseErrorBundle String Void
e String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" original input " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
input) Set ModuleName -> IO (Set ModuleName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ParseErrorBundle String Void) (Set ModuleName)
 -> IO (Set ModuleName))
-> Either (ParseErrorBundle String Void) (Set ModuleName)
-> IO (Set ModuleName)
forall a b. (a -> b) -> a -> b
$ Parser (Set ModuleName)
-> String
-> String
-> Either (ParseErrorBundle String Void) (Set ModuleName)
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parser (Set ModuleName)
exposedModules String
"" String
input

-- |Get the dependencies used by a list of modules imported by a Haskell source file.
getUsedDependencies :: Map T.ModuleName T.DependencyName -> Set T.ModuleName -> Set T.DependencyName
getUsedDependencies :: Map ModuleName DependencyName
-> Set ModuleName -> Set DependencyName
getUsedDependencies Map ModuleName DependencyName
dependencyByModule = (ModuleName -> Set DependencyName -> Set DependencyName)
-> Set DependencyName -> [ModuleName] -> Set DependencyName
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ModuleName -> Set DependencyName -> Set DependencyName
go Set DependencyName
forall a. Monoid a => a
mempty ([ModuleName] -> Set DependencyName)
-> (Set ModuleName -> [ModuleName])
-> Set ModuleName
-> Set DependencyName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set ModuleName -> [ModuleName]
forall a. Set a -> [a]
Set.toList
  where
    go :: ModuleName -> Set DependencyName -> Set DependencyName
go ModuleName
next Set DependencyName
acc = Set DependencyName
acc Set DependencyName -> Set DependencyName -> Set DependencyName
forall a. Semigroup a => a -> a -> a
<> Set DependencyName
-> (DependencyName -> Set DependencyName)
-> Maybe DependencyName
-> Set DependencyName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set DependencyName
forall a. Monoid a => a
mempty DependencyName -> Set DependencyName
forall a. a -> Set a
Set.singleton (ModuleName -> Map ModuleName DependencyName -> Maybe DependencyName
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
next Map ModuleName DependencyName
dependencyByModule)

-- |Get the dependencies used by a thing to compile by (1) parsing each source file's imports, (2) getting the
-- dependencies each of those files use, and (3) smooshing all the dependencies together to return.
getCompilableUsedDependencies :: Map T.ModuleName T.DependencyName -> T.Compilable -> IO (Set T.DependencyName)
getCompilableUsedDependencies :: Map ModuleName DependencyName
-> Compilable -> IO (Set DependencyName)
getCompilableUsedDependencies Map ModuleName DependencyName
dependencyByModule T.Compilable {Set String
Set DependencyName
CompilableName
CompilableType
compilableFiles :: Compilable -> Set String
compilableDependencies :: Compilable -> Set DependencyName
compilableType :: Compilable -> CompilableType
compilableName :: Compilable -> CompilableName
compilableFiles :: Set String
compilableDependencies :: Set DependencyName
compilableType :: CompilableType
compilableName :: CompilableName
..} = ([Set DependencyName] -> Set DependencyName)
-> IO [Set DependencyName] -> IO (Set DependencyName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Set DependencyName] -> Set DependencyName
forall a. Monoid a => [a] -> a
mconcat (IO [Set DependencyName] -> IO (Set DependencyName))
-> ((String -> IO (Set DependencyName)) -> IO [Set DependencyName])
-> (String -> IO (Set DependencyName))
-> IO (Set DependencyName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String]
-> (String -> IO (Set DependencyName)) -> IO [Set DependencyName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
compilableFiles) ((String -> IO (Set DependencyName)) -> IO (Set DependencyName))
-> (String -> IO (Set DependencyName)) -> IO (Set DependencyName)
forall a b. (a -> b) -> a -> b
$ \String
fp -> do
  Set ModuleName
moduleNames <- String -> IO (Set ModuleName)
parseFileImports String
fp
  Set DependencyName -> IO (Set DependencyName)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set DependencyName -> IO (Set DependencyName))
-> Set DependencyName -> IO (Set DependencyName)
forall a b. (a -> b) -> a -> b
$ Map ModuleName DependencyName
-> Set ModuleName -> Set DependencyName
getUsedDependencies Map ModuleName DependencyName
dependencyByModule Set ModuleName
moduleNames