{-# LANGUAGE RecordWildCards, PatternGuards, TemplateHaskell, CPP #-}


-- | Module for reading settings files.
module Input.Settings(
    Settings(..), loadSettings
    ) where

import Control.Exception (catch, throwIO)
import Data.List.Extra
import Data.Maybe
import Language.Haskell.TH.Syntax (lift, runIO)
import System.FilePath
import System.IO.Error (isDoesNotExistError)
import System.IO.Extra
import qualified Data.Map.Strict as Map
import Paths_hoogle


-- | Settings values. Later settings always override earlier settings.
data Setting
    = -- | Given a Cabal tag/author rename it from the LHS to the RHS.
      --   If the RHS is blank, delete the tag.
      RenameTag String String
    | -- | Change the priority of a module. Given package name, module name, new priority.
      --   Use * for wildcard matches. All un-reordered modules are 0
      ReorderModule String String Int
    deriving ReadPrec [Setting]
ReadPrec Setting
Int -> ReadS Setting
ReadS [Setting]
(Int -> ReadS Setting)
-> ReadS [Setting]
-> ReadPrec Setting
-> ReadPrec [Setting]
-> Read Setting
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Setting]
$creadListPrec :: ReadPrec [Setting]
readPrec :: ReadPrec Setting
$creadPrec :: ReadPrec Setting
readList :: ReadS [Setting]
$creadList :: ReadS [Setting]
readsPrec :: Int -> ReadS Setting
$creadsPrec :: Int -> ReadS Setting
Read


data Settings = Settings
    {Settings -> String -> String
renameTag :: String -> String -- ^ Rename a cabal tag
    ,Settings -> String -> String -> Int
reorderModule :: String -> String -> Int
    }


readFileSettings :: FilePath -> String -> IO [Setting]
readFileSettings :: String -> String -> IO [Setting]
readFileSettings String
file String
backup = do
    String
src <- String -> IO String
readFileUTF8 String
file IO String -> (IOError -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
e ->
        if IOError -> Bool
isDoesNotExistError IOError
e
            then String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
backup
            else IOError -> IO String
forall e a. Exception e => e -> IO a
throwIO IOError
e
    [Setting] -> IO [Setting]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Setting] -> IO [Setting]) -> [Setting] -> IO [Setting]
forall a b. (a -> b) -> a -> b
$ [[Setting]] -> [Setting]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Setting]] -> [Setting]) -> [[Setting]] -> [Setting]
forall a b. (a -> b) -> a -> b
$ (Integer -> String -> [Setting])
-> Integer -> [String] -> [[Setting]]
forall a b c. Enum a => (a -> b -> c) -> a -> [b] -> [c]
zipWithFrom Integer -> String -> [Setting]
forall a a. (Read a, Show a) => a -> String -> [a]
f Integer
1 ([String] -> [[Setting]]) -> [String] -> [[Setting]]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
trim ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
src
    where
        f :: a -> String -> [a]
f a
i String
s | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s = []
              | String
"--" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s = []
              | [(a
x,String
"")] <- ReadS a
forall a. Read a => ReadS a
reads String
s = [a
x]
              | Bool
otherwise = String -> [a]
forall a. HasCallStack => String -> a
error (String -> [a]) -> String -> [a]
forall a b. (a -> b) -> a -> b
$ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": Failure to parse, got: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s



-- | Fix bad names in the Cabal file.
loadSettings :: IO Settings
loadSettings :: IO Settings
loadSettings = do
    String
dataDir <- IO String
getDataDir
#ifdef PROFILE
    -- profiling and TemplateHaskell don't play well
    let backup = ""
#else
    let backup :: String
backup = $(runIO (readFileUTF8 "misc/settings.txt") >>= lift)
#endif
    [Setting]
src <- String -> String -> IO [Setting]
readFileSettings (String
dataDir String -> String -> String
</> String
"misc/settings.txt") String
backup
    Settings -> IO Settings
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Settings -> IO Settings) -> Settings -> IO Settings
forall a b. (a -> b) -> a -> b
$ [Setting] -> Settings
createSettings [Setting]
src

createSettings :: [Setting] -> Settings
createSettings :: [Setting] -> Settings
createSettings [Setting]
xs = Settings :: (String -> String) -> (String -> String -> Int) -> Settings
Settings{String -> String
String -> String -> Int
reorderModule :: String -> String -> Int
renameTag :: String -> String
reorderModule :: String -> String -> Int
renameTag :: String -> String
..}
    where
        renameTag :: String -> String
renameTag = \String
x -> String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
x (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
f String
x
            where f :: String -> Maybe String
f = [(String, String)] -> String -> Maybe String
forall a. [(String, a)] -> String -> Maybe a
literals [(String
a,String
b) | RenameTag String
a String
b <- [Setting]
xs]

        reorderModule :: String -> String -> Int
reorderModule = \String
pkg -> case String -> [(String, Int)]
f String
pkg of
                                    [] -> Int -> String -> Int
forall a b. a -> b -> a
const Int
0
                                    [(String, Int)]
xs -> let f :: String -> [Int]
f = [(String, Int)] -> String -> [Int]
forall a. [(String, a)] -> String -> [a]
wildcards [(String, Int)]
xs
                                          in \String
mod -> Int -> [Int] -> Int
forall a. a -> [a] -> a
lastDef Int
0 (String -> [Int]
f String
mod)
            where f :: String -> [(String, Int)]
f = [(String, (String, Int))] -> String -> [(String, Int)]
forall a. [(String, a)] -> String -> [a]
wildcards [(String
a,(String
b,Int
c)) | ReorderModule String
a String
b Int
c <- [Setting]
xs]


---------------------------------------------------------------------
-- SPECIAL LOOKUPS

literals :: [(String, a)] -> String -> Maybe a
literals :: [(String, a)] -> String -> Maybe a
literals [(String, a)]
xs = \String
x -> String -> Map String a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
x Map String a
mp
    where mp :: Map String a
mp = [(String, a)] -> Map String a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, a)]
xs

wildcards :: [(String, a)] -> String -> [a]
wildcards :: [(String, a)] -> String -> [a]
wildcards [(String, a)]
xs String
x = [a
b | (String
a,a
b) <- [(String, a)]
xs, String -> String -> Bool
matchWildcard String
a String
x]

matchWildcard :: String -> String -> Bool
matchWildcard :: String -> String -> Bool
matchWildcard [Char
'*'] String
ys = Bool
True -- special common case
matchWildcard (Char
'*':String
xs) String
ys = (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
matchWildcard String
xs) ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ String -> [String]
forall a. [a] -> [[a]]
tails String
ys
matchWildcard (Char
x:String
xs) (Char
y:String
ys) = Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
y Bool -> Bool -> Bool
&& String -> String -> Bool
matchWildcard String
xs String
ys
matchWildcard [] [] = Bool
True
matchWildcard String
_ String
_ = Bool
False