{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} module Hpack.Module ( Module(..) , toModule , getModules #ifdef TEST , getModuleFilesRecursive #endif ) where import Data.String import System.FilePath import qualified System.Directory as Directory import Control.Monad import Data.List hiding (nub, sort) import Data.Aeson.Config.FromValue import Hpack.Util import Hpack.Haskell import Path (Path(..), PathComponent(..)) import qualified Path newtype Module = Module {Module -> String unModule :: String} deriving (Module -> Module -> Bool (Module -> Module -> Bool) -> (Module -> Module -> Bool) -> Eq Module forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Module -> Module -> Bool $c/= :: Module -> Module -> Bool == :: Module -> Module -> Bool $c== :: Module -> Module -> Bool Eq, Eq Module Eq Module -> (Module -> Module -> Ordering) -> (Module -> Module -> Bool) -> (Module -> Module -> Bool) -> (Module -> Module -> Bool) -> (Module -> Module -> Bool) -> (Module -> Module -> Module) -> (Module -> Module -> Module) -> Ord Module Module -> Module -> Bool Module -> Module -> Ordering Module -> Module -> Module forall a. Eq a -> (a -> a -> Ordering) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> a) -> (a -> a -> a) -> Ord a min :: Module -> Module -> Module $cmin :: Module -> Module -> Module max :: Module -> Module -> Module $cmax :: Module -> Module -> Module >= :: Module -> Module -> Bool $c>= :: Module -> Module -> Bool > :: Module -> Module -> Bool $c> :: Module -> Module -> Bool <= :: Module -> Module -> Bool $c<= :: Module -> Module -> Bool < :: Module -> Module -> Bool $c< :: Module -> Module -> Bool compare :: Module -> Module -> Ordering $ccompare :: Module -> Module -> Ordering $cp1Ord :: Eq Module Ord) instance Show Module where show :: Module -> String show = ShowS forall a. Show a => a -> String show ShowS -> (Module -> String) -> Module -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Module -> String unModule instance IsString Module where fromString :: String -> Module fromString = String -> Module Module instance FromValue Module where fromValue :: Value -> Parser Module fromValue = (String -> Module) -> Parser String -> Parser Module forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap String -> Module Module (Parser String -> Parser Module) -> (Value -> Parser String) -> Value -> Parser Module forall b c a. (b -> c) -> (a -> b) -> a -> c . Value -> Parser String forall a. FromValue a => Value -> Parser a fromValue toModule :: Path -> Module toModule :: Path -> Module toModule Path path = case [String] -> [String] forall a. [a] -> [a] reverse ([String] -> [String]) -> [String] -> [String] forall a b. (a -> b) -> a -> b $ Path -> [String] Path.components Path path of [] -> String -> Module Module String "" String file : [String] dirs -> String -> Module Module (String -> Module) -> ([String] -> String) -> [String] -> Module forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> [String] -> String forall a. [a] -> [[a]] -> [a] intercalate String "." ([String] -> String) -> ([String] -> [String]) -> [String] -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . [String] -> [String] forall a. [a] -> [a] reverse ([String] -> Module) -> [String] -> Module forall a b. (a -> b) -> a -> b $ ShowS dropExtension String file String -> [String] -> [String] forall a. a -> [a] -> [a] : [String] dirs getModules :: FilePath -> FilePath -> IO [Module] getModules :: String -> String -> IO [Module] getModules String dir String literalSrc = [Module] -> [Module] sortModules ([Module] -> [Module]) -> IO [Module] -> IO [Module] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> do Bool exists <- String -> IO Bool Directory.doesDirectoryExist (String dir String -> ShowS </> String literalSrc) if Bool exists then do String canonicalSrc <- String -> IO String Directory.canonicalizePath (String dir String -> ShowS </> String literalSrc) let srcIsProjectRoot :: Bool srcIsProjectRoot :: Bool srcIsProjectRoot = String canonicalSrc String -> String -> Bool forall a. Eq a => a -> a -> Bool == String dir toModules :: [Path] -> [Module] toModules :: [Path] -> [Module] toModules = [Module] -> [Module] removeSetup ([Module] -> [Module]) -> ([Path] -> [Module]) -> [Path] -> [Module] forall b c a. (b -> c) -> (a -> b) -> a -> c . [Module] -> [Module] forall a. Ord a => [a] -> [a] nub ([Module] -> [Module]) -> ([Path] -> [Module]) -> [Path] -> [Module] forall b c a. (b -> c) -> (a -> b) -> a -> c . (Path -> Module) -> [Path] -> [Module] forall a b. (a -> b) -> [a] -> [b] map Path -> Module toModule removeSetup :: [Module] -> [Module] removeSetup :: [Module] -> [Module] removeSetup | Bool srcIsProjectRoot = (Module -> Bool) -> [Module] -> [Module] forall a. (a -> Bool) -> [a] -> [a] filter (Module -> Module -> Bool forall a. Eq a => a -> a -> Bool /= Module "Setup") | Bool otherwise = [Module] -> [Module] forall a. a -> a id [Path] -> [Module] toModules ([Path] -> [Module]) -> IO [Path] -> IO [Module] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> IO [Path] getModuleFilesRecursive String canonicalSrc else [Module] -> IO [Module] forall (m :: * -> *) a. Monad m => a -> m a return [] sortModules :: [Module] -> [Module] sortModules :: [Module] -> [Module] sortModules = (String -> Module) -> [String] -> [Module] forall a b. (a -> b) -> [a] -> [b] map String -> Module Module ([String] -> [Module]) -> ([Module] -> [String]) -> [Module] -> [Module] forall b c a. (b -> c) -> (a -> b) -> a -> c . [String] -> [String] sort ([String] -> [String]) -> ([Module] -> [String]) -> [Module] -> [String] forall b c a. (b -> c) -> (a -> b) -> a -> c . (Module -> String) -> [Module] -> [String] forall a b. (a -> b) -> [a] -> [b] map Module -> String unModule isSourceFile :: PathComponent -> Bool isSourceFile :: PathComponent -> Bool isSourceFile (String -> (String, String) splitExtension (String -> (String, String)) -> (PathComponent -> String) -> PathComponent -> (String, String) forall b c a. (b -> c) -> (a -> b) -> a -> c . PathComponent -> String unPathComponent -> (String name, String ext)) = String ext String -> [String] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` [String] extensions Bool -> Bool -> Bool && String -> Bool isModuleNameComponent String name where extensions :: [String] extensions :: [String] extensions = [ String ".hs" , String ".lhs" , String ".chs" , String ".hsc" , String ".y" , String ".ly" , String ".x" ] isModuleComponent :: PathComponent -> Bool isModuleComponent :: PathComponent -> Bool isModuleComponent = String -> Bool isModuleNameComponent (String -> Bool) -> (PathComponent -> String) -> PathComponent -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . PathComponent -> String unPathComponent getModuleFilesRecursive :: FilePath -> IO [Path] getModuleFilesRecursive :: String -> IO [Path] getModuleFilesRecursive String baseDir = Path -> IO [Path] go ([PathComponent] -> Path Path []) where addBaseDir :: Path -> FilePath addBaseDir :: Path -> String addBaseDir = (String baseDir String -> ShowS </>) ShowS -> (Path -> String) -> Path -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Path -> String Path.toFilePath listDirectory :: Path -> IO [PathComponent] listDirectory :: Path -> IO [PathComponent] listDirectory = ([String] -> [PathComponent]) -> IO [String] -> IO [PathComponent] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ((String -> PathComponent) -> [String] -> [PathComponent] forall a b. (a -> b) -> [a] -> [b] map String -> PathComponent PathComponent) (IO [String] -> IO [PathComponent]) -> (Path -> IO [String]) -> Path -> IO [PathComponent] forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> IO [String] Directory.listDirectory (String -> IO [String]) -> (Path -> String) -> Path -> IO [String] forall b c a. (b -> c) -> (a -> b) -> a -> c . Path -> String addBaseDir doesFileExist :: Path -> IO Bool doesFileExist :: Path -> IO Bool doesFileExist = String -> IO Bool Directory.doesFileExist (String -> IO Bool) -> (Path -> String) -> Path -> IO Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Path -> String addBaseDir doesDirectoryExist :: Path -> IO Bool doesDirectoryExist :: Path -> IO Bool doesDirectoryExist = String -> IO Bool Directory.doesDirectoryExist (String -> IO Bool) -> (Path -> String) -> Path -> IO Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Path -> String addBaseDir go :: Path -> IO [Path] go :: Path -> IO [Path] go Path dir = do [PathComponent] entries <- Path -> IO [PathComponent] listDirectory Path dir [Path] files <- (Path -> IO Bool) -> [PathComponent] -> IO [Path] filterWith Path -> IO Bool doesFileExist ((PathComponent -> Bool) -> [PathComponent] -> [PathComponent] forall a. (a -> Bool) -> [a] -> [a] filter PathComponent -> Bool isSourceFile [PathComponent] entries) [Path] directories <- (Path -> IO Bool) -> [PathComponent] -> IO [Path] filterWith Path -> IO Bool doesDirectoryExist ((PathComponent -> Bool) -> [PathComponent] -> [PathComponent] forall a. (a -> Bool) -> [a] -> [a] filter PathComponent -> Bool isModuleComponent [PathComponent] entries) [Path] subdirsFiles <- [[Path]] -> [Path] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat ([[Path]] -> [Path]) -> IO [[Path]] -> IO [Path] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Path -> IO [Path]) -> [Path] -> IO [[Path]] forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM Path -> IO [Path] go [Path] directories [Path] -> IO [Path] forall (m :: * -> *) a. Monad m => a -> m a return ([Path] files [Path] -> [Path] -> [Path] forall a. [a] -> [a] -> [a] ++ [Path] subdirsFiles) where filterWith :: (Path -> IO Bool) -> [PathComponent] -> IO [Path] filterWith :: (Path -> IO Bool) -> [PathComponent] -> IO [Path] filterWith Path -> IO Bool p = (Path -> IO Bool) -> [Path] -> IO [Path] forall (m :: * -> *) a. Applicative m => (a -> m Bool) -> [a] -> m [a] filterM Path -> IO Bool p ([Path] -> IO [Path]) -> ([PathComponent] -> [Path]) -> [PathComponent] -> IO [Path] forall b c a. (b -> c) -> (a -> b) -> a -> c . (PathComponent -> Path) -> [PathComponent] -> [Path] forall a b. (a -> b) -> [a] -> [b] map PathComponent -> Path addDir addDir :: PathComponent -> Path addDir :: PathComponent -> Path addDir PathComponent entry = [PathComponent] -> Path Path (Path -> [PathComponent] unPath Path dir [PathComponent] -> [PathComponent] -> [PathComponent] forall a. [a] -> [a] -> [a] ++ [PathComponent entry])