{-# 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 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 -> [Char]
(Int -> SetupHooksException -> ShowS)
-> (SetupHooksException -> [Char])
-> ([SetupHooksException] -> ShowS)
-> Show SetupHooksException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SetupHooksException -> ShowS
showsPrec :: Int -> SetupHooksException -> ShowS
$cshow :: SetupHooksException -> [Char]
show :: SetupHooksException -> [Char]
$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 -> [Char]
(Int -> CannotApplyComponentDiffReason -> ShowS)
-> (CannotApplyComponentDiffReason -> [Char])
-> ([CannotApplyComponentDiffReason] -> ShowS)
-> Show CannotApplyComponentDiffReason
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CannotApplyComponentDiffReason -> ShowS
showsPrec :: Int -> CannotApplyComponentDiffReason -> ShowS
$cshow :: CannotApplyComponentDiffReason -> [Char]
show :: CannotApplyComponentDiffReason -> [Char]
$cshowList :: [CannotApplyComponentDiffReason] -> ShowS
showList :: [CannotApplyComponentDiffReason] -> ShowS
Show)

data IllegalComponentDiffReason
  = CannotChangeName
  | CannotChangeComponentField String
  | CannotChangeBuildInfoField String
  deriving (Int -> IllegalComponentDiffReason -> ShowS
[IllegalComponentDiffReason] -> ShowS
IllegalComponentDiffReason -> [Char]
(Int -> IllegalComponentDiffReason -> ShowS)
-> (IllegalComponentDiffReason -> [Char])
-> ([IllegalComponentDiffReason] -> ShowS)
-> Show IllegalComponentDiffReason
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IllegalComponentDiffReason -> ShowS
showsPrec :: Int -> IllegalComponentDiffReason -> ShowS
$cshow :: IllegalComponentDiffReason -> [Char]
show :: IllegalComponentDiffReason -> [Char]
$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 -> [Char]
setupHooksExceptionMessage = \case
  CannotApplyComponentDiff CannotApplyComponentDiffReason
reason ->
    CannotApplyComponentDiffReason -> [Char]
cannotApplyComponentDiffMessage CannotApplyComponentDiffReason
reason
  RulesException RulesException
reason ->
    RulesException -> [Char]
rulesExceptionMessage RulesException
reason

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

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

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

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