darcs-2.8.0: src/Darcs/Test/Patch/Arbitrary/Generic.hs
{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-}
{-# LANGUAGE CPP, UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses,
FlexibleInstances, ViewPatterns #-}
#include "gadts.h"
module Darcs.Test.Patch.Arbitrary.Generic
( Tree(..), TreeWithFlattenPos(..), G2(..), ArbitraryPrim, NullPatch(..), RepoModel(..)
, flattenOne, flattenTree, mapTree, sizeTree
, commutePairFromTree, mergePairFromTree
, commuteTripleFromTree, mergePairFromCommutePair
, commutePairFromTWFP, mergePairFromTWFP, getPairs, getTriples
, patchFromTree
, canonizeTree
, quickCheck
) where
import Control.Monad ( liftM )
import Test.QuickCheck
import Darcs.Test.Patch.WithState
import Darcs.Test.Patch.RepoModel
import Darcs.Test.Util.QuickCheck ( bSized )
import Darcs.Witnesses.Sealed
import Darcs.Witnesses.Eq
import Darcs.Witnesses.Unsafe
import Darcs.Witnesses.Ordered
import Darcs.Patch.Merge ( Merge(..) )
import Darcs.Patch.Patchy ( Invert(..), Commute(..) )
import Darcs.Patch.Prim ( PrimOf, PrimPatch, PrimPatchBase, FromPrim(..), PrimConstruct( anIdentity ) )
import Darcs.Patch.Prim.V1 ()
import Darcs.Patch.V2 ( RealPatch ) -- XXX this is more or less a hack
--import Darcs.ColorPrinter ( errorDoc )
--import Darcs.ColorPrinter ( traceDoc )
import Darcs.Witnesses.Show
--import Printer ( greenText, ($$) )
-- | Generate a patch to a certain state.
class ArbitraryStateIn s p where
arbitraryStateIn :: s C(x) -> Gen (p C(x))
data Tree p C(x) where
NilTree :: Tree p C(x)
SeqTree :: p C(x y) -> Tree p C(y) -> Tree p C(x)
ParTree :: Tree p C(x) -> Tree p C(x) -> Tree p C(x)
mapTree :: (FORALL(y z) p C(y z) -> q C(y z)) -> Tree p C(x) -> Tree q C(x)
mapTree _ NilTree = NilTree
mapTree f (SeqTree p t) = SeqTree (f p) (mapTree f t)
mapTree f (ParTree t1 t2) = ParTree (mapTree f t1) (mapTree f t2)
instance Show2 p => Show (Tree p C(x)) where
showsPrec _ NilTree = showString "NilTree"
showsPrec d (SeqTree a t) = showParen (d > appPrec) $ showString "SeqTree " .
showsPrec2 (appPrec + 1) a . showString " " .
showsPrec (appPrec + 1) t
showsPrec d (ParTree t1 t2) = showParen (d > appPrec) $ showString "ParTree " .
showsPrec (appPrec + 1) t1 . showString " " .
showsPrec (appPrec + 1) t2
instance Show2 p => Show1 (Tree p) where
showDict1 = ShowDictClass
instance Show2 p => Show1 (TreeWithFlattenPos p) where
showDict1 = ShowDictClass
sizeTree :: Tree p C(x) -> Int
sizeTree NilTree = 0
sizeTree (SeqTree _ t) = 1 + sizeTree t
sizeTree (ParTree t1 t2) = 1 + sizeTree t1 + sizeTree t2
-- newtype G1 l p C(x) = G1 { _unG1 :: l (p C(x)) }
newtype G2 l p C(x y) = G2 { unG2 :: l (p C(x y)) }
flattenTree :: (Merge p) => Tree p C(z) -> Sealed (G2 [] (FL p) C(z))
flattenTree NilTree = seal $ G2 $ return NilFL
flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t
flattenTree (ParTree (flattenTree -> Sealed gpss1) (flattenTree -> Sealed gpss2))
= seal $ G2 $
do ps1 <- unG2 gpss1
ps2 <- unG2 gpss2
ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2)
-- We can't prove that the existential type in the result
-- of merge will be the same for each pair of
-- ps1 and ps2.
map unsafeCoerceP [ps1 +>+ ps2', ps2 +>+ ps1']
instance ArbitraryState s p => ArbitraryStateIn s (Tree p) where
-- Don't generate trees deeper than 6 with default QuickCheck size (0..99).
-- Note if we don't put a non-zero lower bound the first generated trees will always have depth 0.
arbitraryStateIn rm = bSized 3 0.035 9 $ \depth -> arbitraryTree rm depth
-- | Generate a tree of patches, bounded by the depth @maxDepth@.
arbitraryTree :: ArbitraryState s p => s C(x) -> Int -> Gen (Tree p C(x))
arbitraryTree rm depth
| depth == 0 = return NilTree
-- Note a probability of N for NilTree would imply ~(100*N)% of empty trees.
-- For the purpose of this module empty trees are useless, but even when
-- NilTree case is omitted there is still a small percentage of empty trees
-- due to the generation of null-patches (empty-hunks) and the use of canonizeTree.
| otherwise = frequency [(1, do Sealed (WithEndState p rm') <- arbitraryState rm
t <- arbitraryTree rm' (depth - 1)
return (SeqTree p t))
,(3, do t1 <- arbitraryTree rm (depth - 1)
t2 <- arbitraryTree rm (depth - 1)
return (ParTree t1 t2))]
class NullPatch p where
nullPatch :: p C(x y) -> EqCheck C(x y)
class (ArbitraryState (ModelOf prim) prim, NullPatch prim, PrimPatch prim, RepoModel (ModelOf prim)) => ArbitraryPrim prim
-- canonize a tree, removing any dead branches
canonizeTree :: NullPatch p => Tree p C(x) -> Tree p C(x)
canonizeTree NilTree = NilTree
canonizeTree (ParTree t1 t2)
| NilTree <- canonizeTree t1 = canonizeTree t2
| NilTree <- canonizeTree t2 = canonizeTree t1
| otherwise = ParTree (canonizeTree t1) (canonizeTree t2)
canonizeTree (SeqTree p t) | IsEq <- nullPatch p = canonizeTree t
| otherwise = SeqTree p (canonizeTree t)
instance (RepoModel model, ArbitraryPrim prim, model ~ ModelOf prim,
ArbitraryState model prim) => Arbitrary (Sealed (WithStartState model (Tree prim))) where
arbitrary = do repo <- aSmallRepo
Sealed (WithStartState rm tree) <-
liftM (seal . WithStartState repo) (arbitraryStateIn repo)
return $ Sealed $ WithStartState rm (canonizeTree tree)
flattenOne :: (FromPrim p, Merge p) => Tree (PrimOf p) C(x) -> Sealed (FL p C(x))
flattenOne NilTree = seal NilFL
flattenOne (SeqTree p (flattenOne -> Sealed ps)) = seal (fromPrim p :>: ps)
flattenOne (ParTree (flattenOne -> Sealed ps1) (flattenOne -> Sealed ps2)) =
--traceDoc (greenText "flattening two parallel series: ps1" $$ showPatch ps1 $$
-- greenText "ps2" $$ showPatch ps2) $
case merge (ps1 :\/: ps2) of
ps2' :/\: _ -> seal (ps1 +>+ ps2')
data TreeWithFlattenPos p C(x) = TWFP Int (Tree p C(x))
commutePairFromTWFP :: (FromPrim p, Merge p, PrimPatchBase p)
=> (FORALL (y z) (p :> p) C(y z) -> t)
-> (WithStartState model (TreeWithFlattenPos (PrimOf p)) C(x) -> t)
commutePairFromTWFP handlePair (WithStartState _ (TWFP n t))
= unseal2 handlePair $
let xs = unseal getPairs (flattenOne t)
in if length xs > n && n >= 0 then xs!!n else seal2 (fromPrim anIdentity :> fromPrim anIdentity)
commutePairFromTree :: (FromPrim p, Merge p, PrimPatchBase p)
=> (FORALL (y z) (p :> p) C(y z) -> t)
-> (WithStartState model (Tree (PrimOf p)) C(x) -> t)
commutePairFromTree handlePair (WithStartState _ t)
= unseal2 handlePair $
case flattenOne t of
Sealed ps ->
let xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $
getPairs ps
in if null xs then seal2 (fromPrim anIdentity :> fromPrim anIdentity) else last xs
commuteTripleFromTree :: (FromPrim p, Merge p, PrimPatchBase p)
=> (FORALL (y z) (p :> p :> p) C(y z) -> t)
-> (WithStartState model (Tree (PrimOf p)) C(x) -> t)
commuteTripleFromTree handle (WithStartState _ t)
= unseal2 handle $
case flattenOne t of
Sealed ps ->
let xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $
getTriples ps
in if null xs
then seal2 (fromPrim anIdentity :> fromPrim anIdentity :> fromPrim anIdentity)
else last xs
mergePairFromCommutePair :: (Commute p, Invert p)
=> (FORALL (y z) (p :\/: p) C(y z) -> t)
-> (FORALL (y z) (p :> p) C(y z) -> t)
mergePairFromCommutePair handlePair (a :> b)
= case commute (a :> b) of
Just (b' :> _) -> handlePair (a :\/: b')
Nothing -> handlePair (b :\/: b)
-- impredicativity problems mean we can't use (.) in the definitions below
mergePairFromTWFP :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)
=> (FORALL (y z) (p :\/: p) C(y z) -> t)
-> (WithStartState model (TreeWithFlattenPos (PrimOf p)) C(x) -> t)
mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x)
mergePairFromTree :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)
=> (FORALL (y z) (p :\/: p) C(y z) -> t)
-> (WithStartState model (Tree (PrimOf p)) C(x) -> t)
mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x)
patchFromCommutePair :: (Commute p, Invert p)
=> (FORALL (y z) p C(y z) -> t)
-> (FORALL (y z) (p :> p) C(y z) -> t)
patchFromCommutePair handle (_ :> b) = handle b
patchFromTree :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)
=> (FORALL (y z) p C(y z) -> t)
-> (WithStartState model (Tree (PrimOf p)) C(x) -> t)
patchFromTree x = commutePairFromTree (patchFromCommutePair x)
instance Show2 p => Show (TreeWithFlattenPos p C(x)) where
showsPrec d (TWFP n t) = showParen (d > appPrec) $ showString "TWFP " .
showsPrec (appPrec + 1) n . showString " " .
showsPrec1 (appPrec + 1) t
getPairs :: FL p C(x y) -> [Sealed2 (p :> p)]
getPairs NilFL = []
getPairs (_:>:NilFL) = []
getPairs (a:>:b:>:c) = seal2 (a:>b) : getPairs (b:>:c)
getTriples :: FL p C(x y) -> [Sealed2 (p :> p :> p)]
getTriples NilFL = []
getTriples (_:>:NilFL) = []
getTriples (_:>:_:>:NilFL) = []
getTriples (a:>:b:>:c:>:d) = seal2 (a:>b:>c) : getTriples (b:>:c:>:d)
instance (ArbitraryPrim prim, RepoModel (ModelOf prim), model ~ ModelOf prim,
ArbitraryState model prim)
=> Arbitrary (Sealed (WithStartState model (TreeWithFlattenPos prim))) where
arbitrary = do Sealed (WithStartState rm t) <- arbitrary
let num = unseal (length . getPairs) (flattenOneRP t)
if num == 0 then return $ Sealed $ WithStartState rm $ TWFP 0 NilTree
else do n <- choose (0, num - 1)
return $ Sealed $ WithStartState rm $ TWFP n t
where -- just used to get the length. In principle this should be independent of the patch type.
flattenOneRP :: Tree prim C(x) -> Sealed (FL (RealPatch prim) C(x))
flattenOneRP = flattenOne