module Test.SmartCheck.Render
( renderWithVars
, smartPrtLn
) where
import Test.SmartCheck.Types
import Test.SmartCheck.Args hiding (format)
import Test.SmartCheck.DataToTree
import Data.Maybe
import Data.Tree
import Data.List
import Data.Char
import Control.Monad
smartPrefix :: String
smartPrefix = "*** "
smartPrtLn :: String -> IO ()
smartPrtLn = putStrLn . (smartPrefix ++)
renderWithVars :: SubTypes a => Format -> a -> Replace Idx -> IO ()
renderWithVars format d idxs = do
prtVars "values" valsLen valVars
prtVars "constructors" constrsLen constrVars
constrArgs
putStrLn ""
putStrLn $ replaceWithVars format d idxs' (Replace valVars constrVars)
putStrLn ""
where
idxs' = let cs = unConstrs idxs \\ unVals idxs in
idxs { unConstrs = cs }
constrArgs =
unless (constrsLen == 0) $ putStrLn " there exist arguments x̅ s.t."
prtVars kind len vs =
when (len > 0)
( putStrLn $ "forall " ++ kind ++ " "
++ unwords (take len vs) ++ ":")
vars str = map (\(x,i) -> x ++ show i) (zip (repeat str) [0::Integer ..])
valVars = vars "x"
constrVars = vars "C"
valsLen = length (unVals idxs')
constrsLen = length (unConstrs idxs')
type VarRepl = Either String String
replaceWithVars :: SubTypes a
=> Format -> a -> Replace Idx -> Replace String -> String
replaceWithVars format d idxs vars =
case format of
PrintTree -> drawTree strTree
PrintString -> stitchTree strTree
where
strTree :: Tree String
strTree = remSubVars (foldl' f t zipRepl)
where
remSubVars (Node (Left s ) sf) = Node s (map remSubVars sf)
remSubVars (Node (Right s) _ ) = Node s []
f :: Tree VarRepl -> (String, Idx) -> Tree VarRepl
f tree (var, idx) = Node (rootLabel tree) $
case getIdxForest sf idx of
Nothing -> errorMsg "replaceWithVars1"
Just (Node (Right _) _) -> sf
Just (Node (Left _) _) -> forestReplaceChildren sf idx (Right var)
where
sf = subForest tree
t :: Tree VarRepl
t = let forest = showForest d in
if null forest then errorMsg "replaceWithVars2"
else fmap Left (head forest)
zipRepl :: [(String, Idx)]
zipRepl = zip (unVals vars) (unVals idxs)
++ zip (unConstrs vars) (unConstrs idxs)
stitchTree :: Tree String -> String
stitchTree = stitch
where
stitch (Node str forest) = str ++ " " ++ unwords (map stitchTree' forest)
stitchTree' (Node str []) = if isJust $ find isSpace str
then '(' : str ++ ")"
else str
stitchTree' node = '(' : stitch node ++ ")"