Types.hs

-- Needed for `deriving Arbitrary via GenericArbitrary DerivationDiff`:
{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}
-- Needed for `deriving instance Data (DerivationOutput StorePath Text)`:
{-# OPTIONS_GHC -Wno-orphans #-}

module Nix.Diff.Types where

import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import Data.Text (Text)
import Nix.Derivation (DerivationOutput (..))
import Nix.Diff.Store ( StorePath )

import qualified Patience
import GHC.Generics (Generic)
import Data.Foldable
import Data.Aeson
import Data.Aeson.Types
import Test.QuickCheck
import Test.QuickCheck.Instances ()
import Test.QuickCheck.Arbitrary.Generic (GenericArbitrary(..))
import Data.Data (Data)

{- ** NOTE: Lawless instances
   All the Arbitrary instances here are written to
   check if `decode . encode == id` rule was broken,
   so they don't respect to internal laws of these types,
   such as "Maps from `extraOutputs` must not have
   intersecting keys" and so on.
   If you want to test these invariants, you have to rewrite
   instances manually.
-}

data Changed a = Changed { before :: a, now :: a }
  deriving stock (Eq, Show, Functor, Foldable, Traversable, Generic, Data)

instance (Arbitrary a) => Arbitrary (Changed a) where
  arbitrary = Changed <$> arbitrary <*> arbitrary
  shrink = genericShrink

instance ToJSON a => ToJSON (Changed a) where
  toJSON = changedToJSON toJSON

instance FromJSON a => FromJSON (Changed a) where
  parseJSON = changedFromJSON parseJSON

newtype TextDiff = TextDiff {unTextDiff :: [Patience.Item Text]}
  deriving stock (Eq, Show, Data)

instance Arbitrary TextDiff where
  arbitrary = TextDiff <$> listOf arbitraryItem

instance ToJSON TextDiff where
  toJSON textDiff = listValue itemToJSON textDiff.unTextDiff

instance FromJSON TextDiff where
  parseJSON v = TextDiff <$> (traverse itemFromJSON =<< parseJSON v)

-- Helpful aliases

type OutputHash = Text

type Platform = Text

type Builder = Text

type Argument = Text

-- | A set of Nix derivation output names.
newtype OutputNames = OutputNames {unOutputNames :: Set Text}
  deriving newtype (Eq, Ord, ToJSON, FromJSON)
  deriving stock (Show, Generic, Data)
  deriving Arbitrary via GenericArbitrary OutputNames

-- Derivation diff

data DerivationDiff
  = DerivationsAreTheSame
  | AlreadyCompared
  | OnlyAlreadyComparedBelow { outputStructure :: Changed OutputStructure}
  | NamesDontMatch           { outputStructure :: Changed OutputStructure}
  | OutputsDontMatch         { outputStructure :: Changed OutputStructure}
  | DerivationDiff
      { outputStructure :: Changed OutputStructure
      , outputsDiff     :: OutputsDiff
      , platformDiff    :: Maybe (Changed Platform)
        -- ^ Will be Nothing, if Platform does not change
      , builderDiff     :: Maybe (Changed Builder)
        -- ^ Will be Nothing, if Builder does not change
      , argumentsDiff   :: Maybe ArgumentsDiff
        -- ^ Will be Nothing, if arguments are equal
      , sourcesDiff     :: SourcesDiff
      , inputsDiff      :: InputsDiff
      , envDiff         :: Maybe EnvironmentDiff
        -- ^ Will be Nothing, if environment comparison is skipped
      }
  deriving stock (Eq, Show, Generic, Data)
  deriving anyclass (ToJSON, FromJSON)
  deriving Arbitrary via GenericArbitrary DerivationDiff

-- Output structure

data OutputStructure = OutputStructure
  { derivationPath :: StorePath
  , derivationOutputs :: OutputNames
  }
  deriving stock (Eq, Show, Generic, Data)
  deriving anyclass (ToJSON, FromJSON)
  deriving Arbitrary via GenericArbitrary OutputStructure

-- ** Outputs diff

data OutputsDiff = OutputsDiff
  { extraOutputs :: Maybe (Changed (Map Text (DerivationOutput StorePath Text)))
    -- ^ Map from derivation name to its outputs.
    --   Will be Nothing, if `Data.Map.difference` gives
    --   empty Maps for both new and old outputs
  , outputHashDiff :: [OutputDiff]
    -- ^ Difference of outputs with the same name.
    --   Will be empty, if all outputs are equal.
  }
  deriving stock (Eq, Show, Data)

deriving instance Data (DerivationOutput StorePath Text)

instance Arbitrary OutputsDiff where
  arbitrary = OutputsDiff <$> arbitraryExtraOutputs  <*> arbitrary
    where
      arbitraryExtraOutputs =
        oneof [pure Nothing, Just <$> arbitraryChangedMap]

      arbitraryChangedMap =
        Changed <$> arbitraryMap <*> arbitraryMap

      arbitraryMap = Map.fromList <$>
        listOf ((,) <$> arbitrary <*> arbitraryDerivationOutput)

instance ToJSON OutputsDiff where
  toJSON OutputsDiff{..} = object
    [ "extraOutputs" .= fmap (changedToJSON extraOutputsToJSON) extraOutputs
    , "outputHashDiff" .= outputHashDiff
    ]
    where
    extraOutputsToJSON :: Map Text (DerivationOutput StorePath Text) -> Value
    extraOutputsToJSON = toJSON . fmap derivationOutputToJSON

    derivationOutputToJSON :: DerivationOutput StorePath Text -> Value
    derivationOutputToJSON DerivationOutput{..} = object
      [ "path" .= path
      , "hashAlgo" .= hashAlgo
      , "hash" .= hash
      ]

instance FromJSON OutputsDiff where
  parseJSON = withObject "OutputsDiff" \o -> do
    extraOutputsWithoutParsingDerivationOutputs <- o .: "extraOutputs"
    ohd <- o .: "outputHashDiff"
    eo <- (traverse . traverse . traverse)
      derivationOutputFromJSON
      extraOutputsWithoutParsingDerivationOutputs
    pure $ OutputsDiff eo ohd
    where

      derivationOutputFromJSON :: Value -> Parser (DerivationOutput StorePath Text)
      derivationOutputFromJSON = withObject "DerivationOutput" \o ->
        DerivationOutput <$> o .: "path" <*> o .: "hashAlgo" <*> o .: "hash"

data OutputDiff = OutputDiff
  { outputName :: Text
  , hashDifference :: Changed OutputHash
  }
  deriving stock (Eq, Show, Generic, Data)
  deriving anyclass (ToJSON, FromJSON)
  deriving Arbitrary via GenericArbitrary OutputDiff

-- ** Arguments diff

newtype ArgumentsDiff = ArgumentsDiff
  { unArgumetsDiff :: NonEmpty (Patience.Item Argument)
  }
  deriving stock (Eq, Show, Data)

instance Arbitrary ArgumentsDiff where
  arbitrary = ArgumentsDiff . NonEmpty.fromList <$> listOf1 arbitraryItem

instance ToJSON ArgumentsDiff where
  toJSON argumentsDiff = listValue itemToJSON (toList argumentsDiff.unArgumetsDiff)

instance FromJSON ArgumentsDiff where
  parseJSON v = ArgumentsDiff <$> (traverse itemFromJSON =<< parseJSON v)

-- ** Sources diff

data SourcesDiff = SourcesDiff
  { extraSrcNames :: Maybe (Changed (Set Text))
    -- ^ Will be Nothing, if there is no extra source names
  , srcFilesDiff :: [SourceFileDiff]
  }
  deriving stock (Eq, Show, Generic, Data)
  deriving anyclass (ToJSON, FromJSON)
  deriving Arbitrary via GenericArbitrary SourcesDiff

data SourceFileDiff
  = OneSourceFileDiff
      { srcName :: Text
      , srcContentDiff :: Maybe TextDiff
      -- ^ Will be Nothing, if any of source files not exists
      }
  | SomeSourceFileDiff
      { srcName :: Text
      , srcFileDiff :: Changed [StorePath]
      }
  deriving stock (Eq, Show, Generic, Data)
  deriving anyclass (ToJSON, FromJSON)
  deriving Arbitrary via GenericArbitrary SourceFileDiff

-- ** Inputs diff

data InputsDiff = InputsDiff
  { inputExtraNames :: Maybe (Changed (Set Text))
    -- ^ Will be Nothing, if there is no extra input names
  , inputDerivationDiffs :: [InputDerivationsDiff]
  }
  deriving stock (Eq, Show, Generic, Data)
  deriving anyclass (ToJSON, FromJSON)
  deriving Arbitrary via GenericArbitrary InputsDiff

data InputDerivationsDiff
  = OneDerivationDiff
      { drvName :: Text
      , drvDiff :: DerivationDiff
      }
  | SomeDerivationsDiff
      { drvName :: Text
      , extraPartsDiff :: Changed (Map StorePath OutputNames)
      }
  | -- | Many input derivations differ, but they've all already been compared.
    ManyDerivationsAlreadyComparedDiff
      { drvNames :: Set Text
      }
  deriving stock (Eq, Show, Generic, Data)
  deriving anyclass (ToJSON, FromJSON)
  deriving Arbitrary via GenericArbitrary InputDerivationsDiff

-- ** Environment diff

data EnvironmentDiff
  = EnvironmentsAreEqual
  | EnvironmentDiff
      { extraEnvDiff :: Changed (Map Text Text)
      , envContentDiff :: [EnvVarDiff]
      }
  deriving stock (Eq, Show, Generic, Data)
  deriving anyclass (ToJSON, FromJSON)
  deriving Arbitrary via GenericArbitrary EnvironmentDiff

data EnvVarDiff = EnvVarDiff
  { envKey :: Text
  , envValueDiff :: TextDiff
  }
  deriving stock (Eq, Show, Generic, Data)
  deriving anyclass (ToJSON, FromJSON)
  deriving Arbitrary via GenericArbitrary EnvVarDiff

-- ** Helpers

changedToJSON :: (a -> Value) -> Changed a -> Value
changedToJSON converter Changed{..} = object
  [ "before" .= converter before
  , "now" .= converter now
  ]

changedFromJSON :: (Value -> Parser a) -> Value -> Parser (Changed a)
changedFromJSON innerParser = withObject "Changed" \o -> do
  b <- o .: "before"
  n <- o .: "now"
  Changed <$> innerParser b <*> innerParser n

itemToJSON :: ToJSON v => Patience.Item v -> Value
itemToJSON (Patience.Old a)    = object
  [ "type" .= ("Old" :: Text), "content" .= a]
itemToJSON (Patience.New a)    = object
  [ "type" .= ("New" :: Text), "content" .= a]
itemToJSON (Patience.Both a _) = object
  [ "type" .= ("Both" :: Text), "content" .= a]

itemFromJSON :: FromJSON v => Value -> Parser (Patience.Item v)
itemFromJSON = withObject "Item" \o -> do
  t <- o .: "type"
  c <- o .: "content"
  case t :: Text of
    "Old" -> pure $ Patience.Old c
    "New" -> pure $ Patience.New c
    "Both" -> pure $ Patience.Both c c
    _ -> fail "Item: unexpected type"

arbitraryItem :: Arbitrary a => Gen (Patience.Item a)
arbitraryItem =  do
  t <- arbitrary
  ctr <- elements [old, new, both]
  pure (ctr t)
  where
    old = Patience.Old
    new = Patience.New
    both x = Patience.Both x x

arbitraryDerivationOutput :: (Arbitrary fp, Arbitrary txt) => Gen (DerivationOutput fp txt)
arbitraryDerivationOutput = DerivationOutput <$> arbitrary <*> arbitrary <*> arbitrary