feat: add cli stuff

pg-dsl/AST.hs

@@ -286,12 +286,13 @@ data ParserError = ParserError
 
 instance Show ParserError where
   show :: ParserError -> String
-  show e =
-    pMsg e ++ " at line " ++ show (pLine e) ++ ", column " ++ show (pCol e)
+  show = pMsg
 
 data FParserError =
   FPError FilePath ParserError
 
 instance Show FParserError where
   show :: FParserError -> String
-  show (FPError fp err) = show err ++ " in file " ++ fp
+  show (FPError fp err) =
+    pMsg err ++
+    " at " ++ fp ++ ":" ++ show (pLine err) ++ "." ++ show (pCol err)

pg-dsl/Main.hs

@@ -1,25 +1,43 @@
 module Main where
 
-import           AST
+import           AST                       (AST, FParserError (..), Model (..),
+                                            PG (..), ParserError, ProgramGraph,
+                                            emptyEnv)
+import           Control.Monad             (when)
 import qualified Data.ByteString.Lazy      as LBS
+import           Data.Char                 (toLower)
 import           Data.List                 (isSuffixOf)
 import           Distribution.Simple.Utils (getDirectoryContentsRecursive)
 import           Distribution.Utils.Json   (renderJson)
 import           GHC.Base                  (returnIO)
 import           Jsonable                  (Jsonable (toJson))
 import           Parser                    (parse, parseMain)
 import           RangeCheck                (checkRanges)
+import           System.Directory          (createDirectoryIfMissing)
+import           System.Environment        (getArgs)
+import           System.Exit               (ExitCode (ExitFailure), exitSuccess,
+                                            exitWith)
+import           System.FilePath           (takeDirectory)
+import           System.Process            (createProcess, proc, waitForProcess)
 import           Tokenizer                 (tokenize)
 import           TypeCheck                 (checkTypes)
 
 main :: IO ()
 main = do
-  let prefix = "./examples/robot/"
-  allFiles <- getDirectoryContentsRecursive prefix
+  args <- getArgs
+  let (fp, cmd) = parseArgs args
+      basepath =
+        if fp /= "" && last fp == '/'
+          then fp
+          else fp ++ "/"
+  when (cmd == ["err"]) $
+    putStrLn ("Invalid command line arguments: " ++ unwords args) >>
+    exitWith (ExitFailure 1)
+  allFiles <- getDirectoryContentsRecursive basepath
   let pgFiles = filter isGraphFile allFiles
-  contents <- mapM (readFile . (prefix ++)) pgFiles
+  contents <- mapM (readFile . (basepath ++)) pgFiles
   let inspected = inspect $ zip pgFiles $ map (parse . tokenize) contents
-      mainFile = prefix ++ "main.pg"
+      mainFile = basepath ++ "main.pg"
   mainContent <- readFile mainFile
   let modelRaw = inspectMain mainFile $ (parseMain . tokenize) mainContent
       model = mergeGraphs modelRaw inspected
@@ -33,8 +51,43 @@ main = do
                   Just err -> Left err
               Left s -> Left s
           err -> err
-  LBS.writeFile "./output.json" $ renderJson $ toJson $ checkedModel
-  print checkedModel
+  when (isError checkedModel) $
+    putStrLn (getErrorMsg checkedModel) >> exitWith (ExitFailure 1)
+  let jsonOut = "./out/pg-dsl/" ++ map toLower (getModelName model) ++ ".json"
+      jsonArgs = ["--json-file", jsonOut]
+  createDirectoryIfMissing True $ takeDirectory jsonOut
+  LBS.writeFile jsonOut $ renderJson $ toJson checkedModel
+  when (cmd /= []) $ do
+    (_, _, _, processHandle) <-
+      createProcess (proc "pg-verify" $ cmd ++ jsonArgs)
+    _ <- waitForProcess processHandle
+    exitSuccess
+  exitSuccess
+
+parseArgs :: [String] -> (FilePath, [String])
+parseArgs [] = (".", [])
+parseArgs [x]
+  | x `elem` ["-t", "--test"] = (".", ["test"])
+  | x `elem` ["-s", "--simulate"] = (".", ["simulate"])
+  | x `elem` ["-d", "--dcca"] = (".", ["dcca"])
+  | notDash x = (x, [])
+parseArgs [x, y]
+  | x `elem` ["-t", "--test"] && notDash y = (y, ["test"])
+  | x `elem` ["-s", "--simulate"] && notDash y = (y, ["simulate"])
+  | x `elem` ["-d", "--dcca"] && notDash y = (y, ["dcca"])
+  | x `elem` ["-o", "--show"] && y `elem` ["puml", "json", "yaml"] =
+    (".", ["show", y])
+  | x `elem` ["-o", "--show"] && y == "png" =
+    (".", ["show", y, "--hide-precons"])
+parseArgs [x, y, z]
+  | x `elem` ["-o", "--show"] && y `elem` ["puml", "json", "yaml"] && notDash z =
+    (z, ["show", y])
+  | x `elem` ["-o", "--show"] && y == "png" = (z, ["show", y, "--hide-precons"])
+parseArgs x = ("", ["err"])
+
+notDash :: String -> Bool
+notDash [] = False
+notDash s  = head s /= '-'
 
 isGraphFile :: String -> Bool
 isGraphFile s = ".pg" `isSuffixOf` s && not ("main.pg" `isSuffixOf` s)
@@ -67,3 +120,13 @@ mergeGraphs (Right m) (Right g) =
     , specs = specs m
     , environ = emptyEnv
     }
+
+getModelName :: AST -> String
+getModelName (Right m) = modelName m
+
+isError :: AST -> Bool
+isError (Left _) = True
+isError _        = False
+
+getErrorMsg :: AST -> String
+getErrorMsg (Left s) = s

pg-dsl/README.md

@@ -0,0 +1,2 @@
+### Compile GHC project to ./build/ directory:
+`ghc -o ./build/pgdsl ./Main.hs -odir ./build -hidir ./build`

pg-dsl/examples/robot/main.pg

@@ -1,26 +1,21 @@
 model Robot {
+    # Stoerungen
     errors {
-        transient TransientError
-        persistent PersistentError
+        persistent AusKnopfKaputt
     }
 
-    # Just some stuff that makes no sense
+    # Gefahren
     hazards {
-        "Hazard 1" {
-            F Robot = Inactive
-        }
-        "Hazard 2" {
-            AF TransientError = Yes & EF PersistentError = Yes
+        "num ist zu gross" {
+            F num = 5
         }
     }
 
-    # More stuff that makes no sense
+    # Plausibilitaetschecks
     specify {
-        "Specification 1" {
-            G nofaults => X Robot = Idle | F Robot = Busy
-        }
-        "Specification 2" {
-            G TransientError = No
+        "Einmal inactive, immer inactive" {
+            G AusKnopfKaputt = No
+            => G (Robot = Inactive => (G Robot = Inactive))
         }
     }
 }

pg-dsl/examples/robot/robot.pg

@@ -20,7 +20,11 @@ graph Robot {
         Busy -> Busy {}
 
         Busy -> Inactive {
-            guard { num = 3 }
+            guard { num >= 3 }
+        }
+
+        Inactive -> Idle {
+            guard { AusKnopfKaputt != No }
         }
     }
 }