{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}

module HsDev.PackageDb.Types (
	PackageDb(..), packageDb,
	PackageDbStack(..), packageDbStack, mkPackageDbStack,
	globalDb, userDb, fromPackageDbs,
	topPackageDb, packageDbs, packageDbStacks,
	isSubStack,

	packageDbOpt, packageDbStackOpts
	) where

import Control.Applicative
import Control.Monad (guard)
import Control.Lens (makeLenses, each, (^.))
import Control.DeepSeq (NFData(..))
import Data.Aeson
import Data.List (tails, isSuffixOf, intercalate)
import qualified Data.Text as T
import Data.String
import Text.Format

import System.Directory.Paths
import HsDev.Display

data PackageDb = GlobalDb | UserDb | PackageDb { PackageDb -> Path
_packageDb :: Path } deriving (PackageDb -> PackageDb -> Bool
(PackageDb -> PackageDb -> Bool)
-> (PackageDb -> PackageDb -> Bool) -> Eq PackageDb
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageDb -> PackageDb -> Bool
$c/= :: PackageDb -> PackageDb -> Bool
== :: PackageDb -> PackageDb -> Bool
$c== :: PackageDb -> PackageDb -> Bool
Eq, Eq PackageDb
Eq PackageDb
-> (PackageDb -> PackageDb -> Ordering)
-> (PackageDb -> PackageDb -> Bool)
-> (PackageDb -> PackageDb -> Bool)
-> (PackageDb -> PackageDb -> Bool)
-> (PackageDb -> PackageDb -> Bool)
-> (PackageDb -> PackageDb -> PackageDb)
-> (PackageDb -> PackageDb -> PackageDb)
-> Ord PackageDb
PackageDb -> PackageDb -> Bool
PackageDb -> PackageDb -> Ordering
PackageDb -> PackageDb -> PackageDb
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 :: PackageDb -> PackageDb -> PackageDb
$cmin :: PackageDb -> PackageDb -> PackageDb
max :: PackageDb -> PackageDb -> PackageDb
$cmax :: PackageDb -> PackageDb -> PackageDb
>= :: PackageDb -> PackageDb -> Bool
$c>= :: PackageDb -> PackageDb -> Bool
> :: PackageDb -> PackageDb -> Bool
$c> :: PackageDb -> PackageDb -> Bool
<= :: PackageDb -> PackageDb -> Bool
$c<= :: PackageDb -> PackageDb -> Bool
< :: PackageDb -> PackageDb -> Bool
$c< :: PackageDb -> PackageDb -> Bool
compare :: PackageDb -> PackageDb -> Ordering
$ccompare :: PackageDb -> PackageDb -> Ordering
$cp1Ord :: Eq PackageDb
Ord)

makeLenses ''PackageDb

instance NFData PackageDb where
	rnf :: PackageDb -> ()
rnf PackageDb
GlobalDb = ()
	rnf PackageDb
UserDb = ()
	rnf (PackageDb Path
p) = Path -> ()
forall a. NFData a => a -> ()
rnf Path
p

instance Show PackageDb where
	show :: PackageDb -> String
show PackageDb
GlobalDb = String
"global-db"
	show PackageDb
UserDb = String
"user-db"
	show (PackageDb Path
p) = String
"package-db:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path
p Path -> Getting String Path String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Path String
Lens' Path String
path

instance Display PackageDb where
	display :: PackageDb -> String
display PackageDb
GlobalDb = String
"global-db"
	display PackageDb
UserDb = String
"user-db"
	display (PackageDb Path
p) = String
"package-db " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path -> String
forall a. Display a => a -> String
display Path
p
	displayType :: PackageDb -> String
displayType PackageDb
_ = String
"package-db"

instance Formattable PackageDb where
	formattable :: PackageDb -> FormatFlags -> Formatted
formattable = String -> FormatFlags -> Formatted
forall a. Formattable a => a -> FormatFlags -> Formatted
formattable (String -> FormatFlags -> Formatted)
-> (PackageDb -> String) -> PackageDb -> FormatFlags -> Formatted
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDb -> String
forall a. Display a => a -> String
display

instance ToJSON PackageDb where
	toJSON :: PackageDb -> Value
toJSON PackageDb
GlobalDb = Value
"global-db"
	toJSON PackageDb
UserDb = Value
"user-db"
	toJSON (PackageDb Path
p) = String -> Value
forall a. IsString a => String -> a
fromString (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"package-db:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path
p Path -> Getting String Path String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Path String
Lens' Path String
path

instance FromJSON PackageDb where
	parseJSON :: Value -> Parser PackageDb
parseJSON Value
v = Value -> Parser PackageDb
globalP Value
v Parser PackageDb -> Parser PackageDb -> Parser PackageDb
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser PackageDb
userP Value
v Parser PackageDb -> Parser PackageDb -> Parser PackageDb
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser PackageDb
dbP Value
v where
		globalP :: Value -> Parser PackageDb
globalP = String -> (Path -> Parser PackageDb) -> Value -> Parser PackageDb
forall a. String -> (Path -> Parser a) -> Value -> Parser a
withText String
"global-db" (\Path
s -> Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Path
s Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
== Path
"global-db") Parser () -> Parser PackageDb -> Parser PackageDb
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PackageDb -> Parser PackageDb
forall (m :: * -> *) a. Monad m => a -> m a
return PackageDb
GlobalDb)
		userP :: Value -> Parser PackageDb
userP = String -> (Path -> Parser PackageDb) -> Value -> Parser PackageDb
forall a. String -> (Path -> Parser a) -> Value -> Parser a
withText String
"user-db" (\Path
s -> Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Path
s Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
== Path
"user-db") Parser () -> Parser PackageDb -> Parser PackageDb
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PackageDb -> Parser PackageDb
forall (m :: * -> *) a. Monad m => a -> m a
return PackageDb
UserDb)
		dbP :: Value -> Parser PackageDb
dbP = String -> (Path -> Parser PackageDb) -> Value -> Parser PackageDb
forall a. String -> (Path -> Parser a) -> Value -> Parser a
withText String
"package-db" ((Path -> Parser PackageDb) -> Value -> Parser PackageDb)
-> (Path -> Parser PackageDb) -> Value -> Parser PackageDb
forall a b. (a -> b) -> a -> b
$ \Path
s -> case Path -> Path -> Maybe Path
T.stripPrefix Path
"package-db:" Path
s of
			Maybe Path
Nothing -> String -> Parser PackageDb
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Can't parse package-db: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path -> String
T.unpack Path
s)
			Just Path
p' -> PackageDb -> Parser PackageDb
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDb -> Parser PackageDb) -> PackageDb -> Parser PackageDb
forall a b. (a -> b) -> a -> b
$ Path -> PackageDb
PackageDb Path
p'

instance Paths PackageDb where
	paths :: (String -> f String) -> PackageDb -> f PackageDb
paths String -> f String
_ PackageDb
GlobalDb = PackageDb -> f PackageDb
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageDb
GlobalDb
	paths String -> f String
_ PackageDb
UserDb = PackageDb -> f PackageDb
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageDb
UserDb
	paths String -> f String
f (PackageDb Path
p) = Path -> PackageDb
PackageDb (Path -> PackageDb) -> f Path -> f PackageDb
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> f String) -> Path -> f Path
forall a. Paths a => Traversal' a String
paths String -> f String
f Path
p

-- | Stack of PackageDb in reverse order
newtype PackageDbStack = PackageDbStack { PackageDbStack -> [PackageDb]
_packageDbStack :: [PackageDb] } deriving (PackageDbStack -> PackageDbStack -> Bool
(PackageDbStack -> PackageDbStack -> Bool)
-> (PackageDbStack -> PackageDbStack -> Bool) -> Eq PackageDbStack
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageDbStack -> PackageDbStack -> Bool
$c/= :: PackageDbStack -> PackageDbStack -> Bool
== :: PackageDbStack -> PackageDbStack -> Bool
$c== :: PackageDbStack -> PackageDbStack -> Bool
Eq, Eq PackageDbStack
Eq PackageDbStack
-> (PackageDbStack -> PackageDbStack -> Ordering)
-> (PackageDbStack -> PackageDbStack -> Bool)
-> (PackageDbStack -> PackageDbStack -> Bool)
-> (PackageDbStack -> PackageDbStack -> Bool)
-> (PackageDbStack -> PackageDbStack -> Bool)
-> (PackageDbStack -> PackageDbStack -> PackageDbStack)
-> (PackageDbStack -> PackageDbStack -> PackageDbStack)
-> Ord PackageDbStack
PackageDbStack -> PackageDbStack -> Bool
PackageDbStack -> PackageDbStack -> Ordering
PackageDbStack -> PackageDbStack -> PackageDbStack
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 :: PackageDbStack -> PackageDbStack -> PackageDbStack
$cmin :: PackageDbStack -> PackageDbStack -> PackageDbStack
max :: PackageDbStack -> PackageDbStack -> PackageDbStack
$cmax :: PackageDbStack -> PackageDbStack -> PackageDbStack
>= :: PackageDbStack -> PackageDbStack -> Bool
$c>= :: PackageDbStack -> PackageDbStack -> Bool
> :: PackageDbStack -> PackageDbStack -> Bool
$c> :: PackageDbStack -> PackageDbStack -> Bool
<= :: PackageDbStack -> PackageDbStack -> Bool
$c<= :: PackageDbStack -> PackageDbStack -> Bool
< :: PackageDbStack -> PackageDbStack -> Bool
$c< :: PackageDbStack -> PackageDbStack -> Bool
compare :: PackageDbStack -> PackageDbStack -> Ordering
$ccompare :: PackageDbStack -> PackageDbStack -> Ordering
$cp1Ord :: Eq PackageDbStack
Ord, Int -> PackageDbStack -> ShowS
[PackageDbStack] -> ShowS
PackageDbStack -> String
(Int -> PackageDbStack -> ShowS)
-> (PackageDbStack -> String)
-> ([PackageDbStack] -> ShowS)
-> Show PackageDbStack
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackageDbStack] -> ShowS
$cshowList :: [PackageDbStack] -> ShowS
show :: PackageDbStack -> String
$cshow :: PackageDbStack -> String
showsPrec :: Int -> PackageDbStack -> ShowS
$cshowsPrec :: Int -> PackageDbStack -> ShowS
Show)

makeLenses ''PackageDbStack

instance NFData PackageDbStack where
	rnf :: PackageDbStack -> ()
rnf (PackageDbStack [PackageDb]
ps) = [PackageDb] -> ()
forall a. NFData a => a -> ()
rnf [PackageDb]
ps

instance Display PackageDbStack where
	display :: PackageDbStack -> String
display = String -> FormatFlags -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" (FormatFlags -> String)
-> (PackageDbStack -> FormatFlags) -> PackageDbStack -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageDb -> String) -> [PackageDb] -> FormatFlags
forall a b. (a -> b) -> [a] -> [b]
map PackageDb -> String
forall a. Display a => a -> String
display ([PackageDb] -> FormatFlags)
-> (PackageDbStack -> [PackageDb]) -> PackageDbStack -> FormatFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDbStack -> [PackageDb]
packageDbs
	displayType :: PackageDbStack -> String
displayType PackageDbStack
_ = String
"package-db-stack"

instance Formattable PackageDbStack where
	formattable :: PackageDbStack -> FormatFlags -> Formatted
formattable = String -> FormatFlags -> Formatted
forall a. Formattable a => a -> FormatFlags -> Formatted
formattable (String -> FormatFlags -> Formatted)
-> (PackageDbStack -> String)
-> PackageDbStack
-> FormatFlags
-> Formatted
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDbStack -> String
forall a. Display a => a -> String
display

instance ToJSON PackageDbStack where
	toJSON :: PackageDbStack -> Value
toJSON (PackageDbStack [PackageDb]
ps) = [PackageDb] -> Value
forall a. ToJSON a => a -> Value
toJSON [PackageDb]
ps

instance FromJSON PackageDbStack where
	parseJSON :: Value -> Parser PackageDbStack
parseJSON = ([PackageDb] -> PackageDbStack)
-> Parser [PackageDb] -> Parser PackageDbStack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PackageDb] -> PackageDbStack
PackageDbStack (Parser [PackageDb] -> Parser PackageDbStack)
-> (Value -> Parser [PackageDb]) -> Value -> Parser PackageDbStack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser [PackageDb]
forall a. FromJSON a => Value -> Parser a
parseJSON

instance Paths PackageDbStack where
	paths :: (String -> f String) -> PackageDbStack -> f PackageDbStack
paths String -> f String
f (PackageDbStack [PackageDb]
ps) = [PackageDb] -> PackageDbStack
PackageDbStack ([PackageDb] -> PackageDbStack)
-> f [PackageDb] -> f PackageDbStack
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((PackageDb -> f PackageDb) -> [PackageDb] -> f [PackageDb]
forall s t a b. Each s t a b => Traversal s t a b
each ((PackageDb -> f PackageDb) -> [PackageDb] -> f [PackageDb])
-> ((String -> f String) -> PackageDb -> f PackageDb)
-> (String -> f String)
-> [PackageDb]
-> f [PackageDb]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> f String) -> PackageDb -> f PackageDb
forall a. Paths a => Traversal' a String
paths) String -> f String
f [PackageDb]
ps

-- | Make @PackageDbStack@ from list of @PackageDb@
mkPackageDbStack :: [PackageDb] -> PackageDbStack
mkPackageDbStack :: [PackageDb] -> PackageDbStack
mkPackageDbStack = [PackageDb] -> PackageDbStack
PackageDbStack ([PackageDb] -> PackageDbStack)
-> ([PackageDb] -> [PackageDb]) -> [PackageDb] -> PackageDbStack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageDb] -> [PackageDb]
forall a. [a] -> [a]
reverse ([PackageDb] -> [PackageDb])
-> ([PackageDb] -> [PackageDb]) -> [PackageDb] -> [PackageDb]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageDb -> Bool) -> [PackageDb] -> [PackageDb]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (PackageDb -> PackageDb -> Bool
forall a. Eq a => a -> a -> Bool
== PackageDb
GlobalDb)

-- | Global db stack
globalDb :: PackageDbStack
globalDb :: PackageDbStack
globalDb = [PackageDb] -> PackageDbStack
PackageDbStack []

-- | User db stack
userDb :: PackageDbStack
userDb :: PackageDbStack
userDb = [PackageDb] -> PackageDbStack
PackageDbStack [PackageDb
UserDb]

-- | Make package-db stack from paths
fromPackageDbs :: [Path] -> PackageDbStack
fromPackageDbs :: [Path] -> PackageDbStack
fromPackageDbs = [PackageDb] -> PackageDbStack
PackageDbStack ([PackageDb] -> PackageDbStack)
-> ([Path] -> [PackageDb]) -> [Path] -> PackageDbStack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path -> PackageDb) -> [Path] -> [PackageDb]
forall a b. (a -> b) -> [a] -> [b]
map Path -> PackageDb
PackageDb ([Path] -> [PackageDb])
-> ([Path] -> [Path]) -> [Path] -> [PackageDb]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Path] -> [Path]
forall a. [a] -> [a]
reverse

-- | Get top package-db for package-db stack
topPackageDb :: PackageDbStack -> PackageDb
topPackageDb :: PackageDbStack -> PackageDb
topPackageDb (PackageDbStack []) = PackageDb
GlobalDb
topPackageDb (PackageDbStack (PackageDb
d:[PackageDb]
_)) = PackageDb
d

-- | Get list of package-db in stack, adds additional global-db at bottom
packageDbs :: PackageDbStack -> [PackageDb]
packageDbs :: PackageDbStack -> [PackageDb]
packageDbs = (PackageDb
GlobalDb PackageDb -> [PackageDb] -> [PackageDb]
forall a. a -> [a] -> [a]
:) ([PackageDb] -> [PackageDb])
-> (PackageDbStack -> [PackageDb]) -> PackageDbStack -> [PackageDb]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageDb] -> [PackageDb]
forall a. [a] -> [a]
reverse ([PackageDb] -> [PackageDb])
-> (PackageDbStack -> [PackageDb]) -> PackageDbStack -> [PackageDb]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDbStack -> [PackageDb]
_packageDbStack

-- | Get stacks for each package-db in stack
packageDbStacks :: PackageDbStack -> [PackageDbStack]
packageDbStacks :: PackageDbStack -> [PackageDbStack]
packageDbStacks = ([PackageDb] -> PackageDbStack)
-> [[PackageDb]] -> [PackageDbStack]
forall a b. (a -> b) -> [a] -> [b]
map [PackageDb] -> PackageDbStack
PackageDbStack ([[PackageDb]] -> [PackageDbStack])
-> (PackageDbStack -> [[PackageDb]])
-> PackageDbStack
-> [PackageDbStack]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageDb] -> [[PackageDb]]
forall a. [a] -> [[a]]
tails ([PackageDb] -> [[PackageDb]])
-> (PackageDbStack -> [PackageDb])
-> PackageDbStack
-> [[PackageDb]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDbStack -> [PackageDb]
_packageDbStack

-- | Is one package-db stack substack of another
isSubStack :: PackageDbStack -> PackageDbStack -> Bool
isSubStack :: PackageDbStack -> PackageDbStack -> Bool
isSubStack (PackageDbStack [PackageDb]
l) (PackageDbStack [PackageDb]
r) = [PackageDb]
l [PackageDb] -> [PackageDb] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [PackageDb]
r

-- | Get ghc options for package-db
packageDbOpt :: PackageDb -> String
packageDbOpt :: PackageDb -> String
packageDbOpt PackageDb
GlobalDb = String
"-global-package-db"
packageDbOpt PackageDb
UserDb = String
"-user-package-db"
packageDbOpt (PackageDb Path
p) = String
"-package-db " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path
p Path -> Getting String Path String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Path String
Lens' Path String
path

-- | Get ghc options for package-db stack
packageDbStackOpts :: PackageDbStack -> [String]
packageDbStackOpts :: PackageDbStack -> FormatFlags
packageDbStackOpts (PackageDbStack [PackageDb]
ps)
	| String
"-user-package-db" String -> FormatFlags -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FormatFlags
opts' = FormatFlags
opts'
	| Bool
otherwise = String
"-no-user-package-db" String -> FormatFlags -> FormatFlags
forall a. a -> [a] -> [a]
: FormatFlags
opts'
	where
		opts' :: FormatFlags
opts' = (PackageDb -> String) -> [PackageDb] -> FormatFlags
forall a b. (a -> b) -> [a] -> [b]
map PackageDb -> String
packageDbOpt ([PackageDb] -> [PackageDb]
forall a. [a] -> [a]
reverse [PackageDb]
ps)