visual-graphrewrite-0.3: GraphRewrite/Internal/Test.hs

module GraphRewrite.Internal.Test  where

import GraphRewrite.Internal.Rewrite
import GraphRewrite.Internal.RewriteTypes hiding (PointedGraph)

import System.IO.Unsafe
--import Test.ChasingBottoms.TimeOut
import Test.LazySmallCheck
import qualified Data.IntMap as IM
import Data.List

{-
Serial instance needed:
    Graph
    RewriteSystem

-}


--------------------------- helper functions

infix 1 <=>
(<=>) :: Bool -> Bool -> Bool
(<=>) = (==)

sameSet :: Ord a => [a] -> [a] -> Bool
sameSet a b = sort a == sort b
{-
timeOut2s :: a -> IO a
timeOut2s x = do
    r <- timeOut 2 (return x)
    case r of
        NonTermination      -> error "nontermination"
        Value x             -> return x
        Exception e         -> error (show e)
-}
--------------------------- Serial instances

instance Serial Expr where
    series
        =  cons1 SCons
        \/ cons2 SFun
        \/ cons1 SLit
        \/ cons1 SHole
        \/ cons1 (SRef . natToInt)
        \/ cons2 SApp

newtype DataExpr
    = DataExpr { unDataExpr :: Expr }
        deriving Show

instance Serial DataExpr where
    series
        =  cons1 (DataExpr . SCons)
        \/ cons2 (\x -> DataExpr . SFun x)
        \/ cons1 (DataExpr . SLit)
        \/ cons1 (DataExpr . SRef . natToInt)
        \/ cons2 (\(DataExpr x) ys -> DataExpr $ SApp x $ map unDataExpr ys)

newtype DataGraph
    = DataGraph Graph
        deriving Show

instance Serial DataGraph where
    series = cons1 (DataGraph . IM.fromList . zip [0..] . map unDataExpr)

data Nat
    = Zero
    | Succ Nat
        deriving (Eq, Ord, Show)

instance Num Nat where
    fromInteger 0 = Zero
    fromInteger n | n < 0 = error "fromInteger/Num"
    fromInteger n = Succ (fromInteger (n-1))

    (+) = undefined
    (*) = undefined
    abs = undefined
    signum = undefined

instance Serial Nat where
    series = cons0 Zero \/ cons1 Succ

natToInt :: Nat -> Int
natToInt Zero = 0
natToInt (Succ n) = 1 + natToInt n

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

data PointedGraph
    = PGraph Expr Graph
        deriving (Show)

instance Serial PointedGraph where
    series = cons1 mkDataGraph

mkDataGraph :: Nat -> PointedGraph
mkDataGraph n = PGraph (SLit "15") IM.empty

--------------------------- auxiliary predicates and functions

dataExpr :: Expr -> Bool
dataExpr (SHole _)   = False
dataExpr (SApp e es) = dataExpr e && all dataExpr es
dataExpr _           = True

dataGraph :: Graph -> Bool
dataGraph g = all dataExpr (IM.elems g)

ref :: Expr -> Bool
ref (SRef _) = True
ref _        = False

collectRefs :: Expr -> [Int]
collectRefs (SRef i)    = [i]
collectRefs (SApp e es) = collectRefs e ++ concatMap collectRefs es
collectRefs _           = []

allReferenceDefined :: Expr -> Graph -> Bool
allReferenceDefined e g = all (`IM.member` g) (collectRefs e ++ concatMap collectRefs (IM.elems g))

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

allTests :: IO ()
allTests = do

    let
        p (SCons _)  = True
        p (SFun _ _) = True
        p (SLit _)   = True
        p _          = False

    smallCheck 30 $ \(PGraph e g) -> -- unsafePerformIO $ timeOut2s $
            not (ref e) && allReferenceDefined e g  ==>  p (fst (flattenSApp e g))

{-
    sm $ interpreter "start = f True; f x = x" == "True"

    sm $ \s1 s2 s3 ->   s1 /= s2
            ==>  freeVars (s1 ++ " = 3;" ++ s2 ++ " " ++ s3 ++ " = " ++ s3)
                    `sameSet` [s1, s2]
-}