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

import Control.Exception
import           Data.Maybe (mapMaybe, fromMaybe)
import           Data.Monoid (Last(..))
import           Data.Aeson (JSONPath)
import           Data.Yaml
import           Data.Yaml.Internal (Warning(..))

import           HIE.Bios.Config.YAML (CradleConfigYAML)
import qualified HIE.Bios.Config.YAML as YAML


-- | 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 { forall a. Config a -> CradleConfig a
cradle :: CradleConfig a }
    deriving (Int -> Config a -> ShowS
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
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, 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
<$ :: forall a b. a -> Config b -> Config a
$c<$ :: forall a b. a -> Config b -> Config a
fmap :: forall a b. (a -> b) -> Config a -> Config b
$cfmap :: forall a b. (a -> b) -> Config a -> Config b
Functor)

data CradleConfig a =
    CradleConfig
        { forall a. 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.
        , forall a. CradleConfig a -> CradleTree a
cradleTree :: CradleTree a
        -- ^ Type of the cradle to use. Actions to obtain
        -- compiler flags from are dependant on this field.
        }
        deriving (Int -> CradleConfig a -> ShowS
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
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, 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
<$ :: forall a b. a -> CradleConfig b -> CradleConfig a
$c<$ :: forall a b. a -> CradleConfig b -> CradleConfig a
fmap :: forall a b. (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
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
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)

-- | A cabal yaml configuration consists of component configuration and project configuration.
--
-- The former specifies how we can find the compilation flags for any filepath
-- in the project.
-- There might be an explicit mapping from source directories to components,
-- or we let cabal figure it out on its own.
--
-- Project configuration is the 'cabal.project' file, we is by default named
-- 'cabal.project'. We allow to override that name to have an HLS specific
-- project configuration file.
data CabalType
    = CabalType_ { CabalType -> Last String
_cabalComponent :: !(Last String), CabalType -> Last String
_cabalProjectFile :: !(Last FilePath) }
    deriving (CabalType -> CabalType -> Bool
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_ Last String
cr Last String
cpr <> :: CabalType -> CabalType -> CabalType
<> CabalType_ Last String
cl Last String
cpl = Last String -> Last String -> CabalType
CabalType_ (Last String
cr forall a. Semigroup a => a -> a -> a
<> Last String
cl) (Last String
cpr forall a. Semigroup a => a -> a -> a
<> Last String
cpl)

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

pattern CabalType :: Maybe String -> Maybe FilePath -> CabalType
pattern $bCabalType :: Maybe String -> Maybe String -> CabalType
$mCabalType :: forall {r}.
CabalType
-> (Maybe String -> Maybe String -> r) -> ((# #) -> r) -> r
CabalType { CabalType -> Maybe String
cabalComponent, CabalType -> Maybe String
cabalProjectFile } = CabalType_ (Last cabalComponent) (Last cabalProjectFile)
{-# COMPLETE CabalType #-}

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

data StackType
    = StackType_ { StackType -> Last String
_stackComponent :: !(Last String) , StackType -> Last String
_stackYaml :: !(Last String) }
    deriving (StackType -> StackType -> Bool
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_ Last String
cr Last String
yr <> :: StackType -> StackType -> StackType
<> StackType_ Last String
cl Last String
yl = Last String -> Last String -> StackType
StackType_ (Last String
cr forall a. Semigroup a => a -> a -> a
<> Last String
cl) (Last String
yr forall a. Semigroup a => a -> a -> a
<> Last String
yl)

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

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

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

data CradleTree a
    = Cabal { forall a. CradleTree a -> CabalType
cabalType :: !CabalType }
    | CabalMulti { forall a. CradleTree a -> CabalType
defaultCabal :: !CabalType, forall a. CradleTree a -> [(String, CabalType)]
subCabalComponents :: [ (FilePath, CabalType) ] }
    | Stack { forall a. CradleTree a -> StackType
stackType :: !StackType }
    | StackMulti { forall a. CradleTree a -> StackType
defaultStack :: !StackType, forall a. CradleTree 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
        { forall a. CradleTree a -> Callable
call :: Callable
        -- ^ Path to program or shell command that retrieves options to compile a file
        , forall a. CradleTree 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.
        , forall a. CradleTree a -> Maybe String
ghcPath :: Maybe FilePath
        -- ^ Optional path to the ghc binary
        }
    | Direct { forall a. CradleTree a -> [String]
arguments :: [String] }
    | None
    | Multi [ (FilePath, CradleConfig a) ]
    | Other { forall a. CradleTree a -> a
otherConfig :: a, forall a. CradleTree a -> Value
originalYamlValue :: Value }
    deriving (CradleTree a -> CradleTree a -> Bool
forall a. Eq a => CradleTree a -> CradleTree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CradleTree a -> CradleTree a -> Bool
$c/= :: forall a. Eq a => CradleTree a -> CradleTree a -> Bool
== :: CradleTree a -> CradleTree a -> Bool
$c== :: forall a. Eq a => CradleTree a -> CradleTree a -> Bool
Eq, forall a b. a -> CradleTree b -> CradleTree a
forall a b. (a -> b) -> CradleTree a -> CradleTree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> CradleTree b -> CradleTree a
$c<$ :: forall a b. a -> CradleTree b -> CradleTree a
fmap :: forall a b. (a -> b) -> CradleTree a -> CradleTree b
$cfmap :: forall a b. (a -> b) -> CradleTree a -> CradleTree b
Functor)

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

readConfig :: FromJSON a => FilePath -> IO (Config a)
readConfig :: forall a. FromJSON a => String -> IO (Config a)
readConfig String
fp = do
  Either ParseException ([Warning], CradleConfigYAML a)
result <- forall a.
FromJSON a =>
String -> IO (Either ParseException ([Warning], a))
decodeFileWithWarnings String
fp
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. CradleConfigYAML a -> Config a
fromYAMLConfig forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall a.
([Warning], CradleConfigYAML a) -> IO (CradleConfigYAML a)
failOnAnyDuplicate Either ParseException ([Warning], CradleConfigYAML a)
result
  where
    failOnAnyDuplicate :: ([Warning], CradleConfigYAML a) -> IO (CradleConfigYAML a)
    failOnAnyDuplicate :: forall a.
([Warning], CradleConfigYAML a) -> IO (CradleConfigYAML a)
failOnAnyDuplicate ([Warning]
warnings, CradleConfigYAML a
config) = do
        ()
_ <- case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Warning -> Maybe JSONPath
failOnDuplicate [Warning]
warnings of
                dups :: [JSONPath]
dups@(JSONPath
_:[JSONPath]
_) -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Maybe YamlException -> ParseException
InvalidYaml forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String -> YamlException
YamlException
                                      forall a b. (a -> b) -> a -> b
$ String
"Duplicate keys are not allowed, found: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [JSONPath]
dups
                [JSONPath]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        forall (m :: * -> *) a. Monad m => a -> m a
return CradleConfigYAML a
config
    -- future proofing in case more warnings are added
    failOnDuplicate :: Warning -> Maybe JSONPath
    failOnDuplicate :: Warning -> Maybe JSONPath
failOnDuplicate (DuplicateKey JSONPath
a) = forall a. a -> Maybe a
Just JSONPath
a

fromYAMLConfig :: CradleConfigYAML a -> Config a
fromYAMLConfig :: forall a. CradleConfigYAML a -> Config a
fromYAMLConfig CradleConfigYAML a
cradleYAML = forall a. CradleConfig a -> Config a
Config forall a b. (a -> b) -> a -> b
$ forall a. [String] -> CradleTree a -> CradleConfig a
CradleConfig (forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall a. CradleConfigYAML a -> Maybe [String]
YAML.dependencies CradleConfigYAML a
cradleYAML)
                                                  (forall a. CradleComponent a -> CradleTree a
toCradleTree forall a b. (a -> b) -> a -> b
$ forall a. CradleConfigYAML a -> CradleComponent a
YAML.cradle CradleConfigYAML a
cradleYAML)

toCradleTree :: YAML.CradleComponent a -> CradleTree a
toCradleTree :: forall a. CradleComponent a -> CradleTree a
toCradleTree (YAML.Multi [MultiSubComponent a]
cpts)  =
  forall a. [(String, CradleConfig a)] -> CradleTree a
Multi forall a b. (a -> b) -> a -> b
$ (\(YAML.MultiSubComponent String
fp' CradleConfigYAML a
cfg) -> (String
fp', forall a. Config a -> CradleConfig a
cradle forall a b. (a -> b) -> a -> b
$ forall a. CradleConfigYAML a -> Config a
fromYAMLConfig CradleConfigYAML a
cfg)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MultiSubComponent a]
cpts
toCradleTree (YAML.Stack (YAML.StackConfig Maybe String
yaml OneOrManyComponents StackComponent
cpts)) =
  case OneOrManyComponents StackComponent
cpts of
    OneOrManyComponents StackComponent
YAML.NoComponent          -> forall a. StackType -> CradleTree a
Stack forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> StackType
StackType forall a. Maybe a
Nothing Maybe String
yaml
    (YAML.SingleComponent String
c)  -> forall a. StackType -> CradleTree a
Stack forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> StackType
StackType (forall a. a -> Maybe a
Just String
c) Maybe String
yaml
    (YAML.ManyComponents [StackComponent]
cs)  -> forall a. StackType -> [(String, StackType)] -> CradleTree a
StackMulti (Maybe String -> Maybe String -> StackType
StackType forall a. Maybe a
Nothing Maybe String
yaml)
                                            ((\(YAML.StackComponent String
fp' String
c Maybe String
cYAML) ->
                                              (String
fp', Maybe String -> Maybe String -> StackType
StackType (forall a. a -> Maybe a
Just String
c) Maybe String
cYAML)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StackComponent]
cs)
toCradleTree (YAML.Cabal (YAML.CabalConfig Maybe String
prjFile OneOrManyComponents CabalComponent
cpts)) =
  case OneOrManyComponents CabalComponent
cpts of
    OneOrManyComponents CabalComponent
YAML.NoComponent          -> forall a. CabalType -> CradleTree a
Cabal forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> CabalType
CabalType forall a. Maybe a
Nothing Maybe String
prjFile
    (YAML.SingleComponent String
c)  -> forall a. CabalType -> CradleTree a
Cabal forall a b. (a -> b) -> a -> b
$ Maybe String -> Maybe String -> CabalType
CabalType (forall a. a -> Maybe a
Just String
c) Maybe String
prjFile
    (YAML.ManyComponents [CabalComponent]
cs)  -> forall a. CabalType -> [(String, CabalType)] -> CradleTree a
CabalMulti (Maybe String -> Maybe String -> CabalType
CabalType forall a. Maybe a
Nothing Maybe String
prjFile)
                                            ((\(YAML.CabalComponent String
fp' String
c Maybe String
cPrjFile) ->
                                              (String
fp', Maybe String -> Maybe String -> CabalType
CabalType (forall a. a -> Maybe a
Just String
c) Maybe String
cPrjFile)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CabalComponent]
cs)
toCradleTree (YAML.Direct DirectConfig
cfg)  = forall a. [String] -> CradleTree a
Direct (DirectConfig -> [String]
YAML.arguments DirectConfig
cfg)
toCradleTree (YAML.Bios BiosConfig
cfg)    = forall a.
Callable -> Maybe Callable -> Maybe String -> CradleTree a
Bios  (Callable -> Callable
toCallable forall a b. (a -> b) -> a -> b
$ BiosConfig -> Callable
YAML.callable BiosConfig
cfg)
                                        (Callable -> Callable
toCallable forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BiosConfig -> Maybe Callable
YAML.depsCallable BiosConfig
cfg)
                                        (BiosConfig -> Maybe String
YAML.ghcPath BiosConfig
cfg)
toCradleTree (YAML.None NoneConfig
_)      = forall a. CradleTree a
None
toCradleTree (YAML.Other OtherConfig a
cfg)   = forall a. a -> Value -> CradleTree a
Other (forall a. OtherConfig a -> a
YAML.otherConfig OtherConfig a
cfg)
                                        (forall a. OtherConfig a -> Value
YAML.originalYamlValue OtherConfig a
cfg)

toCallable :: YAML.Callable -> Callable
toCallable :: Callable -> Callable
toCallable (YAML.Program String
p) = String -> Callable
Program String
p
toCallable (YAML.Shell String
c)   = String -> Callable
Command String
c