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)) 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 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 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) 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