-- BSD3
--
-- This file contains examples found during the development of Darcs.Patch.Unwind

{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Darcs.Test.Patch.Examples.Unwind where

import Darcs.Prelude

import Darcs.Patch.FromPrim
import Darcs.Patch.Info
import Darcs.Patch.Merge
import Darcs.Patch.Named
import Darcs.Patch.V1 ()
import Darcs.Patch.V1.Core
import Darcs.Patch.Prim.Class
import Darcs.Patch.Witnesses.Ordered
import Darcs.Patch.Witnesses.Sealed

import Darcs.Util.Path
import Darcs.Util.Tree

import Darcs.Test.HashedStorage ( unsafeMakeName )
import Darcs.Test.Patch.Arbitrary.Generic
import Darcs.Test.Patch.Arbitrary.Named ()
import Darcs.Test.Patch.Arbitrary.PrimV1 ()
import Darcs.Test.Patch.Arbitrary.RepoPatch
import Darcs.Test.Patch.RepoModel
import Darcs.Test.Patch.Types.MergeableSequence
    ( MergeableSequence(..) )
import Darcs.Test.Patch.V1Model
import Darcs.Test.Patch.WithState
import Darcs.Test.TestOnly.Instance ()

#if MIN_VERSION_base(4,12,0) && !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail
#endif
import Data.ByteString.Char8 ( pack )
import qualified Data.ByteString.Lazy.Char8 as BLC
import Data.Constraint
import Data.String

examples
  :: forall p
   . (ArbitraryRepoPatch p, ArbitraryPrim (OnlyPrim p))
   => [Sealed2 (WithStartState2 (MergeableSequence (Named p)))]
examples =
  case (hasPrimConstruct @(OnlyPrim p), usesV1Model @(PrimOf p), notRepoPatchV1 @p) of
    (Just Dict, Just Dict, Just _) -> [example1, example2, example3, example4]
    (Just Dict, Just Dict, Nothing) -> [example1, example2, example3]
    _ -> []

mkNamed :: String -> FL p wX wY -> Named p wX wY
mkNamed hash = NamedP (rawPatchInfo "" "" "" ["Ignore-this: "++hash] False) []

path :: String -> AnchoredPath
path s = AnchoredPath [unsafeMakeName s]

repo :: [(String, [BLC.ByteString])] -> V1Model wX
repo entries =
  makeRepo [ (unsafeMakeName s, RepoItem (File (makeBlob (BLC.unlines thelines))))
           | (s, thelines) <- entries
           ]

example1
  :: forall p
   . (PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)
   => Sealed2 (WithStartState2 (MergeableSequence (Named p)))
example1 =
  Sealed2
    (WithStartState2
      (repo [("a", [])])
      (ParMS
        (SeqMS
          NilMS
          (mkNamed "d4c5605cd6b83371fec990c1835c6416a187ba0"
            (hunk (path "a") 1 [] [pack "x"] :>: NilFL)))
        (SeqMS
          NilMS
          (mkNamed "bb201b95265f199e7fd98a7e2216a0add4fece68"
            (hunk (path "a") 1 [] [pack "y"] :>:
             hunk (path "a") 1 [pack "y"] [pack "z"] :>:
             NilFL)))))

example2
  :: forall p
   . (PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)
   => Sealed2 (WithStartState2 (MergeableSequence (Named p)))
example2 =
  let s3,s4 :: forall s . IsString s => [s]
      s3 = ["f"]
      s4 = ["g"]
  in
  Sealed2
    (WithStartState2
      (repo [("a", s3++s4)])
      (ParMS
        (ParMS
          (SeqMS
            NilMS
              (mkNamed "e8204d03b3f785675ce4bd676adbfe89c4979399"
                (hunk (path "a") 1 (map pack s3) [] :>: NilFL)))
          (SeqMS
            NilMS
              (mkNamed "ac22106fec2b81ae4f75039210f0601dbc9f677d"
                (hunk (path "a") 1 (map pack (s3++s4)) [] :>: NilFL))))
        (SeqMS
          NilMS
          (mkNamed "4f5a9665900931228596a8241ff03dea1a54805f"
            (
             hunk (path "a") (1 + length s3 + length s4) [] [pack "d"] :>:
             hunk (path "a") 1 (map pack s3) [] :>:
            NilFL)))))


example3
  :: forall p
   . (PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)
   => Sealed2 (WithStartState2 (MergeableSequence (Named p)))
example3 =
  let
    s4 :: IsString s => [s]
    s4 = ["w"]
  in
  Sealed2
    (WithStartState2
      (repo [("a", s4)])
      (ParMS
        (SeqMS
          (ParMS
            (SeqMS NilMS
               (mkNamed "e631e70c43b4e609830053068eef382a4b2fec7"
                 (
                  hunk (path "a") (1+length s4) [] [pack "t"] :>:
                  NilFL
                 )))
            (SeqMS NilMS
               (mkNamed "cc39750d852a02487e2854be4c2b28f6cadf0957"
                 (
                  hunk (path "a") 1 (map pack (s4)) [] :>:
                  NilFL
                 ))))
          (mkNamed "3e2975afd211888617b20a58455926411f1ebaab"
            (
              hunk (path "a") (1+length s4) (map pack ([])) [pack "d"] :>:
              NilFL
            )))
        (SeqMS NilMS
          (mkNamed "441f412b978df5bd8febfe1f4baa5cb8d35f6e4c"
            (
             hunk (path "a") 1 (map pack []) [pack "U"] :>: 
             hunk (path "a") 2 (map pack s4) [] :>:
             NilFL
          )
        )
      )
    ))

example4guts :: forall p prim . (PrimConstruct prim, ModelOf p ~ V1Model, OnlyPrim p ~ prim) => Sealed2 (WithStartState2 (MergeableSequence p))
example4guts =
  let
    s3,s5,s7,s9,s10,s11,s12 :: IsString a => [a]
    s3 = ["A","F","l"]
    s5 = ["w"]
    s7 = ["y"]
    s9 = ["u"]
    s10 = ["x"]
    s11 = ["S"]
    s12 = ["e"]
    off :: [[a]] -> Int
    off xs = 1 + sum (map length xs)
  in
   Sealed2
     (WithStartState2
       (repo [("a", s3++s5++s7)])
       (
         (NilMS
           `SeqMS` hunk (path "a") (off [s3,s5]) [] (map pack s10)
           `SeqMS` hunk (path "a") (off [s3,s5,s10,s7]) [] (map pack s11)
         )
         `ParMS`
         (NilMS
            `SeqMS` hunk (path "a") (off []) (map pack s3) (map pack s9)
            `SeqMS` hunk (path "a") (off []) (map pack (s9++s5++s7)) []
         )
         `ParMS`
         (NilMS
           `SeqMS` hunk (path "a") (off []) (map pack (s3)) []
           `SeqMS` hunk (path "a") (off []) [] (map pack s12)
         )
       )
     )
         

example4
  :: forall p
   . (PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)
   => Sealed2 (WithStartState2 (MergeableSequence (Named p)))
example4 =
  case example4guts @p of
   Sealed2 (WithStartState2 model (((NilMS `SeqMS` a1 `SeqMS` a2) `ParMS` (NilMS `SeqMS` a3 `SeqMS` a4)) `ParMS` (NilMS `SeqMS` a5 `SeqMS` a6))) ->
     Sealed2
       (WithStartState2 model
         ((NilMS
            `SeqMS`
            mkNamed "91b78b39ea6649b6e43ea74a57070480c87d7053"
                   (a1 :>: NilFL)
            `SeqMS`
            mkNamed "80da177d495a63bc9d80b8c9bc56045b23b629f7"
                   (a2 :>: NilFL)
          )
          `ParMS`
          (NilMS
            `SeqMS`
            mkNamed "cdd591a73493d39bd763bd71acac4c1e3078a4a"
                   (a3 :>: a4 :>: NilFL)
          )
          `ParMS`
          (NilMS
            `SeqMS`
            mkNamed "9b7b08b417d62868eb92d2cac7512b899c32f722"
               (a5 :>: a6 :>: NilFL)
          )
         ))

-- like Identity but with a MonadFail instance, just to make it easier
-- to write 'brokenV1Merge' below
newtype ErrorFail a = ErrorFail { runErrorFail :: a }

instance Functor ErrorFail where
  fmap f = ErrorFail . f . runErrorFail
instance Applicative ErrorFail where
  pure = ErrorFail
  liftA2 f (ErrorFail v1) (ErrorFail v2) = ErrorFail (f v1 v2)
instance Monad ErrorFail where
  ErrorFail v >>= f = f v
#if MIN_VERSION_base(4,12,0)
instance MonadFail ErrorFail where
#endif
  fail = error

-- For now this code isn't used, it just demonstrates how example4 is broken in V1
-- x4;x5' =\/= x5;x4' but not (effect (x4;x5') =\/= effect (x5;x4'))
brokenV1Merge :: forall prim . (OnlyPrim (RepoPatchV1 prim) ~ prim, ModelOf (RepoPatchV1 prim) ~ V1Model, PrimPatch prim) => ()
brokenV1Merge =
  let
    x4, x4', x4'', x5, x5', x6, x6' :: Sealed2 (RepoPatchV1 prim)
    (x4, x4', x4'', x5, x5', x6, x6') =
      case example4guts @(RepoPatchV1 prim) of
        Sealed2
          (WithStartState2 _
            ((NilMS `SeqMS` a1 `SeqMS` a2) `ParMS` (NilMS `SeqMS` a3 `SeqMS` a4) `ParMS` (NilMS `SeqMS` a5 `SeqMS` a6))
          )
         -> runErrorFail $ do
          (a3' :>: a4' :>: NilFL) :/\: _ <- return $ merge ((PP a1 :>: PP a2 :>: NilFL) :\/: (PP a3 :>: PP a4 :>: NilFL))
          (a5' :>: a6' :>: NilFL) :/\: _ <- return $ merge ((PP a1 :>: PP a2 :>: a3' :>: NilFL) :\/: (PP a5 :>: PP a6 :>: NilFL))
          a5'' :/\: a4'' <- return $ merge (a4' :\/: a5')
          a6'' :/\: a4''' <- return $ merge (a4'' :\/: a6')
          return (Sealed2 a4', Sealed2 a4'', Sealed2 a4''', Sealed2 a5', Sealed2 a5'', Sealed2 a6', Sealed2 a6'')
  in x4 `seq` x4' `seq` x4'' `seq` x5 `seq` x5' `seq` x6 `seq` x6' `seq` ()
