Merge pull request #1496 from AmpersandTarski/issues-1495-add-guarded…

…-to-json-parser

Issues 1495 add Guarded to .json parser

ReleaseNotes.md

@@ -2,7 +2,8 @@
 
 ## Unreleased
 
-
+## v5.2.0 (16 august 2024)
+- [Issue #1496](https://github.com/AmpersandTarski/Ampersand/issues/1496) .json file can now be parsed as import from the Atlas
 
 ## v5.1.3 (12 august 2024) 
 - [Issue #1381](https://github.com/AmpersandTarski/Ampersand/issues/1381) Bugfixes for support for new Angular frontend

ampersand.cabal

@@ -5,7 +5,7 @@ cabal-version: 2.0
 -- see: https://github.com/sol/hpack
 
 name:           ampersand
-version:        5.1.3
+version:        5.2.0
 synopsis:       Toolsuite for automated design of enterprise information systems.
 description:    You can define your business processes by means of rules, written in Relation Algebra.
 category:       Database Design
@@ -541,7 +541,6 @@ library
   other-modules:
       Ampersand.Basics.Hashing
       Ampersand.Basics.Name
-      Ampersand.Commands.AtlasImport
       Ampersand.Commands.Daemon
       Ampersand.Commands.Devoutput
       Ampersand.Commands.Documentation
@@ -563,8 +562,8 @@ library
       Ampersand.FSpec.FPA
       Ampersand.FSpec.Instances
       Ampersand.Input.Archi.ArchiAnalyze
+      Ampersand.Input.AtlasImport
       Ampersand.Misc.Defaults
-      Ampersand.Options.AtlasImportOptsParser
       Ampersand.Options.DaemonParser
       Ampersand.Options.DevoutputOptsParser
       Ampersand.Options.DocOptsParser

package.yaml

@@ -1,5 +1,5 @@
 name: ampersand
-version: 5.1.3
+version: 5.2.0
 author: Stef Joosten
 maintainer: [email protected]
 synopsis: Toolsuite for automated design of enterprise information systems.

src/Ampersand/Input/ADL1/CtxError.hs

@@ -42,6 +42,7 @@ module Ampersand.Input.ADL1.CtxError
     mkSubInterfaceMustBeDefinedOnObject,
     lexerWarning2Warning,
     lexerError2CtxError,
+    mkJSONParseError,
     addWarning,
     addWarnings,
     mkCrudWarning,
@@ -727,6 +728,9 @@ mkCaseProblemWarning x y =
         tshow (typeOf x) <> " `" <> fullName x <> "` and `" <> fullName y <> "`."
       ]
 
+mkJSONParseError :: Origin -> Text -> Guarded a
+mkJSONParseError orig msg = Errors . pure $ CTXE orig msg
+
 mkParserStateWarning :: Origin -> Text -> Warning
 mkParserStateWarning = Warning
 

src/Ampersand/Input/ADL1/ParsingLib.hs

@@ -69,12 +69,20 @@ module Ampersand.Input.ADL1.ParsingLib
     -- * Integer parsers
     pZero,
     pOne,
+
+    -- * Runners
+    runParser,
   )
 where
 
 import Ampersand.Basics hiding (many, try)
+import Ampersand.Input.ADL1.CtxError
 import Ampersand.Input.ADL1.FilePos (FilePos (..), Origin (..))
-import Ampersand.Input.ADL1.Lexer (keywords)
+import Ampersand.Input.ADL1.Lexer
+  ( Token,
+    keywords,
+    lexer,
+  )
 import Ampersand.Input.ADL1.LexerToken
   ( Lexeme (..),
     Token (..),
@@ -87,7 +95,8 @@ import qualified RIO.Set as Set
 import qualified RIO.Text as T
 import RIO.Time
 import Text.Parsec as P hiding
-  ( satisfy,
+  ( runParser,
+    satisfy,
     sepBy1,
     (<|>),
   )
@@ -498,3 +507,29 @@ posOf parser = do pos <- getPosition; a <- parser; return (posOrigin a pos)
 
 valPosOf :: (Show a) => AmpParser a -> AmpParser (a, Origin)
 valPosOf parser = do pos <- getPosition; a <- parser; return (a, posOrigin a pos)
+
+ampParse :: AmpParser a -> FilePath -> [Token] -> Guarded a
+ampParse p fn ts =
+  -- runP :: Parsec s u a -> u -> FilePath -> s -> Either ParseError a
+  case runP p initialParserState fn ts of
+    -- TODO: Add language support to the parser errors
+    Left err -> Errors $ pure $ PE err
+    Right a -> pure a
+
+-- | Runs the given parser
+runParser ::
+  -- | The parser to run
+  AmpParser a ->
+  -- | Name of the file (for error messages)
+  FilePath ->
+  -- | Text to parse
+  Text ->
+  -- | The result
+  Guarded a
+runParser parser filename input =
+  case lexer filename (T.unpack input) of
+    Left err -> Errors . pure $ lexerError2CtxError err
+    Right (tokens', lexerWarnings) ->
+      addWarnings
+        (map lexerWarning2Warning lexerWarnings)
+        (ampParse parser filename tokens')

src/Ampersand/Commands/AtlasImport.hs → src/Ampersand/Input/AtlasImport.hs

@@ -9,10 +9,11 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- | Generate a configuration file for a new project.
-module Ampersand.Commands.AtlasImport
+module Ampersand.Input.AtlasImport
   ( atlasImport,
     InitOpts (..),
     HasInitOpts (..),
+    parseJsonFile,
   )
 where
 
@@ -52,18 +53,20 @@ import Ampersand.Core.ParseTree
     Role (..),
     TType (..),
     TemplateKeyValue (..),
+    Term,
     TermPrim (PNamedR),
   )
 import Ampersand.Core.ShowPStruct
-import Ampersand.Input.ADL1.CtxError (Guarded (..))
-import Ampersand.Input.Parsing (parseTerm)
+import Ampersand.Input.ADL1.CtxError (Guarded (..), mkJSONParseError)
+import Ampersand.Input.ADL1.Parser (pTerm)
+import Ampersand.Input.ADL1.ParsingLib
 import Ampersand.Misc.HasClasses
 import Ampersand.Types.Config
 import qualified Data.Aeson as JSON
 import Data.Aeson.Key (fromText)
 import qualified Data.Aeson.Types as JSON
 import qualified RIO
-import qualified RIO.ByteString.Lazy as B
+import qualified RIO.ByteString.Lazy as BL
 import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 
@@ -73,7 +76,7 @@ atlasImport ::
   RIO env ()
 atlasImport = do
   env <- ask
-  content <- liftIO $ B.readFile (view importFileL env)
+  content <- liftIO $ BL.readFile (view importFileL env)
   -- Get JSON data and decode it
   let result = myDecode content
   case result of
@@ -83,9 +86,20 @@ atlasImport = do
       writeFileUtf8 outputFn (showP x)
       logInfo . display . T.pack $ outputFn <> " written"
 
-myDecode :: B.ByteString -> Either String P_Context
+myDecode :: BL.ByteString -> Either String P_Context
 myDecode = JSON.eitherDecode
 
+parseJsonFile :: FilePath -> RIO env (Guarded P_Context)
+parseJsonFile fp = do
+  contents <- RIO.readFileBinary fp
+  pure . fromAtlas $ contents
+
+fromAtlas :: ByteString -> Guarded P_Context
+fromAtlas json =
+  case JSON.eitherDecode (BL.fromStrict json) of
+    Left msg -> mkJSONParseError OriginAtlas (T.pack msg)
+    Right a -> pure a
+
 instance JSON.FromJSON P_Context where
   parseJSON :: JSON.Value -> JSON.Parser P_Context
   parseJSON val = case val of
@@ -439,6 +453,9 @@ instance JSON.FromJSON (P_Rule TermPrim) where
             rr_viol = Nothing
           }
 
+parseTerm :: FilePath -> Text -> Guarded (Term TermPrim)
+parseTerm = runParser pTerm
+
 instance JSON.FromJSON (P_Enforce TermPrim) where
   parseJSON val = case val of
     JSON.Object v ->

src/Ampersand/Input/Parsing.hs

@@ -25,19 +25,12 @@ import Ampersand.ADL1
 import Ampersand.Basics
 import Ampersand.Core.ShowPStruct (showP)
 import Ampersand.Input.ADL1.CtxError
-  ( CtxError (PE),
-    Guarded (..),
+  ( Guarded (..),
     addWarnings,
-    lexerError2CtxError,
-    lexerWarning2Warning,
     mkErrorReadingINCLUDE,
     mkParserStateWarning,
     whenCheckedM,
   )
-import Ampersand.Input.ADL1.Lexer
-  ( Token,
-    lexer,
-  )
 import Ampersand.Input.ADL1.Parser
   ( Include (..),
     pContext,
@@ -46,6 +39,7 @@ import Ampersand.Input.ADL1.Parser
   )
 import Ampersand.Input.ADL1.ParsingLib
 import Ampersand.Input.Archi.ArchiAnalyze (archi2PContext)
+import Ampersand.Input.AtlasImport
 import Ampersand.Input.PreProcessor
   ( PreProcDefine,
     preProcess,
@@ -81,7 +75,7 @@ import System.FilePath
     takeExtension,
     (</>),
   )
-import Text.Parsec (getState, runP)
+import Text.Parsec (getState)
 
 -- | Parse Ampersand files and all transitive includes
 parseFilesTransitive ::
@@ -232,6 +226,10 @@ parseSingleADL pc =
               logInfo "ArchiMetaModel.adl written"
             Errors _ -> pure ()
           return ((,[]) <$> ctxFromArchi) -- An Archimate file does not contain include files
+      | -- This feature enables the parsing of .json files, that can be generated with the Atlas.
+        extension == ".json" = do
+          ctxFromAtlas <- catchInvalidJSON $ parseJsonFile filePath
+          return ((,[]) <$> ctxFromAtlas) -- A .json file does not contain include files
       | otherwise = do
           mFileContents <-
             case pcFileKind pc of
@@ -302,32 +300,11 @@ parseSingleADL pc =
           where
             f :: SomeException -> RIO env a
             f exception = fatal ("The file does not seem to have a valid .xlsx structure:\n  " <> tshow exception)
-
-parse :: AmpParser a -> FilePath -> [Token] -> Guarded a
-parse p fn ts =
-  -- runP :: Parsec s u a -> u -> FilePath -> s -> Either ParseError a
-  case runP p initialParserState fn ts of
-    -- TODO: Add language support to the parser errors
-    Left err -> Errors $ pure $ PE err
-    Right a -> pure a
-
--- | Runs the given parser
-runParser ::
-  -- | The parser to run
-  AmpParser a ->
-  -- | Name of the file (for error messages)
-  FilePath ->
-  -- | Text to parse
-  Text ->
-  -- | The result
-  Guarded a
-runParser parser filename input =
-  case lexer filename (T.unpack input) of
-    Left err -> Errors . pure $ lexerError2CtxError err
-    Right (tokens, lexerWarnings) ->
-      addWarnings
-        (map lexerWarning2Warning lexerWarnings)
-        (parse parser filename tokens)
+        catchInvalidJSON :: RIO env a -> RIO env a
+        catchInvalidJSON m = catch m f
+          where
+            f :: SomeException -> RIO env a
+            f exception = fatal ("The file does not seem to have a valid .json structure:\n  " <> tshow exception)
 
 -- | Parses an isolated rule
 -- In order to read derivation rules, we use the Ampersand parser.

src/Ampersand/Misc/Commands.hs

@@ -11,7 +11,6 @@ module Ampersand.Misc.Commands
 where
 
 import Ampersand.Basics
-import Ampersand.Commands.AtlasImport
 import Ampersand.Commands.Daemon
 import Ampersand.Commands.Devoutput
 import Ampersand.Commands.Documentation
@@ -27,7 +26,6 @@ import Ampersand.FSpec (FSpec)
 import Ampersand.FSpec.ToFSpec.CreateFspec
 import Ampersand.Input.ADL1.CtxError
 import Ampersand.Misc.HasClasses
-import Ampersand.Options.AtlasImportOptsParser
 import Ampersand.Options.DaemonParser
 import Ampersand.Options.DevoutputOptsParser
 import Ampersand.Options.DocOptsParser
@@ -133,11 +131,6 @@ commandLineHandler currentDir _progName args =
         "Generate a file that contains the population of your script."
         (mkAction population)
         populationOptsParser
-      addCommand''
-        AtlasImport
-        "Import a file that contains the population of an atlas (json)."
-        atlasImportCmd
-        atlasimportOptsParser
       addCommand''
         Proofs
         "Generate a report containing proofs."
@@ -389,10 +382,6 @@ testCmd :: TestOpts -> RIO Runner ()
 testCmd testOpts =
   extendWith testOpts test
 
-atlasImportCmd :: AtlasImportOpts -> RIO Runner ()
-atlasImportCmd opts = do
-  extendWith opts atlasImport
-
 checkCmd :: FSpecGenOpts -> RIO Runner ()
 checkCmd = mkAction doNothing
   where