{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE CPP                   #-}

-- | Datatypes for parsing @hie.yaml@ files
module HIE.Bios.Config.YAML
  ( CradleConfigYAML(..)
  , CradleComponent(..)
  , MultiSubComponent(..)
  , CabalConfig(..)
  , CabalComponent(..)
  , StackConfig(..)
  , StackComponent(..)
  , DirectConfig(..)
  , BiosConfig(..)
  , NoneConfig(..)
  , OtherConfig(..)
  , OneOrManyComponents(..)
  , Callable(..)
  ) where

import           Control.Applicative ((<|>))
import           Data.Aeson
#if MIN_VERSION_aeson(2,0,0)
import           Data.Aeson.KeyMap   (keys)
#else
import qualified Data.HashMap.Strict as Map
import qualified Data.Text           as T
#endif
import           Data.Aeson.Types    (Object, Parser, Value (Null),
                                      typeMismatch)
import qualified Data.Char           as C (toLower)
import           Data.List           ((\\))
import           GHC.Generics        (Generic)

#if !MIN_VERSION_aeson(2,0,0)
-- | Backwards compatible type-def for Key
-- This used to be just a Text, but since aeson >= 2
-- this is an opaque datatype.
type Key = T.Text
-- | Backwards compatible type-def for KeyMap
-- This used to be just a HashMap, but since aeson >= 2
-- this is an opaque datatype.
type KeyMap v = Map.HashMap T.Text v
 
keys :: KeyMap v -> [Key]
keys = Map.keys
#endif

checkObjectKeys :: [Key] -> Object -> Parser ()
checkObjectKeys :: [Key] -> Object -> Parser ()
checkObjectKeys [Key]
allowedKeys Object
obj =
  let extraKeys :: [Key]
extraKeys = forall v. KeyMap v -> [Key]
keys Object
obj forall a. Eq a => [a] -> [a] -> [a]
\\ [Key]
allowedKeys
   in case [Key]
extraKeys of
        []          -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        [Key]
_           -> forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [ FilePath
"Unexpected keys "
                                      , forall a. Show a => a -> FilePath
show [Key]
extraKeys
                                      , FilePath
", keys allowed: "
                                      , forall a. Show a => a -> FilePath
show [Key]
allowedKeys
                                      ]

data CradleConfigYAML a
  = CradleConfigYAML { forall a. CradleConfigYAML a -> CradleComponent a
cradle       :: CradleComponent a
                     , forall a. CradleConfigYAML a -> Maybe [FilePath]
dependencies :: Maybe [FilePath]
                     } deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (CradleConfigYAML a) x -> CradleConfigYAML a
forall a x. CradleConfigYAML a -> Rep (CradleConfigYAML a) x
$cto :: forall a x. Rep (CradleConfigYAML a) x -> CradleConfigYAML a
$cfrom :: forall a x. CradleConfigYAML a -> Rep (CradleConfigYAML a) x
Generic, forall a. FromJSON a => Value -> Parser [CradleConfigYAML a]
forall a. FromJSON a => Value -> Parser (CradleConfigYAML a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CradleConfigYAML a]
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [CradleConfigYAML a]
parseJSON :: Value -> Parser (CradleConfigYAML a)
$cparseJSON :: forall a. FromJSON a => Value -> Parser (CradleConfigYAML a)
FromJSON)

data CradleComponent a
  = Multi [MultiSubComponent a]
  | Cabal CabalConfig
  | Stack StackConfig
  | Direct DirectConfig
  | Bios BiosConfig
  | None NoneConfig
  | Other (OtherConfig a)
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (CradleComponent a) x -> CradleComponent a
forall a x. CradleComponent a -> Rep (CradleComponent a) x
$cto :: forall a x. Rep (CradleComponent a) x -> CradleComponent a
$cfrom :: forall a x. CradleComponent a -> Rep (CradleComponent a) x
Generic)

instance FromJSON a => FromJSON (CradleComponent a) where
  parseJSON :: Value -> Parser (CradleComponent a)
parseJSON = let opts :: Options
opts = Options
defaultOptions { constructorTagModifier :: FilePath -> FilePath
constructorTagModifier = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
C.toLower
                                        , sumEncoding :: SumEncoding
sumEncoding = SumEncoding
ObjectWithSingleField
                                        }
               in forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
opts

data NoneConfig = NoneConfig

data OtherConfig a
  = OtherConfig { forall a. OtherConfig a -> a
otherConfig       :: a
                , forall a. OtherConfig a -> Value
originalYamlValue :: Value
                }

instance FromJSON a => FromJSON (OtherConfig a) where
  parseJSON :: Value -> Parser (OtherConfig a)
parseJSON Value
v = forall a. a -> Value -> OtherConfig a
OtherConfig
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v

instance FromJSON NoneConfig where
  parseJSON :: Value -> Parser NoneConfig
parseJSON Value
Null = forall (f :: * -> *) a. Applicative f => a -> f a
pure NoneConfig
NoneConfig
  parseJSON Value
v    = forall a. FilePath -> Value -> Parser a
typeMismatch FilePath
"NoneConfig" Value
v

data MultiSubComponent a
  = MultiSubComponent { forall a. MultiSubComponent a -> FilePath
path   :: FilePath
                      , forall a. MultiSubComponent a -> CradleConfigYAML a
config :: CradleConfigYAML a
                      } deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (MultiSubComponent a) x -> MultiSubComponent a
forall a x. MultiSubComponent a -> Rep (MultiSubComponent a) x
$cto :: forall a x. Rep (MultiSubComponent a) x -> MultiSubComponent a
$cfrom :: forall a x. MultiSubComponent a -> Rep (MultiSubComponent a) x
Generic, forall a. FromJSON a => Value -> Parser [MultiSubComponent a]
forall a. FromJSON a => Value -> Parser (MultiSubComponent a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MultiSubComponent a]
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [MultiSubComponent a]
parseJSON :: Value -> Parser (MultiSubComponent a)
$cparseJSON :: forall a. FromJSON a => Value -> Parser (MultiSubComponent a)
FromJSON)

data CabalConfig
  = CabalConfig { CabalConfig -> OneOrManyComponents CabalComponent
cabalComponents :: OneOrManyComponents CabalComponent }

instance FromJSON CabalConfig where
  parseJSON :: Value -> Parser CabalConfig
parseJSON v :: Value
v@(Array Array
_)     = OneOrManyComponents CabalComponent -> CabalConfig
CabalConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall component. [component] -> OneOrManyComponents component
ManyComponents forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
  parseJSON v :: Value
v@(Object Object
obj)  = ([Key] -> Object -> Parser ()
checkObjectKeys [Key
"component", Key
"components"] Object
obj) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (OneOrManyComponents CabalComponent -> CabalConfig
CabalConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)
  parseJSON Value
Null            = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ OneOrManyComponents CabalComponent -> CabalConfig
CabalConfig forall component. OneOrManyComponents component
NoComponent
  parseJSON Value
v               = forall a. FilePath -> Value -> Parser a
typeMismatch FilePath
"CabalConfig" Value
v

data CabalComponent
  = CabalComponent { CabalComponent -> FilePath
cabalPath      :: FilePath
                   , CabalComponent -> FilePath
cabalComponent :: String
                   }

instance FromJSON CabalComponent where
  parseJSON :: Value -> Parser CabalComponent
parseJSON =
    let parseCabalComponent :: Object -> Parser CabalComponent
parseCabalComponent Object
obj = [Key] -> Object -> Parser ()
checkObjectKeys [Key
"path", Key
"component"] Object
obj
                                    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (FilePath -> FilePath -> CabalComponent
CabalComponent
                                          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"path"
                                          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"component")
     in forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"CabalComponent" Object -> Parser CabalComponent
parseCabalComponent

data StackConfig
  = StackConfig { StackConfig -> Maybe FilePath
stackYaml       :: Maybe FilePath
                , StackConfig -> OneOrManyComponents StackComponent
stackComponents :: OneOrManyComponents StackComponent
                }

data StackComponent
  = StackComponent { StackComponent -> FilePath
stackPath          :: FilePath
                   , StackComponent -> FilePath
stackComponent     :: String
                   , StackComponent -> Maybe FilePath
stackComponentYAML :: Maybe String
                   }

instance FromJSON StackConfig where
  parseJSON :: Value -> Parser StackConfig
parseJSON v :: Value
v@(Array Array
_)     = Maybe FilePath -> OneOrManyComponents StackComponent -> StackConfig
StackConfig forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall component. [component] -> OneOrManyComponents component
ManyComponents forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
  parseJSON v :: Value
v@(Object Object
obj)  = ([Key] -> Object -> Parser ()
checkObjectKeys [Key
"component", Key
"components", Key
"stackYaml"] Object
obj)
                                forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Maybe FilePath -> OneOrManyComponents StackComponent -> StackConfig
StackConfig
                                      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"stackYaml"
                                      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
                                    )
  parseJSON Value
Null            = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe FilePath -> OneOrManyComponents StackComponent -> StackConfig
StackConfig forall a. Maybe a
Nothing forall component. OneOrManyComponents component
NoComponent
  parseJSON Value
v               = forall a. FilePath -> Value -> Parser a
typeMismatch FilePath
"StackConfig" Value
v

instance FromJSON StackComponent where
  parseJSON :: Value -> Parser StackComponent
parseJSON =
    let parseStackComponent :: Object -> Parser StackComponent
parseStackComponent Object
obj = ([Key] -> Object -> Parser ()
checkObjectKeys [Key
"path", Key
"component", Key
"stackYaml"] Object
obj)
                                    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (FilePath -> FilePath -> Maybe FilePath -> StackComponent
StackComponent
                                          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"path"
                                          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"component"
                                          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"stackYaml")
     in forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"StackComponent" Object -> Parser StackComponent
parseStackComponent

data OneOrManyComponents component
  = SingleComponent String
  | ManyComponents [component]
  | NoComponent

instance FromJSON component => FromJSON (OneOrManyComponents component) where
  parseJSON :: Value -> Parser (OneOrManyComponents component)
parseJSON =
    let parseComponents :: Object -> Parser (OneOrManyComponents component)
parseComponents Object
o = (forall {component}.
Object -> Parser (OneOrManyComponents component)
parseSingleComponent Object
o forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {component}.
FromJSON component =>
Object -> Parser (OneOrManyComponents component)
parseSubComponents Object
o forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall component. OneOrManyComponents component
NoComponent)
        parseSingleComponent :: Object -> Parser (OneOrManyComponents component)
parseSingleComponent Object
o = forall component. FilePath -> OneOrManyComponents component
SingleComponent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"component"
        parseSubComponents :: Object -> Parser (OneOrManyComponents component)
parseSubComponents   Object
o = forall component. [component] -> OneOrManyComponents component
ManyComponents forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"components"
     in forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"Components" forall {component}.
FromJSON component =>
Object -> Parser (OneOrManyComponents component)
parseComponents

data DirectConfig
  = DirectConfig { DirectConfig -> [FilePath]
arguments :: [String] }
  deriving (forall x. Rep DirectConfig x -> DirectConfig
forall x. DirectConfig -> Rep DirectConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DirectConfig x -> DirectConfig
$cfrom :: forall x. DirectConfig -> Rep DirectConfig x
Generic, Value -> Parser [DirectConfig]
Value -> Parser DirectConfig
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [DirectConfig]
$cparseJSONList :: Value -> Parser [DirectConfig]
parseJSON :: Value -> Parser DirectConfig
$cparseJSON :: Value -> Parser DirectConfig
FromJSON)

data BiosConfig =
  BiosConfig { BiosConfig -> Callable
callable     :: Callable
             , BiosConfig -> Maybe Callable
depsCallable :: Maybe Callable
             , BiosConfig -> Maybe FilePath
ghcPath      :: Maybe FilePath
             }

instance FromJSON BiosConfig where
  parseJSON :: Value -> Parser BiosConfig
parseJSON = forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject FilePath
"BiosConfig" Object -> Parser BiosConfig
parseBiosConfig

data Callable
  = Program FilePath
  | Shell String

parseBiosConfig :: Object -> Parser BiosConfig
parseBiosConfig :: Object -> Parser BiosConfig
parseBiosConfig Object
obj =
  let parseCallable :: Object -> Parser Callable
parseCallable Object
o = (FilePath -> Callable
Program forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"program") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (FilePath -> Callable
Shell forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"shell")
      parseDepsCallable :: Object -> Parser (Maybe Callable)
parseDepsCallable Object
o = (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Callable
Program forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"dependency-program")
                            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Callable
Shell forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"dependency-shell")
                            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
      parse :: Object -> Parser BiosConfig
parse Object
o = Callable -> Maybe Callable -> Maybe FilePath -> BiosConfig
BiosConfig  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Parser Callable
parseCallable Object
o
                            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Parser (Maybe Callable)
parseDepsCallable Object
o
                            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"with-ghc")
      check :: Object -> Parser ()
check = [Key] -> Object -> Parser ()
checkObjectKeys [Key
"program", Key
"shell", Key
"dependency-program", Key
"dependency-shell", Key
"with-ghc"]
   in Object -> Parser ()
check Object
obj forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Object -> Parser BiosConfig
parse Object
obj