More rearranging of generators.

Matthewar · Jul 10, 2018 · 173d527 · 173d527
1 parent df48afc
commit 173d527
Show file tree

Hide file tree

Showing 2 changed files with 63 additions and 53 deletions.
diff --git a/test/Spec/Generators/LexElements.hs b/test/Spec/Generators/LexElements.hs
@@ -2,7 +2,7 @@
    Module      : Spec.Generators.LexElements
    Description : Generators of basic lexical elements of VHDL
 -}
-module Spec.Generators.LexElements 
+module Spec.Generators.LexElements
    --( GenPair(..)
    --, combineGen
    ( genInteger
@@ -15,12 +15,14 @@ module Spec.Generators.LexElements
    , genCaseInsensitiveWord
    --, genDelimiter
    , genComment
+   , intersperseUnderscores
    ) where
 
 import qualified Test.Tasty.QuickCheck as QC
 
 import Control.Monad
 import Data.Function ((&))
+import Data.Int (Int64)
 import qualified Data.Map.Strict as MapS
 import qualified Data.ByteString.Lazy.Char8 as B
 import Data.Char
@@ -66,18 +68,17 @@ import Parser.Types.Token
 --    'genInteger' ::= digit { 'genUnderscoreDigit' }
 --    'genUnderscoreDigit' ::= [ underline ] digit
 -- @
-genInteger :: Integer -> Integer -> QC.Gen (ParserExpectedOutput Integer)
+genInteger :: Maybe Integer -> Maybe Integer -> QC.Gen (ParserExpectedOutput Integer)
 genInteger minimum maximum =
-   let genUnderscore char = QC.arbitrary
-                            <&> \includeUnderscore ->
-                                 if includeUnderscore
-                                    then ['_',char]
-                                    else [char]
-       addUnderscores (fst:rest) = ([fst]:) <$> mapM genUnderscore rest
-       addUnderscores [] = return []
-       input output = concat <$> (addUnderscores $ show $ output)
+   let input = (intersperseUnderscores . show)
        output val = input val <&> \input -> ExpectedOutput input val
-   in output =<< QC.choose (minimum,maximum)
+       maxInt64 = toInteger (maxBound :: Int64)
+   in output =<< QC.choose ( case (minimum,maximum) of
+                              (Just min,Just max) -> (min,max)
+                              (Just min,Nothing) -> (min,maxInt64)
+                              (Nothing,Just max) -> (0,max)
+                              (Nothing,Nothing) -> (0,maxInt64)
+                           )
 
 -- |Generate a VHDL specific exponent
 -- > exponent ::= E [ + ] integer  | E - integer
@@ -92,7 +93,7 @@ genExponent :: QC.Gen (ParserExpectedOutput Integer)
 genExponent = do
    expChar <- QC.elements "Ee"
    expSign <- QC.elements ["+","-",""]
-   (ExpectedOutput expStr expVal) <- genInteger 0 200
+   (ExpectedOutput expStr expVal) <- genInteger Nothing Nothing
    let expectedOutput = expVal & case expSign of
                                     "-" -> (-) 0
                                     _ -> id
@@ -280,18 +281,11 @@ genIdentifier :: Int -> Int -> QC.Gen String
 genIdentifier fromLength toLength = do
    letter <- QC.elements letters
    lengthStr <- QC.elements [fromLength..toLength]
-   otherLetters <- replicateM lengthStr genUnderscoreLetterOrDigit
-   let identifier = (letter:concat otherLetters)
-   return identifier
+   intersperseUnderscores
+      =<< (letter:)
+      <$> (replicateM lengthStr $ QC.elements letters_or_digits)
    where letters = ['a'..'z'] ++ ['A'..'Z']
          letters_or_digits = ['0'..'9'] ++ letters
-         genUnderscoreLetterOrDigit :: QC.Gen String
-         genUnderscoreLetterOrDigit = do
-            optionalUnderscore <- QC.elements [True,False]
-            letter_or_digit <- QC.elements letters_or_digits
-            return $
-               if optionalUnderscore then ['_',letter_or_digit]
-               else [letter_or_digit]
 
 ---- |Generate a VHDL specific decimal literal
 ---- Arguments: range of unit string, range of optional decimal part, whether exponent used
@@ -371,3 +365,15 @@ genComment = do
             (fst,snd@('\n':rest)) -> (fst++snd,rest)
             (fst,[]) -> (fst,[])
    return $ ExpectedOutput ("--" ++ input) expectedOutput
+
+-- |Intersperse a string with underscores
+-- Useful for many VHDL patterns including integer and identifiers
+intersperseUnderscores :: String -> QC.Gen String
+intersperseUnderscores (fst:rest) = concat . ([fst]:) <$> mapM genUnderscore rest
+   where genUnderscore char =
+            QC.arbitrary
+            <&> \includeUnderscore ->
+                  if includeUnderscore
+                     then ['_',char]
+                     else [char]
+intersperseUnderscores [] = return []
diff --git a/test/Spec/Parser/Combinators/Lex.hs b/test/Spec/Parser/Combinators/Lex.hs
@@ -12,8 +12,7 @@ import Control.Applicative (liftA2)
 import Data.Either (isLeft)
 import Data.Maybe (isNothing)
 import Data.Int
-         ( Int8
-         , Int16
+         ( Int16
          , Int64
          )
 import Numeric
@@ -50,6 +49,7 @@ import Spec.Generators.LexElements
          , genBitStr
          , genIdentifier
          , genComment
+         , intersperseUnderscores
          )
 
 -- |All tests for the module "Parser.Combinators.Lex"
@@ -110,38 +110,42 @@ validDecimals = testGroup "Valid decimal literals"
 -- Any decimal without a decimal point
 validDecimalIntegers :: TestTree
 validDecimalIntegers = QC.testProperty "Valid integer-kind decimal literals" $
-   QC.forAll genInteger $ \(ExpectedOutput input expectedOutput) -> (parse abstractLiteral "TEST" input) == Right (UniversalInteger expectedOutput)
-   where genInteger :: QC.Gen (ParserExpectedOutput Int64)
-         genInteger = QC.oneof
-                        [ noExponent
-                        , positiveExponent
-                        , negativeExponent
-                        ]
-         genInt :: (QC.Arbitrary a,Integral a) => QC.Gen a
-         genInt = QC.suchThat QC.arbitrary (>= 0)
+   QC.forAll genDecimalInteger $ \(ExpectedOutput input expectedOutput) -> (parse abstractLiteral "TEST" input) == Right (UniversalInteger expectedOutput)
+   where genDecimalInteger :: QC.Gen (ParserExpectedOutput Int64)
+         genDecimalInteger = QC.oneof
+                              [ noExponent
+                              , positiveExponent
+                              , negativeExponent
+                              ]
          noExponent :: QC.Gen (ParserExpectedOutput Int64)
-         noExponent =
-            let gen value = ExpectedOutput (show value) value
-            in gen <$> genInt
-         positiveExponent :: QC.Gen (ParserExpectedOutput Int64)
+         noExponent = let gen (ExpectedOutput input value) = ExpectedOutput input (fromIntegral value)
+                      in gen <$> genInteger Nothing Nothing
          positiveExponent = do
-            let genMulTen :: QC.Gen (Integer,Int8)
-                genMulTen = (\baseVal exponent -> (toInteger baseVal * 10 ^ exponent,exponent))
-                            <$> (genInt :: QC.Gen Int16)
-                            <*> genInt
-            (expectedOutput,exponent) <- (\(a,b) -> (fromInteger a,b))
-                                         <$> QC.suchThat genMulTen ((\val -> val >= 0 && val <= toInteger (maxBound :: Int64)) . fst)
-            actualExponent <- QC.choose (0,exponent)
+            (minValue,maxExponent) <- QC.suchThat 
+                                       ( (,)
+                                     <$> QC.choose (0,2^7)
+                                     <*> QC.choose (0,maxBound :: Int16)
+                                       )
+                                       $ \(baseVal,exp) -> (baseVal * 10 ^ exp) <= toInteger (maxBound :: Int64)
+            actualExponent <- QC.choose (0,maxExponent)
             exponentChar <- QC.elements "Ee"
-            let input = show (floor $ fromIntegral expectedOutput / 10.0 ^^ actualExponent) ++ [exponentChar] ++ show actualExponent
-            return $ ExpectedOutput input expectedOutput
+            valueStr <- intersperseUnderscores $ show $ minValue * 10 ^ (maxExponent - actualExponent)
+            exponentStr <- intersperseUnderscores $ show actualExponent
+            let inputStr = valueStr ++ [exponentChar] ++ exponentStr
+                expectedOutput = fromIntegral $ minValue * 10 ^ maxExponent
+            return $ ExpectedOutput inputStr expectedOutput
          negativeExponent :: QC.Gen (ParserExpectedOutput Int64)
          negativeExponent = do
-            expectedOutput <- genInt
-            shiftVal <- genInt
-            exponentChar <- QC.elements "Ee"
-            let input = show expectedOutput ++ replicate shiftVal '0' ++ [exponentChar] ++ show (-shiftVal)
-            return $ ExpectedOutput input expectedOutput
+            expectedValue <- QC.choose (0,maxBound :: Int64)
+            shiftVal <- QC.choose (0,2^7) -- Number of zeros on end of value
+            let actualValue = intersperseUnderscores $ show expectedValue ++ replicate shiftVal '0'
+            input <- (++)
+                     <$> actualValue
+                     <*> ( (\e val -> (e:'-':val))
+                       <$> QC.elements "Ee"
+                       <*> intersperseUnderscores (show shiftVal)
+                         )
+            return $ ExpectedOutput input expectedValue
 
 -- |Tests for decimal literals that parse to reals
 validDecimalReals :: TestTree
@@ -495,7 +499,7 @@ integers = testGroup "Integers"
 -- |Tests for valid integers
 validIntegers :: TestTree
 validIntegers = QC.testProperty "Valid integers" $
-   QC.forAll (genInteger 0 $ toInteger (maxBound :: Int64)) $
+   QC.forAll (genInteger Nothing Nothing) $
       \(ExpectedOutput input expectedValue) -> parse integer "TEST" input == Right (show expectedValue)
 
 -- |Tests for invalid integers
@@ -517,7 +521,7 @@ exponents = testGroup "Exponents"
 -- |Tests for valid exponents
 validExponents :: TestTree
 validExponents = QC.testProperty "Valid exponents" $
-   QC.forAll genExponent $ \(ExpectedOutput input expectedOutput) -> parse exponent' "TEST" input == Right expectedOutput
+   QC.forAll genExponent $ \(ExpectedOutput input expectedOutput) -> parse exponent' "TEST" input == Right (toInteger expectedOutput)
 
 -- |Tests for invalid exponents
 invalidExponents :: TestTree