{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}

-----------------------------------------------------------------------------

-- Module      :  Distribution.Simple.SetupHooks.Errors
-- Copyright   :
-- License     :
--
-- Maintainer  :
-- Portability :
--
-- Exceptions for the Hooks build-type.

module Distribution.Simple.SetupHooks.Errors
  ( SetupHooksException (..)
  , CannotApplyComponentDiffReason (..)
  , IllegalComponentDiffReason (..)
  , RulesException (..)
  , setupHooksExceptionCode
  , setupHooksExceptionMessage
  ) where

import Distribution.PackageDescription
import Distribution.Simple.SetupHooks.Rule
import qualified Distribution.Simple.SetupHooks.Rule as Rule
import Distribution.Types.Component

import qualified Data.Graph as Graph
import Data.List
  ( intercalate
  )
import qualified Data.List.NonEmpty as NE
import qualified Data.Tree as Tree

--------------------------------------------------------------------------------

-- | An error involving the @SetupHooks@ module of a package with
-- Hooks build-type.
data SetupHooksException
  = -- | Cannot apply a diff to a component in a per-component configure hook.
    CannotApplyComponentDiff CannotApplyComponentDiffReason
  | -- | An error with pre-build rules.
    RulesException RulesException
  deriving (Int -> SetupHooksException -> ShowS
[SetupHooksException] -> ShowS
SetupHooksException -> String
(Int -> SetupHooksException -> ShowS)
-> (SetupHooksException -> String)
-> ([SetupHooksException] -> ShowS)
-> Show SetupHooksException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SetupHooksException -> ShowS
showsPrec :: Int -> SetupHooksException -> ShowS
$cshow :: SetupHooksException -> String
show :: SetupHooksException -> String
$cshowList :: [SetupHooksException] -> ShowS
showList :: [SetupHooksException] -> ShowS
Show)

-- | AN error involving the @Rules@ in the @SetupHooks@ module of a
-- package with the Hooks build-type.
data RulesException
  = -- | There are cycles in the dependency graph of fine-grained rules.
    CyclicRuleDependencies
      (NE.NonEmpty (RuleBinary, [Graph.Tree RuleBinary]))
  | -- | When executing fine-grained rules compiled into the external hooks
    -- executable, we failed to find dependencies of a rule.
    CantFindSourceForRuleDependencies
      RuleBinary
      (NE.NonEmpty Rule.Location)
      -- ^ missing dependencies
  | -- | When executing fine-grained rules compiled into the external hooks
    -- executable, a rule failed to generate the outputs it claimed it would.
    MissingRuleOutputs
      RuleBinary
      (NE.NonEmpty Rule.Location)
      -- ^ missing outputs
  | -- | An invalid reference to a rule output, e.g. an out-of-range
    -- index.
    InvalidRuleOutputIndex
      RuleId
      -- ^ rule
      RuleId
      -- ^ dependency
      (NE.NonEmpty Rule.Location)
      -- ^ outputs of dependency
      Word
      -- ^ the invalid index
  | -- | A duplicate 'RuleId' in the construction of pre-build rules.
    DuplicateRuleId !RuleId !Rule !Rule

deriving instance Show RulesException

data CannotApplyComponentDiffReason
  = MismatchedComponentTypes Component Component
  | IllegalComponentDiff Component (NE.NonEmpty IllegalComponentDiffReason)
  deriving (Int -> CannotApplyComponentDiffReason -> ShowS
[CannotApplyComponentDiffReason] -> ShowS
CannotApplyComponentDiffReason -> String
(Int -> CannotApplyComponentDiffReason -> ShowS)
-> (CannotApplyComponentDiffReason -> String)
-> ([CannotApplyComponentDiffReason] -> ShowS)
-> Show CannotApplyComponentDiffReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CannotApplyComponentDiffReason -> ShowS
showsPrec :: Int -> CannotApplyComponentDiffReason -> ShowS
$cshow :: CannotApplyComponentDiffReason -> String
show :: CannotApplyComponentDiffReason -> String
$cshowList :: [CannotApplyComponentDiffReason] -> ShowS
showList :: [CannotApplyComponentDiffReason] -> ShowS
Show)

data IllegalComponentDiffReason
  = CannotChangeName
  | CannotChangeComponentField String
  | CannotChangeBuildInfoField String
  deriving (Int -> IllegalComponentDiffReason -> ShowS
[IllegalComponentDiffReason] -> ShowS
IllegalComponentDiffReason -> String
(Int -> IllegalComponentDiffReason -> ShowS)
-> (IllegalComponentDiffReason -> String)
-> ([IllegalComponentDiffReason] -> ShowS)
-> Show IllegalComponentDiffReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IllegalComponentDiffReason -> ShowS
showsPrec :: Int -> IllegalComponentDiffReason -> ShowS
$cshow :: IllegalComponentDiffReason -> String
show :: IllegalComponentDiffReason -> String
$cshowList :: [IllegalComponentDiffReason] -> ShowS
showList :: [IllegalComponentDiffReason] -> ShowS
Show)

setupHooksExceptionCode :: SetupHooksException -> Int
setupHooksExceptionCode :: SetupHooksException -> Int
setupHooksExceptionCode = \case
  CannotApplyComponentDiff CannotApplyComponentDiffReason
rea ->
    CannotApplyComponentDiffReason -> Int
cannotApplyComponentDiffCode CannotApplyComponentDiffReason
rea
  RulesException RulesException
rea ->
    RulesException -> Int
rulesExceptionCode RulesException
rea

rulesExceptionCode :: RulesException -> Int
rulesExceptionCode :: RulesException -> Int
rulesExceptionCode = \case
  CyclicRuleDependencies{} -> Int
9077
  CantFindSourceForRuleDependencies{} -> Int
1071
  MissingRuleOutputs{} -> Int
3498
  InvalidRuleOutputIndex{} -> Int
1173
  DuplicateRuleId{} -> Int
7717

setupHooksExceptionMessage :: SetupHooksException -> String
setupHooksExceptionMessage :: SetupHooksException -> String
setupHooksExceptionMessage = \case
  CannotApplyComponentDiff CannotApplyComponentDiffReason
reason ->
    CannotApplyComponentDiffReason -> String
cannotApplyComponentDiffMessage CannotApplyComponentDiffReason
reason
  RulesException RulesException
reason ->
    RulesException -> String
rulesExceptionMessage RulesException
reason

rulesExceptionMessage :: RulesException -> String
rulesExceptionMessage :: RulesException -> String
rulesExceptionMessage = \case
  CyclicRuleDependencies NonEmpty (RuleBinary, [Tree RuleBinary])
cycles ->
    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
      (String
"Hooks: cycle" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
plural String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in dependency structure of rules:")
        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((RuleBinary, [Tree RuleBinary]) -> String)
-> [(RuleBinary, [Tree RuleBinary])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (RuleBinary, [Tree RuleBinary]) -> String
showCycle (NonEmpty (RuleBinary, [Tree RuleBinary])
-> [(RuleBinary, [Tree RuleBinary])]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (RuleBinary, [Tree RuleBinary])
cycles)
    where
      plural :: String
      plural :: String
plural
        | NonEmpty (RuleBinary, [Tree RuleBinary]) -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty (RuleBinary, [Tree RuleBinary])
cycles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 =
            String
"s"
        | Bool
otherwise =
            String
""
      showCycle :: (RuleBinary, [Graph.Tree RuleBinary]) -> String
      showCycle :: (RuleBinary, [Tree RuleBinary]) -> String
showCycle (RuleBinary
r, [Tree RuleBinary]
rs) =
        [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          Tree String -> String
Tree.drawTree (Tree String -> String) -> Tree String -> String
forall a b. (a -> b) -> a -> b
$
            (RuleBinary -> String) -> Tree RuleBinary -> Tree String
forall a b. (a -> b) -> Tree a -> Tree b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RuleBinary -> String
showRule (Tree RuleBinary -> Tree String) -> Tree RuleBinary -> Tree String
forall a b. (a -> b) -> a -> b
$
              RuleBinary -> [Tree RuleBinary] -> Tree RuleBinary
forall a. a -> [Tree a] -> Tree a
Tree.Node RuleBinary
r [Tree RuleBinary]
rs
  CantFindSourceForRuleDependencies RuleBinary
_r NonEmpty Location
deps ->
    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
      (String
"Pre-build rules: can't find source for rule " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":")
        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Location -> String) -> [Location] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Location
d -> String
"  - " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Location -> String
forall a. Show a => a -> String
show Location
d) [Location]
depsL
    where
      depsL :: [Location]
depsL = NonEmpty Location -> [Location]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Location
deps
      what :: String
what
        | [Location] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Location]
depsL Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 =
            String
"dependency"
        | Bool
otherwise =
            String
"dependencies"
  MissingRuleOutputs RuleBinary
_r NonEmpty Location
reslts ->
    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
      (String
"Pre-build rule did not generate expected result" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
plural String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":")
        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Location -> String) -> [Location] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Location
res -> String
"  - " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Location -> String
forall a. Show a => a -> String
show Location
res) [Location]
resultsL
    where
      resultsL :: [Location]
resultsL = NonEmpty Location -> [Location]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Location
reslts
      plural :: String
plural
        | [Location] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Location]
resultsL Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 =
            String
""
        | Bool
otherwise =
            String
"s"
  InvalidRuleOutputIndex RuleId
rId RuleId
depRuleId NonEmpty Location
outputs Word
i -> [String] -> String
unlines [String
header, String
body]
    where
      header :: String
header = String
"Invalid index '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' in dependency of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ RuleId -> String
forall a. Show a => a -> String
show RuleId
rId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
      nbOutputs :: Int
nbOutputs = NonEmpty Location -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty Location
outputs
      body :: String
body
        | (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i :: Int) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 =
            [String] -> String
unwords
              [ String
"The dependency"
              , RuleId -> String
forall a. Show a => a -> String
show RuleId
depRuleId
              , String
"only has"
              , Int -> String
forall a. Show a => a -> String
show Int
nbOutputs
              , String
"output" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
plural String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
              ]
        | Bool
otherwise =
            String
"The index is too large."
      plural :: String
plural = if Int
nbOutputs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then String
"" else String
"s"
  DuplicateRuleId RuleId
rId Rule
r1 Rule
r2 ->
    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
      [ String
"Duplicate pre-build rule (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> RuleId -> String
forall a. Show a => a -> String
show RuleId
rId String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
      , String
"  - " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> RuleBinary -> String
showRule (Rule -> RuleBinary
ruleBinary Rule
r1)
      , String
"  - " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> RuleBinary -> String
showRule (Rule -> RuleBinary
ruleBinary Rule
r2)
      ]
  where
    showRule :: RuleBinary -> String
    showRule :: RuleBinary -> String
showRule (Rule{staticDependencies :: forall (scope :: Scope). RuleData scope -> [Dependency]
staticDependencies = [Dependency]
deps, results :: forall (scope :: Scope). RuleData scope -> NonEmpty Location
results = NonEmpty Location
reslts}) =
      String
"Rule: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Dependency] -> String
showDeps [Dependency]
deps String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" --> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Location] -> String
forall a. Show a => a -> String
show (NonEmpty Location -> [Location]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Location
reslts)

showDeps :: [Rule.Dependency] -> String
showDeps :: [Dependency] -> String
showDeps [Dependency]
deps = String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Dependency -> String) -> [Dependency] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> String
showDep [Dependency]
deps) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"

showDep :: Rule.Dependency -> String
showDep :: Dependency -> String
showDep = \case
  RuleDependency (RuleOutput{outputOfRule :: RuleOutput -> RuleId
outputOfRule = RuleId
rId, outputIndex :: RuleOutput -> Word
outputIndex = Word
i}) ->
    String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ RuleId -> String
forall a. Show a => a -> String
show RuleId
rId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
  FileDependency Location
loc -> Location -> String
forall a. Show a => a -> String
show Location
loc

cannotApplyComponentDiffCode :: CannotApplyComponentDiffReason -> Int
cannotApplyComponentDiffCode :: CannotApplyComponentDiffReason -> Int
cannotApplyComponentDiffCode = \case
  MismatchedComponentTypes{} -> Int
9491
  IllegalComponentDiff{} -> Int
7634

cannotApplyComponentDiffMessage :: CannotApplyComponentDiffReason -> String
cannotApplyComponentDiffMessage :: CannotApplyComponentDiffReason -> String
cannotApplyComponentDiffMessage = \case
  MismatchedComponentTypes Component
comp Component
diff ->
    [String] -> String
unlines
      [ String
"Hooks: mismatched component types in per-component configure hook."
      , String
"Trying to apply " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" diff to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
to String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
      ]
    where
      what :: String
what = case Component
diff of
        CLib{} -> String
"a library"
        CFLib{} -> String
"a foreign library"
        CExe{} -> String
"an executable"
        CTest{} -> String
"a testsuite"
        CBench{} -> String
"a benchmark"
      to :: String
to = case Component -> ComponentName
componentName Component
comp of
        nm :: ComponentName
nm@(CExeName{}) -> String
"an " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ComponentName -> String
showComponentName ComponentName
nm
        ComponentName
nm -> String
"a " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ComponentName -> String
showComponentName ComponentName
nm
  IllegalComponentDiff Component
comp NonEmpty IllegalComponentDiffReason
reasons ->
    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
      (String
"Hooks: illegal component diff in per-component pre-configure hook for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
what String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":")
        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (IllegalComponentDiffReason -> String)
-> [IllegalComponentDiffReason] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map IllegalComponentDiffReason -> String
mk_rea (NonEmpty IllegalComponentDiffReason -> [IllegalComponentDiffReason]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty IllegalComponentDiffReason
reasons)
    where
      mk_rea :: IllegalComponentDiffReason -> String
mk_rea IllegalComponentDiffReason
err = String
"  - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IllegalComponentDiffReason -> String
illegalComponentDiffMessage IllegalComponentDiffReason
err String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
      what :: String
what = case Component -> ComponentName
componentName Component
comp of
        CLibName LibraryName
LMainLibName -> String
"main library"
        ComponentName
nm -> ComponentName -> String
showComponentName ComponentName
nm

illegalComponentDiffMessage :: IllegalComponentDiffReason -> String
illegalComponentDiffMessage :: IllegalComponentDiffReason -> String
illegalComponentDiffMessage = \case
  IllegalComponentDiffReason
CannotChangeName ->
    String
"cannot change the name of a component"
  CannotChangeComponentField String
fld ->
    String
"cannot change component field '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fld String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"
  CannotChangeBuildInfoField String
fld ->
    String
"cannot change BuildInfo field '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fld String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"