module Main where

import qualified Data.List as Lst
import Language.CCS.Data
import Language.CCS.Parser
import Language.CCS.Printer
import System.Environment(getArgs)
import Text.Parsec
import Test.QuickCheck
import Test.Framework as TF (defaultMain, testGroup, Test)
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2 (testProperty)
import qualified Data.HashSet as HS
import qualified Data.HashMap.Strict as HM


small :: Gen Char
small = choose ('a','z')

capital :: Gen Char
capital = choose ('A','Z')

digits :: Gen Char
digits = choose ('0','9')

genhspace :: Gen String
genhspace =   listOf1 (elements [' ','\t'])

genvspace :: Gen String
genvspace = do
  n <- listOf1 (elements ["\n", "\r\n"])
  return $ concat n

genspace = oneof [genhspace, genvspace]

gencomma = do
  l <- genspace
  return $ ',' : l

gensym c = do
  l <- genspace
  return $ c : l  

genCurlyOpen = gensym '{'
genCurlyClose = gensym '}'

genequals = elements [":", "="]
  
genLib :: Gen CLib
genLib = do
   f <- small
   rest <- listOf $ oneof [small, capital, digits , elements ['-','.']]
   return . CLib $ (f:rest)


genHdr :: Gen CInclude
genHdr = do
  f <- small
  rest <- listOf $ oneof [small, capital, digits, elements ['-','/','.']]
  return . CInclude $ (f:rest)

gParse :: (a ->  Bool) -> String -> Parser  a -> String -> Gen Bool
gParse eqcheck sourceName parser text = case runParser parser (HS.empty) sourceName  text of
                                         Left err      -> return False
                                         Right i       ->  return $ eqcheck i
  

gptest :: (Show a) => Gen String ->   Parsec String u a -> u -> IO ()
gptest g p u = do
  txt <- generate g
  putStrLn txt
  case runParser p u "gptest" txt of
   Left err      -> print err
   Right a       -> putStrLn (show a)
       

libText :: CLib -> Gen String
libText (CLib txt) = return $  "\"" ++ txt ++ "\""

hdrText :: CInclude -> Gen String
hdrText (CInclude str) = return $ "<" ++ str ++ ">"


hdrTexts = combElems hdrText gencomma


combElems2 ::  (a -> Gen String) ->[a] -> Gen String
combElems2 _ []  = return ""
combElems2  f  (h:rest)= do
  t <- f h
  rem <- combElems2 f rest
  return $ t ++ rem


combElems ::  (a -> Gen String) -> Gen String ->[a] -> Gen String
combElems _ _ []  = return ""
combElems  f sep (h:rest)= do
  t <- f h
  s <- genspace
  c <- gencomma
  case rest of
   [] -> return $ t ++ s
   _  -> do
     rem <- combElems f sep rest
     return $ t ++ s ++ c ++ rem

headerSecTxt :: [CInclude] -> Gen String
headerSecTxt incs = do
  s1 <- genspace
  e <- genequals
  ghs <-hdrTexts incs
  return $ "headers" ++ s1 ++ e ++ ghs
  

libSectionText :: CLib ->  Gen String
libSectionText  lib = do
  l <- libText lib
  e <- genequals
  s1 <- genspace
  s2 <- genspace
  s3 <- genspace
  return $ "library" ++ s1 ++ e ++ s2 ++ l ++ s3


dependencySecTxt ::  Gen String
dependencySecTxt  = do
  s1 <- genspace
  e <- genequals
  o <- genCurlyOpen
  c <- genCurlyClose
  libs <- listOf genLib
  txt <- combElems libText gencomma libs
  return $ "dependencies" ++ e ++ o ++ txt ++ c
  

asisText :: Gen String
asisText =  vectorOf 100 $ suchThat (choose (' ','z')) onlyAllowed
  where onlyAllowed c = not $ elem c "{}#$" 

  
verbatimText :: Gen CSVal
verbatimText =   do
   t <- listOf (choose ('%','~'))
   return $ CSVerbatim t

genCId :: Gen String
genCId = do
  l <- small
  rest <- listOf $ oneof [small, capital, digits , elements ['_']]
  return $ l:rest

genTypeName :: Gen String
genTypeName = do
  l <- listOf1 genCId
  return . Lst.concat $ Lst.intersperse "." l

genHashDef :: Gen CSVal
genHashDef = do
  c <- genCId
  return $ CHashDef c

genHashChar :: Gen CSVal
genHashChar = return CDblHash

genHashAlign :: Gen CSVal
genHashAlign = do
  s <- genCId
  c <- genCId
  return $ CFieldOffset s c

genSizeof :: Gen CSVal
genSizeof = do
  s <- genCId
  return $ CSizeOf s

genEpiFrag = oneof [verbatimText, genHashDef, genHashChar, genHashAlign, genSizeof]

prop_validEpilog = do
  frags <- listOf genEpiFrag
  txt <- combElems2 csVerbToStr  frags
  gParse (\x -> True) "prop_validEpilog" epilogue txt
                 
prop_parseLib :: Gen Bool
prop_parseLib = do
  l <- genLib
  txt <- libSectionText l
  gParse (== l) "prop_parseLib " libSection txt

prop_parseHeader :: Gen Bool
prop_parseHeader = do
  hdrs <- listOf1 genHdr
  txt <- headerSecTxt hdrs
  gParse (== hdrs) "prop_parseHeader" headers txt


prop_parseDependencySec :: Gen Bool
prop_parseDependencySec = do
  txt <- dependencySecTxt
  gParse (\x -> True) "prop_parseDependencySec" extraLibs txt


csVerbToStr :: CSVal -> Gen String
csVerbToStr (CSVerbatim str) = return str
csVerbToStr (CHashDef str)   = return str
csVerbToStr (CDblHash )      = return "##"
csVerbToStr (CSizeOf s) = do
  s1 <- gensym '('
  s2 <- gensym ')'
  return $ "#$sizeof" ++ s1 ++ s ++ s2
csVerbToStr (CFieldOffset str f) = do
  s1 <- gensym '('
  s2 <- gensym ')'
  junk <- genspace
  return $ "#$offset" ++ s1 ++ str ++ junk ++ f ++ s2 


enumValToStr :: EnumValue -> Gen String
enumValToStr EmptyEnum = return ""
enumValToStr (FromMacro s) = return $ '#' : s
enumValToStr (EnumSize s)  = do {s1 <- gensym '('; s2 <- gensym ')'; return $ "#$sizeof" ++ s1 ++ s ++ s2}
enumValToStr (EnumOffset s f) = do {s1 <- gensym '('; s2 <- gensym ')'; c <- gensym ','; return $ "#$offset" ++ s1 ++ s ++ c ++ f ++ s2}
enumValToStr (EnumText s)  = return s
enumValToStr (EnumComplex lst) = do
  txts <- mapM enumValToStr lst
  return $ "{" ++ concat txts ++ "}"

genEnumVal = oneof [genempty, genmacro, genComplex, gensize, genoffset]
  where
    genempty = return $ EmptyEnum
    genmacro = (genCId >>= return . FromMacro)
    gensize  = (genCId >>= return . EnumSize )
    genasis = (asisText >>= return . EnumText)
    genoffset = do
      s1 <- genCId
      f <- genCId
      return $ EnumOffset s1 f
    genComplex = do
      l <- listOf1 $ oneof [genasis, genmacro]
      return $ EnumComplex l

prop_enumVal :: Gen Bool
prop_enumVal = do
  ev <- genEnumVal
  txt <- enumValToStr ev
  gParse (\x -> True) "prop_enumVal" (option EmptyEnum enumValue) txt

tests :: [TF.Test]
tests = [
        testGroup "QuickCheck CCS.Parser" [
                testProperty "parseLibrary"       prop_parseLib,
                testProperty "parseHeader"        prop_parseHeader,
                testProperty "parseDependency"    prop_parseDependencySec,
                testProperty "parseEpilogue"      prop_validEpilog,
                testProperty "parseEnumValue"     prop_enumVal
                ]
       ]


tester  p strs = parseTest p (unlines strs)

main = defaultMain tests
