{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
-- | Logic and datatypes for parsing @hie.yaml@ files.
module HIE.Bios.Config(
    readConfig,
    Config(..),
    CradleConfig(..),
    CabalType,
    pattern CabalType,
    cabalComponent,
    StackType,
    pattern StackType,
    stackComponent,
    stackYaml,
    CradleType(..),
    Callable(..)
    ) where

import Control.Exception
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as Map
import           Data.Maybe (mapMaybe)
import           Data.Semigroup
import           Data.Foldable (foldrM)
import           Data.Aeson (JSONPath)
import           Data.Yaml
import           Data.Yaml.Internal (Warning(..))

type MLast a = Maybe (Last a)

viewLast :: MLast a -> Maybe a
viewLast :: MLast a -> Maybe a
viewLast (Just Last a
l) = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Last a -> a
forall a. Last a -> a
getLast Last a
l
viewLast MLast a
Nothing = Maybe a
forall a. Maybe a
Nothing

pattern MLast :: Maybe a -> MLast a
pattern $bMLast :: Maybe a -> MLast a
$mMLast :: forall r a. MLast a -> (Maybe a -> r) -> (Void# -> r) -> r
MLast m <- (viewLast -> m) where
    MLast (Just a
l) = Last a -> MLast a
forall a. a -> Maybe a
Just (Last a -> MLast a) -> Last a -> MLast a
forall a b. (a -> b) -> a -> b
$ a -> Last a
forall a. a -> Last a
Last a
l
    MLast Maybe a
Nothing = MLast a
forall a. Maybe a
Nothing

-- | Configuration that can be used to load a 'Cradle'.
-- A configuration has roughly the following form:
--
-- @
-- cradle:
--   cabal:
--     component: "lib:hie-bios"
-- @
newtype Config a = Config { Config a -> CradleConfig a
cradle :: CradleConfig a }
    deriving (Int -> Config a -> ShowS
[Config a] -> ShowS
Config a -> String
(Int -> Config a -> ShowS)
-> (Config a -> String) -> ([Config a] -> ShowS) -> Show (Config a)
forall a. Int -> Config a -> ShowS
forall a. [Config a] -> ShowS
forall a. Config a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config a] -> ShowS
$cshowList :: forall a. [Config a] -> ShowS
show :: Config a -> String
$cshow :: forall a. Config a -> String
showsPrec :: Int -> Config a -> ShowS
$cshowsPrec :: forall a. Int -> Config a -> ShowS
Show, Config a -> Config a -> Bool
(Config a -> Config a -> Bool)
-> (Config a -> Config a -> Bool) -> Eq (Config a)
forall a. Eq a => Config a -> Config a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Config a -> Config a -> Bool
$c/= :: forall a. Eq a => Config a -> Config a -> Bool
== :: Config a -> Config a -> Bool
$c== :: forall a. Eq a => Config a -> Config a -> Bool
Eq, a -> Config b -> Config a
(a -> b) -> Config a -> Config b
(forall a b. (a -> b) -> Config a -> Config b)
-> (forall a b. a -> Config b -> Config a) -> Functor Config
forall a b. a -> Config b -> Config a
forall a b. (a -> b) -> Config a -> Config b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Config b -> Config a
$c<$ :: forall a b. a -> Config b -> Config a
fmap :: (a -> b) -> Config a -> Config b
$cfmap :: forall a b. (a -> b) -> Config a -> Config b
Functor)

data CradleConfig a =
    CradleConfig
        { CradleConfig a -> [String]
cradleDependencies :: [FilePath]
        -- ^ Dependencies of a cradle.
        -- Dependencies are expected to be relative to the root directory.
        -- The given files are not required to exist.
        , CradleConfig a -> CradleType a
cradleType :: CradleType a
        -- ^ Type of the cradle to use. Actions to obtain
        -- compiler flags from are dependant on this field.
        }
        deriving (Int -> CradleConfig a -> ShowS
[CradleConfig a] -> ShowS
CradleConfig a -> String
(Int -> CradleConfig a -> ShowS)
-> (CradleConfig a -> String)
-> ([CradleConfig a] -> ShowS)
-> Show (CradleConfig a)
forall a. Int -> CradleConfig a -> ShowS
forall a. [CradleConfig a] -> ShowS
forall a. CradleConfig a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CradleConfig a] -> ShowS
$cshowList :: forall a. [CradleConfig a] -> ShowS
show :: CradleConfig a -> String
$cshow :: forall a. CradleConfig a -> String
showsPrec :: Int -> CradleConfig a -> ShowS
$cshowsPrec :: forall a. Int -> CradleConfig a -> ShowS
Show, CradleConfig a -> CradleConfig a -> Bool
(CradleConfig a -> CradleConfig a -> Bool)
-> (CradleConfig a -> CradleConfig a -> Bool)
-> Eq (CradleConfig a)
forall a. Eq a => CradleConfig a -> CradleConfig a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CradleConfig a -> CradleConfig a -> Bool
$c/= :: forall a. Eq a => CradleConfig a -> CradleConfig a -> Bool
== :: CradleConfig a -> CradleConfig a -> Bool
$c== :: forall a. Eq a => CradleConfig a -> CradleConfig a -> Bool
Eq, a -> CradleConfig b -> CradleConfig a
(a -> b) -> CradleConfig a -> CradleConfig b
(forall a b. (a -> b) -> CradleConfig a -> CradleConfig b)
-> (forall a b. a -> CradleConfig b -> CradleConfig a)
-> Functor CradleConfig
forall a b. a -> CradleConfig b -> CradleConfig a
forall a b. (a -> b) -> CradleConfig a -> CradleConfig b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CradleConfig b -> CradleConfig a
$c<$ :: forall a b. a -> CradleConfig b -> CradleConfig a
fmap :: (a -> b) -> CradleConfig a -> CradleConfig b
$cfmap :: forall a b. (a -> b) -> CradleConfig a -> CradleConfig b
Functor)

data Callable = Program FilePath | Command String
    deriving (Int -> Callable -> ShowS
[Callable] -> ShowS
Callable -> String
(Int -> Callable -> ShowS)
-> (Callable -> String) -> ([Callable] -> ShowS) -> Show Callable
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Callable] -> ShowS
$cshowList :: [Callable] -> ShowS
show :: Callable -> String
$cshow :: Callable -> String
showsPrec :: Int -> Callable -> ShowS
$cshowsPrec :: Int -> Callable -> ShowS
Show, Callable -> Callable -> Bool
(Callable -> Callable -> Bool)
-> (Callable -> Callable -> Bool) -> Eq Callable
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Callable -> Callable -> Bool
$c/= :: Callable -> Callable -> Bool
== :: Callable -> Callable -> Bool
$c== :: Callable -> Callable -> Bool
Eq)

data CabalType
    = CabalType_ { CabalType -> MLast String
_cabalComponent :: !(MLast String) }
    deriving (CabalType -> CabalType -> Bool
(CabalType -> CabalType -> Bool)
-> (CabalType -> CabalType -> Bool) -> Eq CabalType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CabalType -> CabalType -> Bool
$c/= :: CabalType -> CabalType -> Bool
== :: CabalType -> CabalType -> Bool
$c== :: CabalType -> CabalType -> Bool
Eq)

instance Semigroup CabalType where
    CabalType_ MLast String
cr <> :: CabalType -> CabalType -> CabalType
<> CabalType_ MLast String
cl = MLast String -> CabalType
CabalType_ (MLast String
cr MLast String -> MLast String -> MLast String
forall a. Semigroup a => a -> a -> a
<> MLast String
cl)

instance Monoid CabalType where
    mempty :: CabalType
mempty = MLast String -> CabalType
CabalType_ MLast String
forall a. Monoid a => a
mempty

pattern CabalType :: Maybe String -> CabalType
pattern $bCabalType :: Maybe String -> CabalType
$mCabalType :: forall r. CabalType -> (Maybe String -> r) -> (Void# -> r) -> r
CabalType { CabalType -> Maybe String
cabalComponent } = CabalType_ (MLast cabalComponent)
{-# COMPLETE CabalType #-}

instance Show CabalType where
  show :: CabalType -> String
show = CradleType Any -> String
forall a. Show a => a -> String
show (CradleType Any -> String)
-> (CabalType -> CradleType Any) -> CabalType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CabalType -> CradleType Any
forall a. CabalType -> CradleType a
Cabal

data StackType
    = StackType_ { StackType -> MLast String
_stackComponent :: !(MLast String) , StackType -> MLast String
_stackYaml :: !(MLast String) }
    deriving (StackType -> StackType -> Bool
(StackType -> StackType -> Bool)
-> (StackType -> StackType -> Bool) -> Eq StackType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StackType -> StackType -> Bool
$c/= :: StackType -> StackType -> Bool
== :: StackType -> StackType -> Bool
$c== :: StackType -> StackType -> Bool
Eq)

instance Semigroup StackType where
    StackType_ MLast String
cr MLast String
yr <> :: StackType -> StackType -> StackType
<> StackType_ MLast String
cl MLast String
yl = MLast String -> MLast String -> StackType
StackType_ (MLast String
cr MLast String -> MLast String -> MLast String
forall a. Semigroup a => a -> a -> a
<> MLast String
cl) (MLast String
yr MLast String -> MLast String -> MLast String
forall a. Semigroup a => a -> a -> a
<> MLast String
yl)

instance Monoid StackType where
    mempty :: StackType
mempty = MLast String -> MLast String -> StackType
StackType_ MLast String
forall a. Monoid a => a
mempty MLast String
forall a. Monoid a => a
mempty

pattern StackType :: Maybe String -> Maybe String -> StackType
pattern $bStackType :: Maybe String -> Maybe String -> StackType
$mStackType :: forall r.
StackType
-> (Maybe String -> Maybe String -> r) -> (Void# -> r) -> r
StackType { StackType -> Maybe String
stackComponent, StackType -> Maybe String
stackYaml } = StackType_ (MLast stackComponent) (MLast stackYaml)
{-# COMPLETE StackType #-}

instance Show StackType where
  show :: StackType -> String
show = CradleType Any -> String
forall a. Show a => a -> String
show (CradleType Any -> String)
-> (StackType -> CradleType Any) -> StackType -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackType -> CradleType Any
forall a. StackType -> CradleType a
Stack

data CradleType a
    = Cabal { CradleType a -> CabalType
cabalType :: !CabalType }
    | CabalMulti { CradleType a -> CabalType
defaultCabal :: !CabalType, CradleType a -> [(String, CabalType)]
subCabalComponents :: [ (FilePath, CabalType) ] }
    | Stack { CradleType a -> StackType
stackType :: !StackType }
    | StackMulti { CradleType a -> StackType
defaultStack :: !StackType, CradleType a -> [(String, StackType)]
subStackComponents :: [ (FilePath, StackType) ] }
--  Bazel and Obelisk used to be supported but bit-rotted and no users have complained.
--  They can be added back if a user
--    | Bazel
--    | Obelisk
    | Bios
        { CradleType a -> Callable
call :: Callable
        -- ^ Path to program or shell command that retrieves options to compile a file
        , CradleType a -> Maybe Callable
depsCall :: Maybe Callable
        -- ^ Optional path to program or shell command to obtain cradle dependencies.
        -- Each cradle dependency is to be expected to be on a separate line
        -- and relative to the root dir of the cradle.
        , CradleType a -> Maybe String
ghcPath :: Maybe FilePath
        -- ^ Optional path to the ghc binary
        }
    | Direct { CradleType a -> [String]
arguments :: [String] }
    | None
    | Multi [ (FilePath, CradleConfig a) ]
    | Other { CradleType a -> a
otherConfig :: a, CradleType a -> Value
originalYamlValue :: Value }
    deriving (CradleType a -> CradleType a -> Bool
(CradleType a -> CradleType a -> Bool)
-> (CradleType a -> CradleType a -> Bool) -> Eq (CradleType a)
forall a. Eq a => CradleType a -> CradleType a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CradleType a -> CradleType a -> Bool
$c/= :: forall a. Eq a => CradleType a -> CradleType a -> Bool
== :: CradleType a -> CradleType a -> Bool
$c== :: forall a. Eq a => CradleType a -> CradleType a -> Bool
Eq, a -> CradleType b -> CradleType a
(a -> b) -> CradleType a -> CradleType b
(forall a b. (a -> b) -> CradleType a -> CradleType b)
-> (forall a b. a -> CradleType b -> CradleType a)
-> Functor CradleType
forall a b. a -> CradleType b -> CradleType a
forall a b. (a -> b) -> CradleType a -> CradleType b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CradleType b -> CradleType a
$c<$ :: forall a b. a -> CradleType b -> CradleType a
fmap :: (a -> b) -> CradleType a -> CradleType b
$cfmap :: forall a b. (a -> b) -> CradleType a -> CradleType b
Functor)

instance FromJSON a => FromJSON (CradleType a) where
    parseJSON :: Value -> Parser (CradleType a)
parseJSON (Object Object
o) = Object -> Parser (CradleType a)
forall a. FromJSON a => Object -> Parser (CradleType a)
parseCradleType Object
o
    parseJSON Value
_ = String -> Parser (CradleType a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not a known cradle type. Possible are: cabal, stack, bios, direct, default, none, multi"

instance Show (CradleType a) where
    show :: CradleType a -> String
show (Cabal CabalType
comp) = String
"Cabal {component = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. Show a => a -> String
show (CabalType -> Maybe String
cabalComponent CabalType
comp) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
    show (CabalMulti CabalType
d [(String, CabalType)]
a) = String
"CabalMulti {defaultCabal = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CabalType -> String
forall a. Show a => a -> String
show CabalType
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", subCabalComponents = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, CabalType)] -> String
forall a. Show a => a -> String
show [(String, CabalType)]
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
    show (Stack StackType
comp) = String
"Stack {component = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. Show a => a -> String
show (StackType -> Maybe String
stackComponent StackType
comp) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", stackYaml = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. Show a => a -> String
show (StackType -> Maybe String
stackYaml StackType
comp) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
    show (StackMulti StackType
d [(String, StackType)]
a) = String
"StackMulti {defaultStack = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ StackType -> String
forall a. Show a => a -> String
show StackType
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", subStackComponents = "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, StackType)] -> String
forall a. Show a => a -> String
show [(String, StackType)]
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
    show Bios { Callable
call :: Callable
call :: forall a. CradleType a -> Callable
call, Maybe Callable
depsCall :: Maybe Callable
depsCall :: forall a. CradleType a -> Maybe Callable
depsCall } = String
"Bios {call = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Callable -> String
forall a. Show a => a -> String
show Callable
call String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", depsCall = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Callable -> String
forall a. Show a => a -> String
show Maybe Callable
depsCall String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
    show (Direct [String]
args) = String
"Direct {arguments = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
args String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"
    show CradleType a
None = String
"None"
    show (Multi [(String, CradleConfig a)]
a) = String
"Multi " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(String, CradleConfig a)] -> String
forall a. Show a => a -> String
show [(String, CradleConfig a)]
a
    show (Other a
_ Value
val) = String
"Other {originalYamlValue = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
val String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"}"

parseCradleType :: FromJSON a => Object -> Parser (CradleType a)
parseCradleType :: Object -> Parser (CradleType a)
parseCradleType Object
o
    | Just Value
val <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"cabal" Object
o = Value -> Parser (CradleType a)
forall a. Value -> Parser (CradleType a)
parseCabal Value
val
    | Just Value
val <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"stack" Object
o = Value -> Parser (CradleType a)
forall a. Value -> Parser (CradleType a)
parseStack Value
val
--    | Just _val <- Map.lookup "bazel" o = return Bazel
--    | Just _val <- Map.lookup "obelisk" o = return Obelisk
    | Just Value
val <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"bios" Object
o = Value -> Parser (CradleType a)
forall a. Value -> Parser (CradleType a)
parseBios Value
val
    | Just Value
val <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"direct" Object
o = Value -> Parser (CradleType a)
forall a. Value -> Parser (CradleType a)
parseDirect Value
val
    | Just Value
_val <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"none" Object
o = CradleType a -> Parser (CradleType a)
forall (m :: * -> *) a. Monad m => a -> m a
return CradleType a
forall a. CradleType a
None
    | Just Value
val  <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"multi" Object
o = Value -> Parser (CradleType a)
forall a. FromJSON a => Value -> Parser (CradleType a)
parseMulti Value
val
    | Just Value
val  <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"other" Object
o = a -> Value -> CradleType a
forall a. a -> Value -> CradleType a
Other (a -> Value -> CradleType a)
-> Parser a -> Parser (Value -> CradleType a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
val Parser (Value -> CradleType a)
-> Parser Value -> Parser (CradleType a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
val
parseCradleType Object
o = String -> Parser (CradleType a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (CradleType a))
-> String -> Parser (CradleType a)
forall a b. (a -> b) -> a -> b
$ String
"Unknown cradle type: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Object -> String
forall a. Show a => a -> String
show Object
o

parseSingleOrMultiple
  :: Monoid x
  => (x -> CradleType a)
  -> (x -> [(FilePath, x)] -> CradleType a)
  -> (Map.HashMap T.Text Value -> Parser x)
  -> Value
  -> Parser (CradleType a)
parseSingleOrMultiple :: (x -> CradleType a)
-> (x -> [(String, x)] -> CradleType a)
-> (Object -> Parser x)
-> Value
-> Parser (CradleType a)
parseSingleOrMultiple x -> CradleType a
single x -> [(String, x)] -> CradleType a
multiple Object -> Parser x
parse = Value -> Parser (CradleType a)
doParse where
    parseOne :: Value -> Parser (String, x)
parseOne Value
e
        | Object Object
v <- Value
e
        , Just (String Text
prefix) <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"path" Object
v
        = (Text -> String
T.unpack Text
prefix,) (x -> (String, x)) -> Parser x -> Parser (String, x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser x
parse (Text -> Object -> Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete Text
"path" Object
v)
        | Bool
otherwise
        = String -> Parser (String, x)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected an object with a path key"
    parseArray :: Vector Value -> Parser [(String, x)]
parseArray = (Value -> [(String, x)] -> Parser [(String, x)])
-> [(String, x)] -> Vector Value -> Parser [(String, x)]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (\Value
v [(String, x)]
cs -> ((String, x) -> [(String, x)] -> [(String, x)]
forall a. a -> [a] -> [a]
: [(String, x)]
cs) ((String, x) -> [(String, x)])
-> Parser (String, x) -> Parser [(String, x)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (String, x)
parseOne Value
v) []
    doParse :: Value -> Parser (CradleType a)
doParse (Object Object
v)
        | Just (Array Vector Value
x) <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"components" Object
v
        = do
            x
d <- Object -> Parser x
parse (Text -> Object -> Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
Map.delete Text
"components" Object
v)
            [(String, x)]
xs <- Vector Value -> Parser [(String, x)]
parseArray Vector Value
x
            CradleType a -> Parser (CradleType a)
forall (m :: * -> *) a. Monad m => a -> m a
return (CradleType a -> Parser (CradleType a))
-> CradleType a -> Parser (CradleType a)
forall a b. (a -> b) -> a -> b
$ x -> [(String, x)] -> CradleType a
multiple x
d [(String, x)]
xs
        | Just Value
_ <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"components" Object
v
        = String -> Parser (CradleType a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected components to be an array of subcomponents"
        | Maybe Value
Nothing <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"components" Object
v
        = x -> CradleType a
single (x -> CradleType a) -> Parser x -> Parser (CradleType a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser x
parse Object
v
    doParse (Array Vector Value
x)
        = do
            [(String, x)]
xs <- Vector Value -> Parser [(String, x)]
parseArray Vector Value
x
            CradleType a -> Parser (CradleType a)
forall (m :: * -> *) a. Monad m => a -> m a
return (CradleType a -> Parser (CradleType a))
-> CradleType a -> Parser (CradleType a)
forall a b. (a -> b) -> a -> b
$ x -> [(String, x)] -> CradleType a
multiple x
forall a. Monoid a => a
mempty [(String, x)]
xs
    doParse Value
Null = x -> CradleType a
single (x -> CradleType a) -> Parser x -> Parser (CradleType a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser x
parse Object
forall k v. HashMap k v
Map.empty
    doParse Value
_ = String -> Parser (CradleType a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Configuration is expected to be an object or an array of objects."

parseStack :: Value -> Parser (CradleType a)
parseStack :: Value -> Parser (CradleType a)
parseStack = (StackType -> CradleType a)
-> (StackType -> [(String, StackType)] -> CradleType a)
-> (Object -> Parser StackType)
-> Value
-> Parser (CradleType a)
forall x a.
Monoid x =>
(x -> CradleType a)
-> (x -> [(String, x)] -> CradleType a)
-> (Object -> Parser x)
-> Value
-> Parser (CradleType a)
parseSingleOrMultiple StackType -> CradleType a
forall a. StackType -> CradleType a
Stack StackType -> [(String, StackType)] -> CradleType a
forall a. StackType -> [(String, StackType)] -> CradleType a
StackMulti ((Object -> Parser StackType) -> Value -> Parser (CradleType a))
-> (Object -> Parser StackType) -> Value -> Parser (CradleType a)
forall a b. (a -> b) -> a -> b
$
  \case Object
x | Object -> Int
forall k v. HashMap k v -> Int
Map.size Object
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
          , Just (String Text
component) <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"component" Object
x
          , Just (String Text
syaml) <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"stackYaml" Object
x
          -> StackType -> Parser StackType
forall (m :: * -> *) a. Monad m => a -> m a
return (StackType -> Parser StackType) -> StackType -> Parser StackType
forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> StackType
StackType (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
component) (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
syaml)
          | Object -> Int
forall k v. HashMap k v -> Int
Map.size Object
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1, Just (String Text
component) <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"component" Object
x
          -> StackType -> Parser StackType
forall (m :: * -> *) a. Monad m => a -> m a
return (StackType -> Parser StackType) -> StackType -> Parser StackType
forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> StackType
StackType (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
component) Maybe String
forall a. Maybe a
Nothing
          | Object -> Int
forall k v. HashMap k v -> Int
Map.size Object
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1, Just (String Text
syaml) <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"stackYaml" Object
x
          -> StackType -> Parser StackType
forall (m :: * -> *) a. Monad m => a -> m a
return (StackType -> Parser StackType) -> StackType -> Parser StackType
forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> StackType
StackType Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
syaml)
          | Object -> Bool
forall k v. HashMap k v -> Bool
Map.null Object
x
          -> StackType -> Parser StackType
forall (m :: * -> *) a. Monad m => a -> m a
return (StackType -> Parser StackType) -> StackType -> Parser StackType
forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> StackType
StackType Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
          | Bool
otherwise
          -> String -> Parser StackType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not a valid Stack configuration, following keys are allowed: component, stackYaml"

parseCabal :: Value -> Parser (CradleType a)
parseCabal :: Value -> Parser (CradleType a)
parseCabal = (CabalType -> CradleType a)
-> (CabalType -> [(String, CabalType)] -> CradleType a)
-> (Object -> Parser CabalType)
-> Value
-> Parser (CradleType a)
forall x a.
Monoid x =>
(x -> CradleType a)
-> (x -> [(String, x)] -> CradleType a)
-> (Object -> Parser x)
-> Value
-> Parser (CradleType a)
parseSingleOrMultiple CabalType -> CradleType a
forall a. CabalType -> CradleType a
Cabal CabalType -> [(String, CabalType)] -> CradleType a
forall a. CabalType -> [(String, CabalType)] -> CradleType a
CabalMulti ((Object -> Parser CabalType) -> Value -> Parser (CradleType a))
-> (Object -> Parser CabalType) -> Value -> Parser (CradleType a)
forall a b. (a -> b) -> a -> b
$
  \case Object
x | Object -> Int
forall k v. HashMap k v -> Int
Map.size Object
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1, Just (String Text
component) <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"component" Object
x
          -> CabalType -> Parser CabalType
forall (m :: * -> *) a. Monad m => a -> m a
return (CabalType -> Parser CabalType) -> CabalType -> Parser CabalType
forall a b. (a -> b) -> a -> b
$ Maybe String -> CabalType
CabalType (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
component)
          | Object -> Bool
forall k v. HashMap k v -> Bool
Map.null Object
x
          -> CabalType -> Parser CabalType
forall (m :: * -> *) a. Monad m => a -> m a
return (CabalType -> Parser CabalType) -> CabalType -> Parser CabalType
forall a b. (a -> b) -> a -> b
$ Maybe String -> CabalType
CabalType Maybe String
forall a. Maybe a
Nothing
          | Bool
otherwise
          -> String -> Parser CabalType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not a valid Cabal configuration, following keys are allowed: component"

parseBios :: Value -> Parser (CradleType a)
parseBios :: Value -> Parser (CradleType a)
parseBios (Object Object
x) =
    case Maybe Callable
biosCallable of
        Just Callable
bc -> CradleType a -> Parser (CradleType a)
forall (m :: * -> *) a. Monad m => a -> m a
return (CradleType a -> Parser (CradleType a))
-> CradleType a -> Parser (CradleType a)
forall a b. (a -> b) -> a -> b
$ Callable -> Maybe Callable -> Maybe String -> CradleType a
forall a.
Callable -> Maybe Callable -> Maybe String -> CradleType a
Bios Callable
bc Maybe Callable
biosDepsCallable Maybe String
ghcPath
        Maybe Callable
_ -> String -> Parser (CradleType a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (CradleType a))
-> String -> Parser (CradleType a)
forall a b. (a -> b) -> a -> b
$ String
"Not a valid Bios Configuration type, following keys are allowed:" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                    String
"program or shell, dependency-program or dependency-shell, with-ghc"
    where
        biosCallable :: Maybe Callable
biosCallable =
            Maybe Callable -> Maybe Callable -> Maybe Callable
forall a. Maybe a -> Maybe a -> Maybe a
exclusive
                ((String -> Callable) -> Text -> Maybe Callable
forall t. (String -> t) -> Text -> Maybe t
stringTypeFromMap String -> Callable
Program Text
"program")
                ((String -> Callable) -> Text -> Maybe Callable
forall t. (String -> t) -> Text -> Maybe t
stringTypeFromMap String -> Callable
Command Text
"shell")
        biosDepsCallable :: Maybe Callable
biosDepsCallable =
            Maybe Callable -> Maybe Callable -> Maybe Callable
forall a. Maybe a -> Maybe a -> Maybe a
exclusive
                ((String -> Callable) -> Text -> Maybe Callable
forall t. (String -> t) -> Text -> Maybe t
stringTypeFromMap String -> Callable
Program Text
"dependency-program")
                ((String -> Callable) -> Text -> Maybe Callable
forall t. (String -> t) -> Text -> Maybe t
stringTypeFromMap String -> Callable
Command Text
"dependency-shell")
        ghcPath :: Maybe String
ghcPath =
            ShowS -> Text -> Maybe String
forall t. (String -> t) -> Text -> Maybe t
stringTypeFromMap ShowS
forall a. a -> a
id Text
"with-ghc"

        exclusive :: Maybe a -> Maybe a -> Maybe a
        exclusive :: Maybe a -> Maybe a -> Maybe a
exclusive (Just a
_) (Just a
_) = Maybe a
forall a. Maybe a
Nothing
        exclusive Maybe a
l Maybe a
Nothing = Maybe a
l
        exclusive Maybe a
Nothing Maybe a
r = Maybe a
r
        stringTypeFromMap :: (String -> t) -> T.Text -> Maybe t
        stringTypeFromMap :: (String -> t) -> Text -> Maybe t
stringTypeFromMap String -> t
constructor Text
name = String -> t
constructor (String -> t) -> Maybe String -> Maybe t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Maybe String
intoString (Value -> Maybe String) -> Maybe Value -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
name Object
x)
        intoString :: Value -> Maybe String
        intoString :: Value -> Maybe String
intoString (String Text
s) = String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
T.unpack Text
s)
        intoString Value
_ = Maybe String
forall a. Maybe a
Nothing

parseBios Value
_ = String -> Parser (CradleType a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Bios Configuration is expected to be an object."

parseDirect :: Value -> Parser (CradleType a)
parseDirect :: Value -> Parser (CradleType a)
parseDirect (Object Object
x)
    | Object -> Int
forall k v. HashMap k v -> Int
Map.size Object
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    , Just (Array Vector Value
v) <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"arguments" Object
x
    = CradleType a -> Parser (CradleType a)
forall (m :: * -> *) a. Monad m => a -> m a
return (CradleType a -> Parser (CradleType a))
-> CradleType a -> Parser (CradleType a)
forall a b. (a -> b) -> a -> b
$ [String] -> CradleType a
forall a. [String] -> CradleType a
Direct [Text -> String
T.unpack Text
s | String Text
s <- Vector Value -> [Value]
forall a. Vector a -> [a]
V.toList Vector Value
v]

    | Bool
otherwise
    = String -> Parser (CradleType a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Not a valid Direct Configuration type, following keys are allowed: arguments"
parseDirect Value
_ = String -> Parser (CradleType a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Direct Configuration is expected to be an object."

parseMulti :: FromJSON a => Value -> Parser (CradleType a)
parseMulti :: Value -> Parser (CradleType a)
parseMulti (Array Vector Value
x)
    = [(String, CradleConfig a)] -> CradleType a
forall a. [(String, CradleConfig a)] -> CradleType a
Multi ([(String, CradleConfig a)] -> CradleType a)
-> Parser [(String, CradleConfig a)] -> Parser (CradleType a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser (String, CradleConfig a))
-> [Value] -> Parser [(String, CradleConfig a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> Parser (String, CradleConfig a)
forall a. FromJSON a => Value -> Parser (String, CradleConfig a)
parsePath (Vector Value -> [Value]
forall a. Vector a -> [a]
V.toList Vector Value
x)
parseMulti Value
_ = String -> Parser (CradleType a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Multi Configuration is expected to be an array."

parsePath :: FromJSON a => Value -> Parser (FilePath, CradleConfig a)
parsePath :: Value -> Parser (String, CradleConfig a)
parsePath (Object Object
v)
  | Just (String Text
path) <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"path" Object
v
  , Just Value
c <- Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
"config" Object
v
  = (Text -> String
T.unpack Text
path,) (CradleConfig a -> (String, CradleConfig a))
-> Parser (CradleConfig a) -> Parser (String, CradleConfig a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (CradleConfig a)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
c
parsePath Value
o = String -> Parser (String, CradleConfig a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Multi component is expected to be an object." String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
o)

instance FromJSON a => FromJSON (CradleConfig a) where
    parseJSON :: Value -> Parser (CradleConfig a)
parseJSON (Object Object
val) = do
            CradleType a
crd     <- Object
val Object -> Text -> Parser (CradleType a)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"cradle"
            [String]
crdDeps <- case Object -> Int
forall k v. HashMap k v -> Int
Map.size Object
val of
                Int
1 -> [String] -> Parser [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                Int
2 -> Object
val Object -> Text -> Parser [String]
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"dependencies"
                Int
_ -> String -> Parser [String]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unknown key, following keys are allowed: cradle, dependencies"

            CradleConfig a -> Parser (CradleConfig a)
forall (m :: * -> *) a. Monad m => a -> m a
return (CradleConfig a -> Parser (CradleConfig a))
-> CradleConfig a -> Parser (CradleConfig a)
forall a b. (a -> b) -> a -> b
$ CradleConfig :: forall a. [String] -> CradleType a -> CradleConfig a
CradleConfig { cradleType :: CradleType a
cradleType         = CradleType a
crd
                                  , cradleDependencies :: [String]
cradleDependencies = [String]
crdDeps
                                  }

    parseJSON Value
_ = String -> Parser (CradleConfig a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected a cradle: key containing the preferences, possible values: cradle, dependencies"


instance FromJSON a => FromJSON (Config a) where
    parseJSON :: Value -> Parser (Config a)
parseJSON Value
o = CradleConfig a -> Config a
forall a. CradleConfig a -> Config a
Config (CradleConfig a -> Config a)
-> Parser (CradleConfig a) -> Parser (Config a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (CradleConfig a)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
o


-- | Decode given file to a 'Config a' value.
-- Type variable 'a' can be used to extend the 'hie.yaml' file format
-- to extend configuration in the user-library.
-- If the contents of the file is not a valid 'Config a',
-- an 'Control.Exception.IOException' is thrown.
readConfig :: FromJSON a => FilePath -> IO (Config a)
readConfig :: String -> IO (Config a)
readConfig String
fp = do
    Either ParseException ([Warning], Config a)
result <- String -> IO (Either ParseException ([Warning], Config a))
forall a.
FromJSON a =>
String -> IO (Either ParseException ([Warning], a))
decodeFileWithWarnings String
fp
    (ParseException -> IO (Config a))
-> (([Warning], Config a) -> IO (Config a))
-> Either ParseException ([Warning], Config a)
-> IO (Config a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseException -> IO (Config a)
forall e a. Exception e => e -> IO a
throwIO ([Warning], Config a) -> IO (Config a)
forall a. ([Warning], Config a) -> IO (Config a)
failOnAnyDuplicate Either ParseException ([Warning], Config a)
result
    where
        failOnAnyDuplicate :: ([Warning], Config a) -> IO (Config a)
        failOnAnyDuplicate :: ([Warning], Config a) -> IO (Config a)
failOnAnyDuplicate ([Warning]
warnings, Config a
config) = do
            ()
_ <- case (Warning -> Maybe JSONPath) -> [Warning] -> [JSONPath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Warning -> Maybe JSONPath
failOnDuplicate [Warning]
warnings of
                    dups :: [JSONPath]
dups@(JSONPath
_:[JSONPath]
_) -> ParseException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ParseException -> IO ()) -> ParseException -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe YamlException -> ParseException
InvalidYaml (Maybe YamlException -> ParseException)
-> Maybe YamlException -> ParseException
forall a b. (a -> b) -> a -> b
$ YamlException -> Maybe YamlException
forall a. a -> Maybe a
Just (YamlException -> Maybe YamlException)
-> YamlException -> Maybe YamlException
forall a b. (a -> b) -> a -> b
$ String -> YamlException
YamlException
                                          (String -> YamlException) -> String -> YamlException
forall a b. (a -> b) -> a -> b
$ String
"Duplicate keys are not allowed, found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [JSONPath] -> String
forall a. Show a => a -> String
show [JSONPath]
dups
                    [JSONPath]
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Config a -> IO (Config a)
forall (m :: * -> *) a. Monad m => a -> m a
return Config a
config
        -- future proofing in case more warnings are added
        failOnDuplicate :: Warning -> Maybe JSONPath
        failOnDuplicate :: Warning -> Maybe JSONPath
failOnDuplicate (DuplicateKey JSONPath
a) = JSONPath -> Maybe JSONPath
forall a. a -> Maybe a
Just JSONPath
a