{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}
module Hpack.Module (
  Module(..)
, toModule
, getModules
#ifdef TEST
, getModuleFilesRecursive
#endif
) where

import           Imports

import           System.FilePath
import qualified System.Directory as Directory

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