Made output much faster by using byte string builders

slapnet.cabal

@@ -21,6 +21,8 @@ executable slapnet
   main-is: Main.hs
   other-modules:
   -- other-extensions:
-  build-depends:       base >=4 && <5, sbv, parsec, containers, transformers
+  build-depends:       base >=4 && <5, sbv, parsec, containers, transformers,
+                       bytestring
   hs-source-dirs:      src
   default-language:    Haskell2010
+  ghc-options:         -fsimpl-tick-factor=1000

src/Main.hs

@@ -10,6 +10,7 @@ import Control.Monad
 import Control.Applicative ((<$>))
 import Control.Arrow (first)
 import Data.List (partition)
+import qualified Data.ByteString.Lazy as L
 
 import Parser
 import qualified Parser.PNET as PNET
@@ -180,16 +181,16 @@ parseArgs = do
 writeFiles :: Int -> String -> PetriNet -> [Property] -> IO ()
 writeFiles verbosity basename net props = do
         verbosePut verbosity 1 $ "Writing " ++ showNetName net ++ " to " ++ basename
-        writeFile basename $ LOLAPrinter.printNet net
+        L.writeFile basename $ LOLAPrinter.printNet net
         mapM_ (\(p,i) -> do
                 let file = basename ++ ".task" ++ show i
                 verbosePut verbosity 1 $ "Writing " ++ showPropertyName p ++
                                          " to " ++ file
-                writeFile file $ LOLAPrinter.printProperty p
+                L.writeFile file $ LOLAPrinter.printProperty p
               ) (zip props [(1::Integer)..])
         verbosePut verbosity 1 $ "Writing properties to " ++ basename ++ ".sara"
-        writeFile (basename ++ ".sara") $ unlines $
-                map (SARAPrinter.printProperty basename net) props
+        L.writeFile (basename ++ ".sara") $
+            SARAPrinter.printProperties basename net props
 
 checkFile :: Parser (PetriNet,[Property]) -> Int -> Bool ->
             [ImplicitProperty] -> [NetTransformation] ->
@@ -206,10 +207,10 @@ checkFile parser verbosity refine implicitProperties transformations
                 "Places: " ++ show (length  $ places net') ++ "; " ++
                 "Transitions: " ++ show (length $ transitions net')
         verbosePut verbosity 3 $ show net'
-        rs <- mapM (checkProperty verbosity net' refine) props'''
         case output of
             Just outputfile -> writeFiles verbosity outputfile net' props'''
             Nothing -> return ()
+        rs <- mapM (checkProperty verbosity net' refine) props'''
         verbosePut verbosity 0 ""
         return $ and rs
 

src/Printer.hs

 module Printer
-    (validateId)
+    (validateId,intercalate)
 where
 
 import Data.Char
+import Data.ByteString.Builder
+import Data.Monoid
 
 validateId :: String -> String
 validateId "" = "_"
 validateId (x:xs) = (if isAlpha x then x else '_') :
         map (\c -> if isAlphaNum c then c else '_') xs
+
+
+intercalate :: Builder -> [Builder] -> Builder
+intercalate _ [] = mempty
+intercalate sep (x:xs) = x <> go xs
+      where go = foldr (\y -> (<>) (sep <> y)) mempty
+

src/Printer/LOLA.hs

+{-# LANGUAGE OverloadedStrings #-}
+
 module Printer.LOLA
     (printNet,printProperty)
 where
 
-import Data.List (intercalate)
+import qualified Data.ByteString.Lazy as L
+import Data.ByteString.Builder
+import Data.Monoid
 
+import Printer
 import PetriNet
 import Property
 
-printNet :: PetriNet -> String
-printNet net =
-        let showWeight (p,x) = p ++ ":" ++ show x
-            ps = "PLACE " ++ intercalate "," (places net) ++ ";\n"
-            is = "MARKING " ++ intercalate ","
-                    (map showWeight (initials net)) ++ ";\n"
+renderNet :: PetriNet -> Builder
+renderNet net =
+        let showWeight (p,x) = stringUtf8 p <> ":" <> integerDec x
+            ps = "PLACE " <> intercalate ","
+                    (map stringUtf8 (places net)) <> ";\n"
+            is = "MARKING " <> intercalate ","
+                    (map showWeight (initials net)) <> ";\n"
             makeTransition t =
                 let (preT,postT) = context net t
-                    preS = "CONSUME " ++ intercalate ","
-                                (map showWeight preT) ++ ";\n"
-                    postS = "PRODUCE " ++ intercalate ","
-                                (map showWeight postT) ++ ";\n"
-                in  "TRANSITION " ++ t ++ "\n" ++ preS ++ postS
+                    preS = "CONSUME " <> intercalate ","
+                                (map showWeight preT) <> ";\n"
+                    postS = "PRODUCE " <> intercalate ","
+                                (map showWeight postT) <> ";\n"
+                in  "TRANSITION " <> stringUtf8 t <> "\n" <> preS <> postS
             ts = map makeTransition (transitions net)
-        in  unlines (ps:is:ts)
-
-printTerm :: Term -> String
-printTerm (Var x) = x
-printTerm (Const c) = show c
-printTerm (Minus t) = "-" ++ printTerm t
-printTerm (t :+: u) = "(" ++ printTerm t ++ " + " ++ printTerm u ++ ")"
-printTerm (t :-: u) = "(" ++ printTerm t ++ " - " ++ printTerm u ++ ")"
-printTerm (t :*: u) = printTerm t ++ " * " ++ printTerm u
-
-printOp :: Op -> String
-printOp Gt = " > "
-printOp Ge = " >= "
-printOp Eq = " = "
-printOp Ne = " != "
-printOp Le = " <= "
-printOp Lt = " < "
-
-printLinIneq :: LinearInequation -> String
-printLinIneq (LinIneq lhs op rhs) = printTerm lhs ++ printOp op ++ printTerm rhs
-
-printFormula :: Formula -> String
-printFormula FTrue = "TRUE"
-printFormula FFalse = "FALSE"
-printFormula (Atom a) = printLinIneq a
-printFormula (Neg p) = "NOT " ++ "(" ++ printFormula p ++ ")"
-printFormula (p :&: q) = printFormula p ++ " AND " ++ printFormula q
-printFormula (p :|: q) = "(" ++ printFormula p ++ " OR " ++ printFormula q ++ ")"
-
-printProperty :: Property -> String
-printProperty (Property _ Safety f) = "EF (" ++ printFormula f ++ ")\n"
-printProperty (Property _ Liveness _) =
+        in  intercalate "\n" (ps:is:ts)
+
+printNet :: PetriNet -> L.ByteString
+printNet = toLazyByteString . renderNet
+
+renderTerm :: Term -> Builder
+renderTerm (Var x) = stringUtf8 x
+renderTerm (Const c) = integerDec c
+renderTerm (Minus t) = "-" <> renderTerm t
+renderTerm (t :+: u) = "(" <> renderTerm t <> " + " <> renderTerm u <> ")"
+renderTerm (t :-: u) = "(" <> renderTerm t <> " - " <> renderTerm u <> ")"
+renderTerm (t :*: u) = renderTerm t <> " * " <> renderTerm u
+
+renderOp :: Op -> Builder
+renderOp Gt = " > "
+renderOp Ge = " >= "
+renderOp Eq = " = "
+renderOp Ne = " != "
+renderOp Le = " <= "
+renderOp Lt = " < "
+
+renderLinIneq :: LinearInequation -> Builder
+renderLinIneq (LinIneq lhs op rhs) =
+        renderTerm lhs <> renderOp op <> renderTerm rhs
+
+renderFormula :: Formula -> Builder
+renderFormula FTrue = "TRUE"
+renderFormula FFalse = "FALSE"
+renderFormula (Atom a) = renderLinIneq a
+renderFormula (Neg p) = "NOT " <> "(" <> renderFormula p <> ")"
+renderFormula (p :&: q) = renderFormula p <> " AND " <> renderFormula q
+renderFormula (p :|: q) = "(" <> renderFormula p <> " OR " <> renderFormula q <> ")"
+
+renderProperty :: Property -> Builder
+renderProperty (Property _ Safety f) = "EF (" <> renderFormula f <> ")\n"
+renderProperty (Property _ Liveness _) =
         error "liveness property not supported for lola"
+
+printProperty :: Property -> L.ByteString
+printProperty = toLazyByteString . renderProperty

src/Printer/SARA.hs

+{-# LANGUAGE OverloadedStrings #-}
+
 module Printer.SARA
-    (printProperty)
+    (printProperties)
 where
 
-import Data.List (intercalate)
+import qualified Data.ByteString.Lazy as L
+import Data.ByteString.Builder
+import Data.Monoid
 
 import Printer
 import PetriNet
 import Property
 
-printSimpleTerm :: Integer -> Term -> String
-printSimpleTerm fac (Var x) = if fac == 1 then x else show fac ++ x
-printSimpleTerm fac (Const c) = show (fac*c)
-printSimpleTerm fac (Const c :*: t) = printSimpleTerm (fac*c) t
-printSimpleTerm fac (t :*: Const c) = printSimpleTerm (fac*c) t
-printSimpleTerm fac (Minus t) = printSimpleTerm (-fac) t
-printSimpleTerm _ t = error $ "term not supported for sara: " ++ show t
-
-printTerm :: Term -> String
-printTerm (t :+: u) = printTerm t ++ "+" ++ printSimpleTerm 1 u
-printTerm (t :-: u) = printTerm t ++ "+" ++ printSimpleTerm (-1) u
-printTerm t = printSimpleTerm 1 t
-
-printOp :: Op -> String
-printOp Ge = ">"
-printOp Eq = ":"
-printOp Le = "<"
-printOp op = error $ "operand not supported for sara: " ++ show op
-
-printLinIneq :: LinearInequation -> String
-printLinIneq (LinIneq lhs op (Const c)) = printTerm lhs ++ printOp op ++ show c
-printLinIneq l = error $ "linear inequation not supported for sara: " ++ show l
-
-printFormula :: Formula -> String
-printFormula (Atom a) = printLinIneq a
-printFormula (Neg _) = error "negation not supported for sara"
-printFormula (p :&: q) = printFormula p ++ "," ++ printFormula q
-printFormula f = error $ "formula not supported for sara: " ++ show f
-
-printProperty :: String -> PetriNet -> Property -> String
-printProperty filename net (Property propname Safety f) =
-        "PROBLEM " ++ validateId propname ++ ":\n" ++
-        "GOAL REACHABILITY;\n" ++
-        "FILE " ++ reverse (takeWhile (/='/') (reverse filename)) ++
-            " TYPE LOLA;\n" ++
-        "INITIAL " ++ intercalate ","
-            (map (\(p,i) -> p ++ ":" ++ show i) (initials net)) ++ ";\n" ++
-        "FINAL COVER;\n" ++
-        "CONSTRAINTS " ++ printFormula f ++ ";"
-printProperty _ _ (Property _ Liveness _) =
+renderSimpleTerm :: Integer -> Term -> Builder
+renderSimpleTerm fac (Var x) = if fac == 1 then stringUtf8 x
+                               else integerDec fac <> stringUtf8 x
+renderSimpleTerm fac (Const c) = integerDec (fac*c)
+renderSimpleTerm fac (Const c :*: t) = renderSimpleTerm (fac*c) t
+renderSimpleTerm fac (t :*: Const c) = renderSimpleTerm (fac*c) t
+renderSimpleTerm fac (Minus t) = renderSimpleTerm (-fac) t
+renderSimpleTerm _ t = error $ "term not supported for sara: " <> show t
+
+renderTerm :: Term -> Builder
+renderTerm (t :+: u) = renderTerm t <> "+" <> renderSimpleTerm 1 u
+renderTerm (t :-: u) = renderTerm t <> "+" <> renderSimpleTerm (-1) u
+renderTerm t = renderSimpleTerm 1 t
+
+renderOp :: Op -> Builder
+renderOp Ge = ">"
+renderOp Eq = ":"
+renderOp Le = "<"
+renderOp op = error $ "operand not supported for sara: " <> show op
+
+renderLinIneq :: LinearInequation -> Builder
+renderLinIneq (LinIneq lhs op (Const c)) =
+        renderTerm lhs <> renderOp op <> integerDec c
+renderLinIneq l = error $ "linear inequation not supported for sara: " <> show l
+
+renderFormula :: Formula -> Builder
+renderFormula (Atom a) = renderLinIneq a
+renderFormula (Neg _) = error "negation not supported for sara"
+renderFormula (p :&: q) = renderFormula p <> "," <> renderFormula q
+renderFormula f = error $ "formula not supported for sara: " <> show f
+
+renderProperty :: String -> PetriNet -> Property -> Builder
+renderProperty filename net (Property propname Safety f) =
+        "PROBLEM " <> stringUtf8 (validateId propname) <> ":\n" <>
+        "GOAL REACHABILITY;\n" <>
+        "FILE " <> stringUtf8 (reverse (takeWhile (/='/') (reverse filename)))
+            <> " TYPE LOLA;\n" <>
+        "INITIAL " <> intercalate ","
+            (map (\(p,i) -> stringUtf8 p <> ":" <> integerDec i) (initials net))
+            <> ";\n" <>
+        "FINAL COVER;\n" <>
+        "CONSTRAINTS " <> renderFormula f <> ";"
+renderProperty _ _ (Property _ Liveness _) =
         error "liveness property not supported for sara"
+
+printProperties :: String -> PetriNet -> [Property] -> L.ByteString
+printProperties filename net props =
+        toLazyByteString $ intercalate "\n" $
+            map (renderProperty filename net) props