{-# LANGUAGE LambdaCase #-}
module Hpack.Util (
  GhcOption
, GhcProfOption
, GhcjsOption
, CppOption
, CcOption
, CxxOption
, LdOption
, parseMain

, tryReadFile
, expandGlobs
, sort
, lexicographically
, Hash
, sha256

, nub
, nubOn
) where

import           Control.Exception
import           Control.Monad
import           Data.Char
import           Data.Bifunctor
import           Data.List hiding (nub, sort)
import           Data.Ord
import qualified Data.Set as Set
import           System.IO.Error
import           System.Directory
import           System.FilePath
import qualified System.FilePath.Posix as Posix
import           System.FilePath.Glob
import           Crypto.Hash

import           Hpack.Haskell
import           Hpack.Utf8 as Utf8

sort :: [String] -> [String]
sort :: [String] -> [String]
sort = (String -> String -> Ordering) -> [String] -> [String]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((String -> (String, String)) -> String -> String -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing String -> (String, String)
lexicographically)

lexicographically :: String -> (String, String)
lexicographically :: String -> (String, String)
lexicographically String
x = ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
x, String
x)

type GhcOption = String
type GhcProfOption = String
type GhcjsOption = String
type CppOption = String
type CcOption = String
type CxxOption = String
type LdOption = String

parseMain :: String -> (FilePath, [GhcOption])
parseMain :: String -> (String, [String])
parseMain String
main = case [String] -> [String]
forall a. [a] -> [a]
reverse [String]
name of
  String
x : [String]
_ | [String] -> Bool
isQualifiedIdentifier [String]
name Bool -> Bool -> Bool
&& String
x String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"hs", String
"lhs"] -> (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" ([String] -> [String]
forall a. [a] -> [a]
init [String]
name) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".hs", [String
"-main-is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
main])
  [String]
_ | [String] -> Bool
isModule [String]
name -> (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" [String]
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".hs", [String
"-main-is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
main])
  [String]
_ -> (String
main, [])
  where
    name :: [String]
name = Char -> String -> [String]
splitOn Char
'.' String
main

splitOn :: Char -> String -> [String]
splitOn :: Char -> String -> [String]
splitOn Char
c = String -> [String]
go
  where
    go :: String -> [String]
go String
xs = case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) String
xs of
      (String
ys, String
"") -> [String
ys]
      (String
ys, Char
_:String
zs) -> String
ys String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
go String
zs

tryReadFile :: FilePath -> IO (Maybe String)
tryReadFile :: String -> IO (Maybe String)
tryReadFile String
file = do
  Either () String
r <- (IOError -> Maybe ()) -> IO String -> IO (Either () String)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (String -> IO String
Utf8.readFile String
file)
  Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ (() -> Maybe String)
-> (String -> Maybe String) -> Either () String -> Maybe String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe String -> () -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing) String -> Maybe String
forall a. a -> Maybe a
Just Either () String
r

toPosixFilePath :: FilePath -> FilePath
toPosixFilePath :: String -> String
toPosixFilePath = [String] -> String
Posix.joinPath ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
splitDirectories

data GlobResult = GlobResult {
  GlobResult -> String
_globResultPattern :: String
, GlobResult -> Pattern
_globResultCompiledPattern :: Pattern
, GlobResult -> [String]
_globResultFiles :: [FilePath]
}

expandGlobs :: String -> FilePath -> [String] -> IO ([String], [FilePath])
expandGlobs :: String -> String -> [String] -> IO ([String], [String])
expandGlobs String
name String
dir [String]
patterns = do
  [[String]]
files <- [Pattern] -> String -> IO [[String]]
globDir [Pattern]
compiledPatterns String
dir IO [[String]] -> ([[String]] -> IO [[String]]) -> IO [[String]]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([String] -> IO [String]) -> [[String]] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [String] -> IO [String]
removeDirectories
  let
    results :: [GlobResult]
    results :: [GlobResult]
results = (((String, Pattern), [String]) -> GlobResult)
-> [((String, Pattern), [String])] -> [GlobResult]
forall a b. (a -> b) -> [a] -> [b]
map (((String, Pattern) -> [String] -> GlobResult)
-> ((String, Pattern), [String]) -> GlobResult
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (((String, Pattern) -> [String] -> GlobResult)
 -> ((String, Pattern), [String]) -> GlobResult)
-> ((String, Pattern) -> [String] -> GlobResult)
-> ((String, Pattern), [String])
-> GlobResult
forall a b. (a -> b) -> a -> b
$ (String -> Pattern -> [String] -> GlobResult)
-> (String, Pattern) -> [String] -> GlobResult
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Pattern -> [String] -> GlobResult
GlobResult) ([((String, Pattern), [String])] -> [GlobResult])
-> [((String, Pattern), [String])] -> [GlobResult]
forall a b. (a -> b) -> a -> b
$ [(String, Pattern)]
-> [[String]] -> [((String, Pattern), [String])]
forall a b. [a] -> [b] -> [(a, b)]
zip ([String] -> [Pattern] -> [(String, Pattern)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
patterns [Pattern]
compiledPatterns) (([String] -> [String]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> [String]
sort [[String]]
files)
  ([String], [String]) -> IO ([String], [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ([GlobResult] -> ([String], [String])
combineResults [GlobResult]
results)
  where
    combineResults :: [GlobResult] -> ([String], [FilePath])
    combineResults :: [GlobResult] -> ([String], [String])
combineResults = ([[String]] -> [String])
-> ([[String]] -> [String])
-> ([[String]], [[String]])
-> ([String], [String])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> [String]
forall a. Ord a => [a] -> [a]
nub ([String] -> [String])
-> ([[String]] -> [String]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) (([[String]], [[String]]) -> ([String], [String]))
-> ([GlobResult] -> ([[String]], [[String]]))
-> [GlobResult]
-> ([String], [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([String], [String])] -> ([[String]], [[String]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([String], [String])] -> ([[String]], [[String]]))
-> ([GlobResult] -> [([String], [String])])
-> [GlobResult]
-> ([[String]], [[String]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobResult -> ([String], [String]))
-> [GlobResult] -> [([String], [String])]
forall a b. (a -> b) -> [a] -> [b]
map GlobResult -> ([String], [String])
fromResult

    fromResult :: GlobResult -> ([String], [FilePath])
    fromResult :: GlobResult -> ([String], [String])
fromResult (GlobResult String
pattern Pattern
compiledPattern [String]
files) = case [String]
files of
      [] -> ([String]
warning, [String]
literalFile)
      [String]
xs -> ([], (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
normalize [String]
xs)
      where
        warning :: [String]
warning = [String -> Pattern -> String
warn String
pattern Pattern
compiledPattern]
        literalFile :: [String]
literalFile
          | Pattern -> Bool
isLiteral Pattern
compiledPattern = [String
pattern]
          | Bool
otherwise = []

    normalize :: FilePath -> FilePath
    normalize :: String -> String
normalize = String -> String
toPosixFilePath (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
makeRelative String
dir

    warn :: String -> Pattern -> String
    warn :: String -> Pattern -> String
warn String
pattern Pattern
compiledPattern
      | Pattern -> Bool
isLiteral Pattern
compiledPattern = String
"Specified file " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
pattern String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not exist"
      | Bool
otherwise = String
"Specified pattern " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
pattern String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not match any files"

    compiledPatterns :: [Pattern]
    compiledPatterns :: [Pattern]
compiledPatterns = (String -> Pattern) -> [String] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map (CompOptions -> String -> Pattern
compileWith CompOptions
options) [String]
patterns

    removeDirectories :: [FilePath] -> IO [FilePath]
    removeDirectories :: [String] -> IO [String]
removeDirectories = (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist

    options :: CompOptions
    options :: CompOptions
options = CompOptions :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> CompOptions
CompOptions {
        characterClasses :: Bool
characterClasses = Bool
False
      , characterRanges :: Bool
characterRanges = Bool
False
      , numberRanges :: Bool
numberRanges = Bool
False
      , wildcards :: Bool
wildcards = Bool
True
      , recursiveWildcards :: Bool
recursiveWildcards = Bool
True
      , pathSepInRanges :: Bool
pathSepInRanges = Bool
False
      , errorRecovery :: Bool
errorRecovery = Bool
True
      }

type Hash = String

sha256 :: String -> Hash
sha256 :: String -> String
sha256 String
c = Digest SHA256 -> String
forall a. Show a => a -> String
show (ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash (String -> ByteString
Utf8.encodeUtf8 String
c) :: Digest SHA256)

nub :: Ord a => [a] -> [a]
nub :: [a] -> [a]
nub = (a -> a) -> [a] -> [a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
nubOn a -> a
forall a. a -> a
id

nubOn :: Ord b => (a -> b) -> [a] -> [a]
nubOn :: (a -> b) -> [a] -> [a]
nubOn a -> b
f = Set b -> [a] -> [a]
go Set b
forall a. Monoid a => a
mempty
  where
    go :: Set b -> [a] -> [a]
go Set b
seen = \ case
        [] -> []
        a
a : [a]
as
          | b
b b -> Set b -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set b
seen -> Set b -> [a] -> [a]
go Set b
seen [a]
as
          | Bool
otherwise -> a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set b -> [a] -> [a]
go (b -> Set b -> Set b
forall a. Ord a => a -> Set a -> Set a
Set.insert b
b Set b
seen) [a]
as
          where
            b :: b
b = a -> b
f a
a