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