Added kquick's SCargotPrintParse test suite with extra unconstrained tests

s-cargot.cabal

@@ -73,3 +73,14 @@ test-suite s-cargot-qc
                     parsec        >=3.1 && <4,
                     QuickCheck    >=2.8 && <3,
                     text          >=1.2 && <2
+
+test-suite s-cargot-printparse
+  default-language: Haskell2010
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   test
+  main-is:          SCargotPrintParse.hs
+  build-depends:    s-cargot,
+                    base          >=4.7 && <5,
+                    parsec        >=3.1 && <4,
+                    HUnit         >=1.6 && <1.7,
+                    text          >=1.2 && <2

test/SCargotPrintParse.hs

@@ -0,0 +1,279 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+
+module Main where
+
+import           Data.Either
+import           Data.SCargot
+import           Data.SCargot.Comments
+import           Data.SCargot.Repr
+import           Data.Semigroup
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import           System.Exit
+import           Test.HUnit
+import           Text.Parsec as P
+import           Text.Parsec.Text (Parser)
+import           Text.Printf ( printf )
+
+
+main = do
+  putStrLn "Parsing a large S-expression"
+  srcs <- mapM (\n -> (,) n <$> TIO.readFile n) [ "test/small-sample.sexp"
+                                                , "test/med-sample.sexp"
+                                                , "test/med2-sample.sexp"
+                                                , "test/big-sample.sexp"
+                                                ]
+  counts <- runTestTT $ TestList
+            [ TestLabel "basic checks" $ TestList
+              [ TestLabel "flat print" $ TestList
+                [ TestLabel "flatprint SNil" $ "()" ~=? printSExpr SNil
+                , TestLabel "flatprint SAtom" $ "hi" ~=? printSExpr (SAtom (AIdent "hi"))
+                , TestLabel "flatprint pair" $ "(hi . world)" ~=?
+                  printSExpr (SCons (SAtom (AIdent "hi")) (SAtom (AIdent "world")))
+                , TestLabel "flatprint list of 1" $ "(hi)" ~=?
+                  printSExpr (SCons (SAtom (AIdent "hi")) SNil)
+                , TestLabel "flatprint list of 2" $ "(hi world)" ~=?
+                  printSExpr (SCons (SAtom (AIdent "hi"))
+                                    (SCons (SAtom (AIdent "world"))
+                                           SNil))
+                , TestLabel "flatprint list of 2 pairs" $ "((hi . hallo) world . welt)" ~=?
+                  printSExpr (SCons (SCons (SAtom (AIdent "hi"))
+                                           (SAtom (AIdent "hallo")))
+                                    (SCons (SAtom (AIdent "world"))
+                                           (SAtom (AIdent "welt"))))
+                , TestLabel "flatprint list of 3 ending in a pair" $ "(hi world hallo . welt)" ~=?
+                  printSExpr (SCons (SAtom (AIdent "hi"))
+                                    (SCons (SAtom (AIdent "world"))
+                                           (SCons (SAtom (AIdent "hallo"))
+                                                  (SAtom (AIdent "welt")))))
+                , TestLabel "flatprint list of 3" $ "(hi world hallo)" ~=?
+                  printSExpr (SCons (SAtom (AIdent "hi"))
+                                    (SCons (SAtom (AIdent "world"))
+                                           (SCons (SAtom (AIdent "hallo"))
+                                                  SNil)))
+                ]
+
+              , TestLabel "pretty print" $
+                let pprintIt = pprintSExpr 40 Swing in TestList
+                [ TestLabel "pretty print SNil" $ "()" ~=? pprintIt SNil
+                , TestLabel "pretty print SAtom" $ "hi" ~=? pprintIt (SAtom (AIdent "hi"))
+                , TestLabel "pretty print pair" $ "(hi . world)" ~=?
+                  pprintIt (SCons (SAtom (AIdent "hi")) (SAtom (AIdent "world")))
+                , TestLabel "pretty print list of 1" $ "(hi)" ~=?
+                  pprintIt (SCons (SAtom (AIdent "hi")) SNil)
+                , TestLabel "pretty print list of 2" $ "(hi world)" ~=?
+                  pprintIt (SCons (SAtom (AIdent "hi"))
+                                  (SCons (SAtom (AIdent "world"))
+                                         SNil))
+                , TestLabel "pretty print list of 2 pairs" $
+                  "((hi . hallo) world . welt)" ~=?
+                  pprintIt (SCons (SCons (SAtom (AIdent "hi"))
+                                         (SAtom (AIdent "hallo")))
+                                  (SCons (SAtom (AIdent "world"))
+                                         (SAtom (AIdent "welt"))))
+                , TestLabel "pretty print list of 3 ending in a pair" $
+                  "(hi world hallo . welt)" ~=?
+                  pprintIt (SCons (SAtom (AIdent "hi"))
+                                  (SCons (SAtom (AIdent "world"))
+                                         (SCons (SAtom (AIdent "hallo"))
+                                                (SAtom (AIdent "welt")))))
+                , TestLabel "pretty print list of 3" $ "(hi world hallo)" ~=?
+                  pprintIt (SCons (SAtom (AIdent "hi"))
+                                  (SCons (SAtom (AIdent "world"))
+                                         (SCons (SAtom (AIdent "hallo"))
+                                                SNil)))
+                ]
+
+              , TestLabel "unconstrained print" $
+                let pprintIt = ucPrintSExpr Swing in TestList
+                [ TestLabel "pretty print SNil" $ "()" ~=? pprintIt SNil
+                , TestLabel "pretty print SAtom" $ "hi" ~=? pprintIt (SAtom (AIdent "hi"))
+                , TestLabel "pretty print pair" $ "(hi . world)" ~=?
+                  pprintIt (SCons (SAtom (AIdent "hi")) (SAtom (AIdent "world")))
+                , TestLabel "pretty print list of 1" $ "(hi)" ~=?
+                  pprintIt (SCons (SAtom (AIdent "hi")) SNil)
+                , TestLabel "pretty print list of 2" $ "(hi world)" ~=?
+                  pprintIt (SCons (SAtom (AIdent "hi"))
+                                  (SCons (SAtom (AIdent "world"))
+                                         SNil))
+                , TestLabel "pretty print list of 2 pairs" $
+                  "((hi . hallo)\n world\n . welt)" ~=?
+                  pprintIt (SCons (SCons (SAtom (AIdent "hi"))
+                                         (SAtom (AIdent "hallo")))
+                                  (SCons (SAtom (AIdent "world"))
+                                         (SAtom (AIdent "welt"))))
+                , TestLabel "pretty print list of 3 ending in a pair" $
+                  "(hi world hallo . welt)" ~=?
+                  pprintIt (SCons (SAtom (AIdent "hi"))
+                                  (SCons (SAtom (AIdent "world"))
+                                         (SCons (SAtom (AIdent "hallo"))
+                                                (SAtom (AIdent "welt")))))
+                , TestLabel "pretty print list of 3" $ "(hi world hallo)" ~=?
+                  pprintIt (SCons (SAtom (AIdent "hi"))
+                                  (SCons (SAtom (AIdent "world"))
+                                         (SCons (SAtom (AIdent "hallo"))
+                                                SNil)))
+                ]
+
+              ]
+            , TestLabel "round-trip" $ TestList $
+              concatMap (\t -> map t srcs) $
+              [ testParsePrint
+              ]
+            ]
+  if errors counts + failures counts > 0
+  then exitFailure
+  else exitSuccess
+
+
+testParsePrint :: (String, T.Text) -> Test
+testParsePrint (n,s) = TestList
+                       [ testParseFlatPrint n s
+
+                       , testParseUnconstrainedPrint Swing n s
+                       , testParseUnconstrainedPrint Align n s
+
+                       , testParsePPrint 80 Swing n s
+                       , testParsePPrint 60 Swing n s
+                       , testParsePPrint 40 Swing n s
+                       , testParsePPrint 20 Swing n s
+                       , testParsePPrint 15 Swing n s
+                       , testParsePPrint 10 Swing n s
+
+                       , testParsePPrint 80 Align n s
+                       , testParsePPrint 40 Align n s
+                       , testParsePPrint 10 Align n s
+                       ]
+
+
+testParseFlatPrint testName src =
+    testRoundTrip (testName <> " flat print")
+                      (fromRight (error "Failed parse") . parseSExpr)
+                      printSExpr
+                      stripAllText
+                      src
+
+testParseUnconstrainedPrint indentStyle testName src =
+    testRoundTrip (testName <> " unconstrained print")
+                      (fromRight (error "Failed parse") . parseSExpr)
+                      (ucPrintSExpr indentStyle)
+                      stripAllText
+                      src
+
+testParsePPrint width indentStyle testName src =
+    testRoundTrip (testName <> " pretty print")
+                      (fromRight (error "Failed parse") . parseSExpr)
+                      (pprintSExpr width indentStyle)
+                      stripAllText
+                      src
+
+stripAllText = T.unwords . concatMap T.words . T.lines
+
+testRoundTrip nm there back prep src = TestList
+  [ TestLabel (nm <> " round trip") $
+    TestCase $ (prep src) @=? (prep $ back $ there src)
+
+  , TestLabel (nm <> " round trip twice") $
+    TestCase $ (prep src) @=? (prep $ back $ there $ back $ there src)
+  ]
+
+
+------------------------------------------------------------------------
+
+data FAtom = AIdent String
+           | AQuoted String
+           | AString String
+           | AInt Integer
+           | ABV Int Integer
+           deriving (Eq, Show)
+
+
+string :: String -> SExpr FAtom
+string = SAtom . AString
+
+-- | Lift an unquoted identifier.
+ident :: String -> SExpr FAtom
+ident = SAtom . AIdent
+
+-- | Lift a quoted identifier.
+quoted :: String -> SExpr FAtom
+quoted = SAtom . AQuoted
+
+-- | Lift an integer.
+int :: Integer -> SExpr FAtom
+int = SAtom . AInt
+
+
+printAtom :: FAtom -> T.Text
+printAtom a =
+  case a of
+    AIdent s -> T.pack s
+    AQuoted s -> T.pack ('\'' : s)
+    AString s -> T.pack (show s)
+    AInt i -> T.pack (show i)
+    ABV w val -> formatBV w val
+
+
+printSExpr :: SExpr FAtom -> T.Text
+printSExpr = encodeOne (flatPrint printAtom)
+
+pprintSExpr :: Int -> Indent -> SExpr FAtom -> T.Text
+pprintSExpr w i = encodeOne (setIndentStrategy (const i) $
+                             setMaxWidth w $
+                             setIndentAmount 1 $
+                             basicPrint printAtom)
+
+ucPrintSExpr :: Indent -> SExpr FAtom -> T.Text
+ucPrintSExpr i = encodeOne (setIndentStrategy (const i) $
+                            setIndentAmount 1 $
+                            unconstrainedPrint printAtom)
+
+getIdent :: FAtom -> Maybe String
+getIdent (AIdent s) = Just s
+getIdent _ = Nothing
+
+formatBV :: Int -> Integer -> T.Text
+formatBV w val = T.pack (prefix ++ printf fmt val)
+  where
+    (prefix, fmt)
+      | w `rem` 4 == 0 = ("#x", "%0" ++ show (w `div` 4) ++ "x")
+      | otherwise = ("#b", "%0" ++ show w ++ "b")
+
+parseIdent :: Parser String
+parseIdent = (:) <$> first <*> P.many rest
+  where first = P.letter P.<|> P.oneOf "+-=<>_"
+        rest = P.letter P.<|> P.digit P.<|> P.oneOf "+-=<>_"
+
+parseString :: Parser String
+parseString = do
+  _ <- P.char '"'
+  s <- P.many (P.noneOf ['"'])
+  _ <- P.char '"'
+  return s
+
+parseBV :: Parser (Int, Integer)
+parseBV = P.char '#' >> ((P.char 'b' >> parseBin) P.<|> (P.char 'x' >> parseHex))
+  where parseBin = P.oneOf "10" >>= \d -> parseBin' (1, if d == '1' then 1 else 0)
+
+        parseBin' :: (Int, Integer) -> Parser (Int, Integer)
+        parseBin' (bits, x) = do
+          P.optionMaybe (P.oneOf "10") >>= \case
+            Just d -> parseBin' (bits + 1, x * 2 + (if d == '1' then 1 else 0))
+            Nothing -> return (bits, x)
+
+        parseHex = (\s -> (length s * 4, read ("0x" ++ s))) <$> P.many1 P.hexDigit
+
+parseAtom :: Parser FAtom
+parseAtom
+  =   AIdent      <$> parseIdent
+  P.<|> AQuoted     <$> (P.char '\'' >> parseIdent)
+  P.<|> AString     <$> parseString
+  P.<|> AInt . read <$> P.many1 P.digit
+  P.<|> uncurry ABV <$> parseBV
+
+parserLL :: SExprParser FAtom (SExpr FAtom)
+parserLL = withLispComments (mkParser parseAtom)
+
+parseSExpr :: T.Text -> Either String (SExpr FAtom)
+parseSExpr = decodeOne parserLL

test/med-sample.sexp

@@ -0,0 +1,17 @@
+((operands ((rA . 'Gprc) (rS . 'Gprc) (rB . 'Gprc))) 
+  (in ('XER 'CR rB rS 'IP))
+  (defs 
+    (('CR 
+       (bvor 
+         (bvand 
+           'CR
+           (bvnot (bvshl #x0000000f (bvmul ((_ zero_extend 29) #b000) #x00000004))))
+         (bvshl 
+           ((_ zero_extend 28) 
+             (concat 
+               (ite 
+                 (bvslt (bvxor rS rB) #x00000000)
+                 #b100
+                 (ite (bvsgt (bvxor rS rB) #x00000000) #b010 #b001))
+               ((_ extract 0 0) 'XER)))
+           (bvmul ((_ zero_extend 29) #b000) #x00000004)))) (rA (bvxor rS rB)) ('IP (bvadd 'IP #x00000004)))))

test/med2-sample.sexp

@@ -0,0 +1,262 @@
+((operands
+ ((rD . 'GPR)
+ (setcc . 'Cc_out)
+ (predBits . 'Pred)
+ (rM . 'GPR)
+ (rN . 'GPR)))
+(in (setcc rN rM 'CPSR 'PC))
+(defs
+ (('PC
+  (ite
+   ((_ call "arm.is_r15") rD)
+   (ite
+    (bveq
+     #b0
+     ((_ extract 0 0)
+     ((_ extract 31 0)
+     (bvadd
+      (bvadd ((_ zero_extend 1) rN) ((_ zero_extend 1) (bvnot rM)))
+      ((_ zero_extend 1) #x00000001)))))
+    (bvand
+     #xfffffffe
+     ((_ extract 31 0)
+     (bvadd
+      (bvadd ((_ zero_extend 1) rN) ((_ zero_extend 1) (bvnot rM)))
+      ((_ zero_extend 1) #x00000001))))
+    (ite
+     (bveq
+      #b0
+      ((_ extract 1 1)
+      ((_ extract 31 0)
+      (bvadd
+       (bvadd
+        ((_ zero_extend 1) rN)
+        ((_ zero_extend 1) (bvnot rM)))
+       ((_ zero_extend 1) #x00000001)))))
+     (bvand
+      #xfffffffd
+      ((_ extract 31 0)
+      (bvadd
+       (bvadd
+        ((_ zero_extend 1) rN)
+        ((_ zero_extend 1) (bvnot rM)))
+       ((_ zero_extend 1) #x00000001))))
+     ((_ extract 31 0)
+     (bvadd
+      (bvadd ((_ zero_extend 1) rN) ((_ zero_extend 1) (bvnot rM)))
+      ((_ zero_extend 1) #x00000001)))))
+   (bvadd 'PC #x00000004)))
+ ('CPSR
+  (ite
+   (ite
+    (andp (bveq #b1 ((_ extract 0 0) predBits)) (bvne predBits #xf))
+    (notp
+     (ite
+      (bveq ((_ extract 3 1) predBits) #b000)
+      (bveq #b1 ((_ extract 30 30) 'CPSR))
+      (ite
+       (bveq ((_ extract 3 1) predBits) #b001)
+       (bveq #b1 ((_ extract 29 29) 'CPSR))
+       (ite
+        (bveq ((_ extract 3 1) predBits) #b010)
+        (bveq #b1 ((_ extract 31 31) 'CPSR))
+        (ite
+         (bveq ((_ extract 3 1) predBits) #b011)
+         (bveq #b1 ((_ extract 28 28) 'CPSR))
+         (ite
+          (bveq ((_ extract 3 1) predBits) #b100)
+          (andp
+           (bveq #b1 ((_ extract 29 29) 'CPSR))
+           (notp (bveq #b1 ((_ extract 30 30) 'CPSR))))
+          (ite
+           (bveq ((_ extract 3 1) predBits) #b101)
+           (bveq
+            ((_ extract 31 31) 'CPSR)
+            ((_ extract 28 28) 'CPSR))
+           (ite
+            (bveq ((_ extract 3 1) predBits) #b110)
+            (andp
+             (bveq
+              ((_ extract 31 31) 'CPSR)
+              ((_ extract 28 28) 'CPSR))
+             (notp (bveq #b1 ((_ extract 30 30) 'CPSR))))
+            (bveq #b0 #b0)))))))))
+    (ite
+     (bveq ((_ extract 3 1) predBits) #b000)
+     (bveq #b1 ((_ extract 30 30) 'CPSR))
+     (ite
+      (bveq ((_ extract 3 1) predBits) #b001)
+      (bveq #b1 ((_ extract 29 29) 'CPSR))
+      (ite
+       (bveq ((_ extract 3 1) predBits) #b010)
+       (bveq #b1 ((_ extract 31 31) 'CPSR))
+       (ite
+        (bveq ((_ extract 3 1) predBits) #b011)
+        (bveq #b1 ((_ extract 28 28) 'CPSR))
+        (ite
+         (bveq ((_ extract 3 1) predBits) #b100)
+         (andp
+          (bveq #b1 ((_ extract 29 29) 'CPSR))
+          (notp (bveq #b1 ((_ extract 30 30) 'CPSR))))
+         (ite
+          (bveq ((_ extract 3 1) predBits) #b101)
+          (bveq
+           ((_ extract 31 31) 'CPSR)
+           ((_ extract 28 28) 'CPSR))
+          (ite
+           (bveq ((_ extract 3 1) predBits) #b110)
+           (andp
+            (bveq
+             ((_ extract 31 31) 'CPSR)
+             ((_ extract 28 28) 'CPSR))
+            (notp (bveq #b1 ((_ extract 30 30) 'CPSR))))
+           (bveq #b0 #b0)))))))))
+   (ite
+    (andp (bveq setcc #b1) (notp ((_ call "arm.is_r15") rD)))
+    (concat
+     (concat
+      ((_ extract 31 31)
+      ((_ extract 31 0)
+      (bvadd
+       (bvadd
+        ((_ zero_extend 1) rN)
+        ((_ zero_extend 1) (bvnot rM)))
+       ((_ zero_extend 1) #x00000001))))
+      (concat
+       (ite
+        (bveq
+         ((_ extract 31 0)
+         (bvadd
+          (bvadd
+           ((_ zero_extend 1) rN)
+           ((_ zero_extend 1) (bvnot rM)))
+          ((_ zero_extend 1) #x00000001)))
+         #x00000000)
+        #b1
+        #b0)
+       (concat
+        ((_ extract 32 32)
+        (bvadd
+         (bvadd
+          ((_ zero_extend 1) rN)
+          ((_ zero_extend 1) (bvnot rM)))
+         ((_ zero_extend 1) #x00000001)))
+        (bvand
+         ((_ extract 31 31)
+         ((_ extract 31 0)
+         (bvadd
+          (bvadd
+           ((_ zero_extend 1) rN)
+           ((_ zero_extend 1) (bvnot rM)))
+          ((_ zero_extend 1) #x00000001))))
+         ((_ extract 32 32)
+         (bvadd
+          (bvadd
+           ((_ zero_extend 1) rN)
+           ((_ zero_extend 1) (bvnot rM)))
+          ((_ zero_extend 1) #x00000001)))))))
+     ((_ extract 27 0)
+     (ite
+      ((_ call "arm.is_r15") rD)
+      (ite
+       (bveq
+        #b0
+        ((_ extract 0 0)
+        ((_ extract 31 0)
+        (bvadd
+         (bvadd
+          ((_ zero_extend 1) rN)
+          ((_ zero_extend 1) (bvnot rM)))
+         ((_ zero_extend 1) #x00000001)))))
+       (bvand #xfeffffff (bvor #x00000020 'CPSR))
+       'CPSR)
+      'CPSR)))
+    (ite
+     ((_ call "arm.is_r15") rD)
+     (ite
+      (bveq
+       #b0
+       ((_ extract 0 0)
+       ((_ extract 31 0)
+       (bvadd
+        (bvadd
+         ((_ zero_extend 1) rN)
+         ((_ zero_extend 1) (bvnot rM)))
+        ((_ zero_extend 1) #x00000001)))))
+      (bvand #xfeffffff (bvor #x00000020 'CPSR))
+      'CPSR)
+     'CPSR))
+   'CPSR))
+ (rD
+  (ite
+   (ite
+    (andp (bveq #b1 ((_ extract 0 0) predBits)) (bvne predBits #xf))
+    (notp
+     (ite
+      (bveq ((_ extract 3 1) predBits) #b000)
+      (bveq #b1 ((_ extract 30 30) 'CPSR))
+      (ite
+       (bveq ((_ extract 3 1) predBits) #b001)
+       (bveq #b1 ((_ extract 29 29) 'CPSR))
+       (ite
+        (bveq ((_ extract 3 1) predBits) #b010)
+        (bveq #b1 ((_ extract 31 31) 'CPSR))
+        (ite
+         (bveq ((_ extract 3 1) predBits) #b011)
+         (bveq #b1 ((_ extract 28 28) 'CPSR))
+         (ite
+          (bveq ((_ extract 3 1) predBits) #b100)
+          (andp
+           (bveq #b1 ((_ extract 29 29) 'CPSR))
+           (notp (bveq #b1 ((_ extract 30 30) 'CPSR))))
+          (ite
+           (bveq ((_ extract 3 1) predBits) #b101)
+           (bveq
+            ((_ extract 31 31) 'CPSR)
+            ((_ extract 28 28) 'CPSR))
+           (ite
+            (bveq ((_ extract 3 1) predBits) #b110)
+            (andp
+             (bveq
+              ((_ extract 31 31) 'CPSR)
+              ((_ extract 28 28) 'CPSR))
+             (notp (bveq #b1 ((_ extract 30 30) 'CPSR))))
+            (bveq #b0 #b0)))))))))
+    (ite
+     (bveq ((_ extract 3 1) predBits) #b000)
+     (bveq #b1 ((_ extract 30 30) 'CPSR))
+     (ite
+      (bveq ((_ extract 3 1) predBits) #b001)
+      (bveq #b1 ((_ extract 29 29) 'CPSR))
+      (ite
+       (bveq ((_ extract 3 1) predBits) #b010)
+       (bveq #b1 ((_ extract 31 31) 'CPSR))
+       (ite
+        (bveq ((_ extract 3 1) predBits) #b011)
+        (bveq #b1 ((_ extract 28 28) 'CPSR))
+        (ite
+         (bveq ((_ extract 3 1) predBits) #b100)
+         (andp
+          (bveq #b1 ((_ extract 29 29) 'CPSR))
+          (notp (bveq #b1 ((_ extract 30 30) 'CPSR))))
+         (ite
+          (bveq ((_ extract 3 1) predBits) #b101)
+          (bveq
+           ((_ extract 31 31) 'CPSR)
+           ((_ extract 28 28) 'CPSR))
+          (ite
+           (bveq ((_ extract 3 1) predBits) #b110)
+           (andp
+            (bveq
+             ((_ extract 31 31) 'CPSR)
+             ((_ extract 28 28) 'CPSR))
+            (notp (bveq #b1 ((_ extract 30 30) 'CPSR))))
+           (bveq #b0 #b0)))))))))
+   (ite
+    ((_ call "arm.is_r15") rD)
+    rD
+    ((_ extract 31 0)
+    (bvadd
+     (bvadd ((_ zero_extend 1) rN) ((_ zero_extend 1) (bvnot rM)))
+     ((_ zero_extend 1) #x00000001))))
+   rD)))))

test/small-sample.sexp

@@ -0,0 +1 @@
+((operands ((rT . 'Gprc) (rA . 'Gprc))) (in (rA 'IP)) (defs ((rT rA) ('IP (bvadd 'IP #x00000004)))))