fortran-src-extras 0.3.0 → 0.3.1

raw patch · 13 files changed

+1081/−42 lines, 13 filesdep +yamldep ~fortran-srcnew-component:exe:fortran-src-extrasPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: yaml

Dependency ranges changed: fortran-src

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• app/Language/Fortran/Extras/CLI/Serialize.hs +98/−0
• app/Main.hs +29/−0
• app/Raehik/CLI/Stream.hs +90/−0
• fortran-src-extras.cabal +97/−6
• src/Language/Fortran/Extras.hs +29/−1
• src/Language/Fortran/Extras/Encoding.hs +7/−32
• src/Language/Fortran/Extras/JSON.hs +512/−0
• src/Language/Fortran/Extras/JSON/Helpers.hs +97/−0
• src/Language/Fortran/Extras/JSON/Literals.hs +31/−0
• src/Language/Fortran/Extras/JSON/Supporting.hs +74/−0
• src/Language/Fortran/Extras/RunOptions.hs +0/−3
• src/Language/Fortran/Extras/Util.hs +8/−0

@@ -1,3 +1,12 @@+## 0.3.1 (2022-07-18)+  * Update to fortran-src 0.10.0+  * Add helpers for using Fortran 77 include parser with IO actions+    `Language.Fortran.Extras.withToolOptionsAndProgramOrBlock`+  * Add `ToJSON` instances for data types in `Language.Fortran.AST`+    * See `docs/json/schema.md` for notes on migrating from inspiration schema+  * Add fortran-src-extras executable with a command for serializing Fortran+    source into JSON (and YAML)+ ## 0.3.0 (2022-02-15)   * Update to fortran-src 0.9.0   * Remove `Language.Fortran.Extras.ModFiles`. The functions are available

@@ -0,0 +1,98 @@+{-# LANGUAGE DataKinds #-}++-- | Fortran serializer CLI app.+module Language.Fortran.Extras.CLI.Serialize where++import Language.Fortran.Extras.JSON()+import Control.Monad.IO.Class+import qualified Options.Applicative as OA+import qualified Language.Fortran.Parser as F.Parser+import qualified Language.Fortran.Parser.Monad as F.Parser -- TODO moved to Parser in next version+import Language.Fortran.Version+import qualified Raehik.CLI.Stream as CLI+import qualified Data.Char as Char+import qualified System.Exit as System++import qualified Data.Yaml as Yaml+import qualified Data.Aeson as Aeson+import qualified Data.ByteString.Lazy as BL++data Cfg = Cfg+  { cfgDirection :: Direction+  , cfgFormat    :: Format+  , cfgVersion   :: FortranVersion+  } deriving (Eq, Show)++-- | Serialization format.+data Format = FmtJson | FmtYaml+    deriving (Eq, Show)++-- | Coding direction.+--+-- _Encode_ means to consume Fortran source and produce serialized Fortran.+-- _Decode_ means to consume serialized Fortran and produce Fortran source.+data Direction+  = DirEncode (CLI.Stream 'CLI.In  "Fortran source")+              (CLI.Stream 'CLI.Out "serialized Fortran")+  | DirDecode (CLI.Stream 'CLI.In  "serialized Fortran")+              (CLI.Stream 'CLI.Out "Fortran source")+    deriving (Eq, Show)++pCfg :: OA.Parser Cfg+pCfg = Cfg <$> pDirection <*> pFormat <*> pFVersion++pFVersion :: OA.Parser FortranVersion+pFVersion =+    OA.option (OA.maybeReader selectFortranVersion) $+           OA.long "version"+        <> OA.short 'v'+        <> OA.help "Fortran version"+        <> OA.metavar "FORTRAN_VER"++pFormat :: OA.Parser Format+pFormat = OA.option (OA.maybeReader go) $ OA.long "format" <> OA.short 't' <> OA.help "Serialization format (allowed: json, yaml)" <> OA.metavar "FORMAT"+  where+    go x =+        case map Char.toLower x of+          "json" -> Just FmtJson+          "yaml" -> Just FmtYaml+          _      -> Nothing++pDirection :: OA.Parser Direction+pDirection = OA.hsubparser $+       cmd "encode" "Serialize Fortran source to the requested format" pDirectionEncode+    <> cmd "decode" "Process serialized Fortran into Fortran source"   pDirectionDecode++pDirectionEncode, pDirectionDecode :: OA.Parser Direction+pDirectionEncode = DirEncode <$> CLI.pStreamIn <*> CLI.pStreamOut+pDirectionDecode = DirDecode <$> CLI.pStreamIn <*> CLI.pStreamOut++run :: MonadIO m => Cfg -> m (Either F.Parser.ParseErrorSimple ())+run cfg = do+    case cfgDirection cfg of+      DirEncode sIn sOut -> do+        bsIn <- CLI.readStream sIn+        case (F.Parser.byVer (cfgVersion cfg)) (CLI.inStreamFileName sIn) bsIn of+          Left  e   -> return $ Left e+          Right src -> do+            let textBsOut = case cfgFormat cfg of+                       FmtJson -> BL.toStrict $ Aeson.encode src+                       FmtYaml -> Yaml.encode src+            CLI.writeStream sOut textBsOut+            return $ Right ()+      DirDecode _sIn _sOut-> do+        liftIO $ putStrLn "converting from serialized Fortran to Fortran source not yet implemented"+        exit 1++--------------------------------------------------------------------------------+-- IO helpers++exit :: MonadIO m => Int -> m a+exit n = liftIO $ System.exitWith $ System.ExitFailure n++--------------------------------------------------------------------------------+-- CLI helpers++-- | Shorthand for defining a CLI command.+cmd :: String -> String -> OA.Parser a -> OA.Mod OA.CommandFields a+cmd name desc p = OA.command name (OA.info p (OA.progDesc desc))

@@ -0,0 +1,29 @@+module Main where++import qualified Language.Fortran.Extras.CLI.Serialize as Serialize+import qualified Options.Applicative as OA+import Control.Monad.IO.Class++data Cmd+  = CmdSerialize Serialize.Cfg+    deriving (Eq, Show)++main :: IO ()+main = execParserWithDefaults desc pCmd >>= \case+  CmdSerialize cfg -> Serialize.run cfg >>= \case+    Right ()  -> return ()+    Left  err -> print err+  where+    desc = "fortran-src extra tools"++pCmd :: OA.Parser Cmd+pCmd = OA.hsubparser $+       Serialize.cmd "serialize" "Convert between Fortran source and serialized forms" (CmdSerialize <$> Serialize.pCfg)++--------------------------------------------------------------------------------++-- | Execute a 'Parser' with decent defaults.+execParserWithDefaults :: MonadIO m => String -> OA.Parser a -> m a+execParserWithDefaults desc p = liftIO $ OA.customExecParser+    (OA.prefs $ OA.showHelpOnError)+    (OA.info (OA.helper <*> p) (OA.progDesc desc))

@@ -0,0 +1,90 @@+{-# LANGUAGE AllowAmbiguousTypes, TypeApplications, ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE DerivingVia #-}++-- | Common convenience definitions I use for filesystem data I/O.+module Raehik.CLI.Stream where++import GHC.Generics ( Generic )+import Data.Data ( Typeable, Data )+import GHC.TypeLits ( Symbol, KnownSymbol, symbolVal' )+import GHC.Exts ( proxy#, Proxy# )++import Options.Applicative++import Control.Monad.IO.Class+import qualified Data.Char as Char+import qualified Data.ByteString as B++data Stream (d :: Direction) (s :: Symbol)+  = Path' (Path d s)+  | Std+    deriving stock (Generic, Typeable, Data, Show, Eq)++newtype Path (d :: Direction) (s :: Symbol)+  = Path { unPath :: FilePath }+    deriving stock (Generic, Typeable, Data)+    deriving (Show, Eq) via FilePath++data Direction = In | Out+    deriving stock (Generic, Typeable, Data, Show, Eq)++-- | Either a positional filepath, or standalone @--stdin@ switch.+pStreamIn :: forall s. KnownSymbol s => Parser (Stream 'In s)+pStreamIn = (Path' <$> pPathIn) <|> pStdinOpt+  where+    pStdinOpt = flag' Std $  long "stdin"+                          <> help ("Get "<>sym @s<>" from stdin")++-- | Either an @--out-file X@ option, or default to stdout.+pStreamOut :: forall s. KnownSymbol s => Parser (Stream 'Out s)+pStreamOut = (Path' <$> pPathOut) <|> pure Std+  where pPathOut = Path <$> strOption (modFileOut (sym @s))++-- | Positional filepath.+pPathIn :: forall s. KnownSymbol s => Parser (Path 'In s)+pPathIn = Path <$> strArgument (modFileIn (sym @s))++--------------------------------------------------------------------------------++-- | Generate a base 'Mod' for a file type using the given descriptive+--   name (the "type" of input, e.g. file format) and the given direction.+modFile :: HasMetavar f => String -> String -> Mod f a+modFile dir desc =  metavar "FILE" <> help (dir<>" "<>desc)++modFileIn :: HasMetavar f => String -> Mod f a+modFileIn = modFile "Input"++modFileOut :: (HasMetavar f, HasName f) => String -> Mod f a+modFileOut s = modFile "Output" s <> long "out-file" <> short 'o'++metavarify :: String -> String+metavarify = map $ Char.toUpper . spaceToUnderscore+  where spaceToUnderscore = \case ' ' -> '_'; ch -> ch++--------------------------------------------------------------------------------++-- | More succint 'symbolVal' via type application.+sym :: forall s. KnownSymbol s => String+sym = symbolVal' (proxy# :: Proxy# s)++--------------------------------------------------------------------------------++readStream :: forall s m. MonadIO m => Stream 'In s -> m B.ByteString+readStream = liftIO . \case Std             -> B.getContents+                            Path' (Path fp) -> B.readFile fp++writeStream :: forall s m. MonadIO m => Stream 'Out s -> B.ByteString -> m ()+writeStream s bs = liftIO $ case s of Std             -> B.putStr bs+                                      Path' (Path fp) -> B.writeFile fp bs++-- | Returns @<stdin>@ for 'Std'.+inStreamFileName :: Stream 'In s -> FilePath+inStreamFileName = \case Std             -> "<stdin>"+                         Path' (Path fp) -> fp++-- | Returns @<stdout>@ for 'Std'.+outStreamFileName :: Stream 'Out s -> FilePath+outStreamFileName = \case Std             -> "<stdout>"+                          Path' (Path fp) -> fp

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           fortran-src-extras-version:        0.3.0+version:        0.3.1 synopsis:       Common functions and utils for fortran-src. description:    Various utility functions and orphan instances which may be useful when using fortran-src. category:       Language@@ -28,13 +28,38 @@       Language.Fortran.Extras       Language.Fortran.Extras.Analysis       Language.Fortran.Extras.Encoding+      Language.Fortran.Extras.JSON+      Language.Fortran.Extras.JSON.Helpers+      Language.Fortran.Extras.JSON.Literals+      Language.Fortran.Extras.JSON.Supporting       Language.Fortran.Extras.ProgramFile       Language.Fortran.Extras.RunOptions       Language.Fortran.Extras.Test+      Language.Fortran.Extras.Util   other-modules:       Paths_fortran_src_extras   hs-source-dirs:       src+  default-extensions:+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      InstanceSigs+      MultiParamTypeClasses+      PolyKinds+      LambdaCase+      DerivingStrategies+      StandaloneDeriving+      DeriveAnyClass+      DeriveGeneric+      DeriveDataTypeable+      DeriveFunctor+      DeriveFoldable+      DeriveTraversable+      DeriveLift+      BangPatterns+      TupleSections+  ghc-options: -Wall   build-depends:       GenericPretty >=1.2.1     , aeson >=1.2.3.0@@ -45,12 +70,54 @@     , directory >=1.3.0.2     , either >=5.0.0 && <5.1     , filepath >=1.4.1.2-    , fortran-src >=0.9.0+    , fortran-src >=0.10.0     , optparse-applicative >=0.14     , text >=1.2.2.2     , uniplate >=1.6.10   default-language: Haskell2010 +executable fortran-src-extras+  main-is: Main.hs+  other-modules:+      Language.Fortran.Extras.CLI.Serialize+      Raehik.CLI.Stream+      Paths_fortran_src_extras+  hs-source-dirs:+      app+  default-extensions:+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      InstanceSigs+      MultiParamTypeClasses+      PolyKinds+      LambdaCase+      DerivingStrategies+      StandaloneDeriving+      DeriveAnyClass+      DeriveGeneric+      DeriveDataTypeable+      DeriveFunctor+      DeriveFoldable+      DeriveTraversable+      DeriveLift+      BangPatterns+      TupleSections+  ghc-options: -Wall+  build-depends:+      GenericPretty >=1.2.1+    , aeson >=1.2.3.0+    , base >=4.7 && <5+    , bytestring >=0.10.8.1+    , containers >=0.5.0.0+    , fortran-src >=0.10.0+    , fortran-src-extras+    , optparse-applicative >=0.14+    , text >=1.2.2.2+    , uniplate >=1.6.10+    , yaml >=0.11.8.0 && <0.12+  default-language: Haskell2010+ test-suite spec   type: exitcode-stdio-1.0   main-is: Spec.hs@@ -60,15 +127,39 @@       Paths_fortran_src_extras   hs-source-dirs:       test-  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  default-extensions:+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      InstanceSigs+      MultiParamTypeClasses+      PolyKinds+      LambdaCase+      DerivingStrategies+      StandaloneDeriving+      DeriveAnyClass+      DeriveGeneric+      DeriveDataTypeable+      DeriveFunctor+      DeriveFoldable+      DeriveTraversable+      DeriveLift+      BangPatterns+      TupleSections+  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N   build-tool-depends:       hspec-discover:hspec-discover   build-depends:-      base >=4.7 && <5-    , either >=5.0.0 && <5.1-    , fortran-src >=0.9.0+      GenericPretty >=1.2.1+    , aeson >=1.2.3.0+    , base >=4.7 && <5+    , bytestring >=0.10.8.1+    , containers >=0.5.0.0+    , fortran-src >=0.10.0     , fortran-src-extras     , hspec >=2.2 && <3+    , optparse-applicative >=0.14     , silently ==1.2.*+    , text >=1.2.2.2     , uniplate >=1.6.10   default-language: Haskell2010

@@ -1,10 +1,13 @@+{-# LANGUAGE TupleSections #-}+ module Language.Fortran.Extras where  import           Control.Exception              ( try                                                 , SomeException                                                 ) import           Data.Data                      ( Data )-import           Data.List                      ( find )+import           Data.List                      ( find+                                                ) import           Data.Maybe                     ( fromMaybe                                                 , mapMaybe                                                 )@@ -20,6 +23,7 @@                                                 , puSrcName                                                 ) import           Language.Fortran.Version       ( FortranVersion(..) )+import           System.FilePath                ( takeExtension ) import           System.Exit                    ( ExitCode(..)                                                 , exitWith                                                 )@@ -28,6 +32,7 @@                                                 , stderr                                                 ) import           Options.Applicative+import           Language.Fortran.Parser        ( f77lIncIncludes ) import qualified Language.Fortran.Extras.ProgramFile                                                as P import qualified Language.Fortran.Extras.Analysis@@ -86,6 +91,11 @@       P.versionedExpandedProgramFile fVersion pfIncludes pfPath pfContents     _ -> return $ P.versionedProgramFile fVersion pfPath pfContents +incFile :: FortranSrcRunOptions -> IO [Block A0]+incFile options = do+  (pfPath, pfContents, pfIncludes, _fVersion) <- unwrapFortranSrcOptions options+  f77lIncIncludes pfIncludes pfPath pfContents+ -- | Get a 'ProgramFile' with 'Analysis' from version and path specified -- in 'FortranSrcRunOptions' programAnalysis :: FortranSrcRunOptions -> IO (ProgramFile (Analysis A0))@@ -202,6 +212,24 @@           (fortranSrcOpts options, toolOpts options)     results <- try $ programAnalysis fortranSrcOptions >>= handler toolOptions     errorHandler (path fortranSrcOptions) results++-- | Given a program description, a program header, cli options parser, and a+-- handler which takes the cli options and either an include files '[Block A0]'+-- or 'Programfile A0', run the handler on the appropriately parsed source,+-- parsing anything that has the ".inc" extension as an include+withToolOptionsAndProgramOrBlock+  :: String+  -> String+  -> Parser a+  -> (a -> Either (FilePath, [Block A0]) (ProgramFile A0) -> IO ())+  -> IO ()+withToolOptionsAndProgramOrBlock programDescription programHeader optsParser handler = do+  RunOptions srcOptions toolOptions <-+    getRunOptions programDescription programHeader optsParser+  ast <- if takeExtension (path srcOptions) == ".inc"+    then Left . (path srcOptions, ) <$> incFile srcOptions+    else Right <$> programFile srcOptions+  handler toolOptions ast  -- | Given a 'ProgramUnit' return a pair of the name of the unit as well as the unit itself -- only if the 'ProgramUnit' is a 'PUMain', 'PUSubroutine', or a 'PUFunction'

@@ -1,46 +1,21 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  -- | Utils and Aeson orphan instances for common types in the AST.+--+-- Partially deprecated by proper JSON serialization support. module Language.Fortran.Extras.Encoding where -import           Data.Aeson                     ( ToJSON-                                                , FromJSON-                                                , encode-                                                )-import           Language.Fortran.AST           ( BaseType )-import           Language.Fortran.Analysis.SemanticTypes-                                                ( CharacterLen-                                                , SemType-                                                )-import           Language.Fortran.Version       ( FortranVersion(..) )-import           Language.Fortran.PrettyPrint   ( IndentablePretty-                                                , pprintAndRender-                                                )-import           Language.Fortran.Util.Position ( Position-                                                , SrcSpan-                                                )-import           Data.ByteString.Lazy           ( ByteString )+import Language.Fortran.Extras.JSON()+import Data.Aeson ( ToJSON, encode )+import Data.ByteString.Lazy ( ByteString )+import Language.Fortran.PrettyPrint ( IndentablePretty, pprintAndRender )+import Language.Fortran.Version ( FortranVersion(..) )  -- | Provide a wrapper for the 'Data.Aeson.encode' function to allow -- indirect use in modules importing -- 'Language.Fortran.Extras.Encoding'. commonEncode :: ToJSON a => a -> ByteString commonEncode = encode--instance ToJSON Position-instance FromJSON Position--instance ToJSON SrcSpan-instance FromJSON SrcSpan--instance ToJSON CharacterLen-instance FromJSON CharacterLen--instance ToJSON SemType-instance FromJSON SemType--instance ToJSON BaseType-instance FromJSON BaseType  -- | Render some AST element to a 'String' using F77 legacy mode. pprint77l :: IndentablePretty a => a -> String

@@ -0,0 +1,512 @@+{- | Aeson instances for the Fortran AST defined in fortran-src.++As of fortran-src v0.10.0, most node types store an annotation and a 'SrcSpan'.+The general approach to instance design is as follows:++  * Annotations are placed in @anno@ fields.+  * Spans are placed in @span@ fields.+  * Where possible, we use a generic derivation that takes field names from the+    data type. (This works for most single-constructor product types.)+  * For sum types, an object is created storing an annotation, span and tag. The+    tag indicates the constructor being used. The other fields are then+    "flattened" into the tag object. (This isn't what Aeson's generic derivation+    does by default due to safety concerns, but it can be nicer for JSON.)++-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Fortran.Extras.JSON() where++import Language.Fortran.Extras.JSON.Helpers+import Language.Fortran.Extras.JSON.Supporting()+import Language.Fortran.Extras.JSON.Literals()+import Data.Aeson hiding ( Value )+import Language.Fortran.AST+import qualified Data.Text as Text+import Data.Text ( Text )++-- Assorted+-- DerivingVia needs GHC 8.6+--deriving via String instance ToJSON (Comment a)+instance ToJSON (Comment a) where+    toJSON     (Comment str) = toJSON     str+    toEncoding (Comment str) = toEncoding str++instance ToJSON BaseType where+    toJSON     = toJSON     . aesonBaseTypeHelper+    toEncoding = toEncoding . aesonBaseTypeHelper++aesonBaseTypeHelper :: BaseType -> Text+aesonBaseTypeHelper = \case+  TypeInteger         -> "integer"+  TypeReal            -> "real"+  TypeDoublePrecision -> "double_precision"+  TypeComplex         -> "complex"+  TypeDoubleComplex   -> "double_complex"+  TypeLogical         -> "logical"+  TypeCharacter       -> "character"+  TypeCustom a        -> "custom:"<>Text.pack a+  TypeByte            -> "byte"+  ClassStar           -> "star"+  ClassCustom a       -> "custom:class:"<>Text.pack a++instance ToJSON Intent where+    toJSON     = gtj $ jcEnumDrop ""+    toEncoding = gte $ jcEnumDrop ""++-- USE statements+instance ToJSON ModuleNature where+    toJSON     = gtj $ jcEnumDrop "Mod"+    toEncoding = gte $ jcEnumDrop "Mod"+instance ToJSON Only where+    toJSON     = gtj $ jcEnumDrop ""+    toEncoding = gte $ jcEnumDrop ""++-- Expressions+instance ToJSON UnaryOp where+    toJSON     = gtj $ jcSumDrop ""+    toEncoding = gte $ jcSumDrop ""+instance ToJSON BinaryOp where+    toJSON     = gtj $ jcSumDrop ""+    toEncoding = gte $ jcSumDrop ""++--------------------------------------------------------------------------------++-- standalone apart from a, SrcSpan+instance ToJSON a => ToJSON (Prefix a) where toJSON = gtj $ jcSumDrop "Pfx"++instance ToJSON a => ToJSON (Value a) where+    toJSON     = gtj $ jcSumDrop "Val"+    toEncoding = gte $ jcSumDrop "Val"++instance ToJSON a => ToJSON (Selector a) where+    toJSON     = gtj $ jcProdDrop "selector"+    toEncoding = gte $ jcProdDrop "selector"++instance ToJSON a => ToJSON (TypeSpec a) where+    toJSON     = gtj $ jcProdDrop "typeSpec"+    toEncoding = gte $ jcProdDrop "typeSpec"++instance ToJSON a => ToJSON (DimensionDeclarator a) where+    toJSON     = gtj $ jcProdDrop "dimDecl"+    toEncoding = gte $ jcProdDrop "dimDecl"++instance ToJSON a => ToJSON (Declarator a) where+    toJSON     d = object $ fieldsMain <> fieldsType+      where+        fieldsMain =+          [ "anno"     .= declaratorAnno     d+          , "span"     .= declaratorSpan     d+          , "variable" .= declaratorVariable d+          , "length"   .= declaratorLength   d+          , "initial"  .= declaratorInitial  d+          ]+        fieldsType = case declaratorType d of+                       ScalarDecl      -> [ "type" .= String "scalar" ]+                       ArrayDecl  dims -> [ "type" .= String "array"+                                          , "dims" .= toJSON dims ]+    -- TODO toEncoding++instance ToJSON a => ToJSON (Suffix a) where+    toJSON (SfxBind a s e) = tja "bind" a s ["expression" .= e]+    -- TODO toEncoding++instance ToJSON a => ToJSON (Attribute a) where+    toJSON = \case+      AttrParameter    a s      -> tja "parameter" a s []+      AttrPublic       a s      -> tja "public" a s []+      AttrProtected    a s      -> tja "protected" a s []+      AttrPrivate      a s      -> tja "private" a s []+      AttrAllocatable  a s      -> tja "allocatable" a s []+      AttrDimension    a s dims -> tja "dimension" a s ["dimensions" .= dims]+      AttrExternal     a s      -> tja "external" a s []+      AttrIntent       a s int  -> tja "intent" a s ["intent" .= int]+      AttrOptional     a s      -> tja "optional" a s []+      AttrPointer      a s      -> tja "pointer" a s []+      AttrSave         a s      -> tja "save" a s []+      AttrTarget       a s      -> tja "target" a s []+      AttrIntrinsic    a s      -> tja "intrinsic" a s []+      AttrAsynchronous a s      -> tja "asynchronous" a s []+      AttrSuffix       a s sfx  -> tja "suffix" a s ["suffix" .= sfx]+      AttrValue        a s      -> tja "value" a s []+      AttrVolatile     a s      -> tja "volatile" a s []+    -- TODO toEncoding++--------------------------------------------------------------------------------++instance ToJSON a => ToJSON (StructureItem a) where+    toJSON = \case+      StructFields a s t attrs decls -> tja "fields" a s+        ["type" .= t, "attributes" .= attrs, "declarators" .= decls]+      StructUnion a s maps -> tja "union" a s ["maps" .= maps]+      StructStructure a s name fname decls -> tja "structure" a s+        ["name" .= fname, "substructure_name" .= name, "fields" .= decls]+    -- TODO toEncoding+instance ToJSON a => ToJSON (UnionMap a) where+    toJSON     = gtj $ jcProdDrop "unionMap"+    toEncoding = gte $ jcProdDrop "unionMap"++-- TODO rec: Expression+instance ToJSON a => ToJSON (DataGroup a) where+    toJSON     = gtj $ jcProdDrop "dataGroup"+    toEncoding = gte $ jcProdDrop "dataGroup"++-- TODO rec: Expression (only ExpValue (ValVariable))+instance ToJSON a => ToJSON (Namelist a) where+    toJSON     = gtj $ jcProdDrop "namelist"+    toEncoding = gte $ jcProdDrop "namelist"++instance ToJSON a => ToJSON (CommonGroup a) where+    toJSON     = gtj $ jcProdDrop "commonGroup"+    toEncoding = gte $ jcProdDrop "commonGroup"++-- TODO not in original package, no field names+instance ToJSON a => ToJSON (FormatItem a) where+    toJSON     = gtj $ jcSumDrop "FI"+    toEncoding = gte $ jcSumDrop "FI"++instance ToJSON a => ToJSON (ImpList a) where+    toJSON     = gtj $ jcProdDrop "impList"+    toEncoding = gte $ jcProdDrop "impList"++instance ToJSON a => ToJSON (ImpElement a) where+    toJSON     = gtj $ jcProdDrop "impElement"+    toEncoding = gte $ jcProdDrop "impElement"++-- random+instance ToJSON a => ToJSON (ControlPair a) where+    toJSON     = gtj $ jcProdDrop "controlPair"+    toEncoding = gte $ jcProdDrop "controlPair"++instance ToJSON a => ToJSON (FlushSpec a) where+    toJSON     = \case+      FSUnit   a s e -> tja "unit" a s ["expression" .= e]+      FSIOStat a s e -> tja "unit" a s ["expression" .= e]+      FSIOMsg  a s e -> tja "unit" a s ["expression" .= e]+      FSErr    a s e -> tja "unit" a s ["expression" .= e]+    -- TODO toEncoding++instance ToJSON a => ToJSON (AllocOpt a) where+    toJSON     = \case+      AOStat   a s e -> tja "stat" a s ["expression" .= e]+      AOErrMsg a s e -> tja "stat" a s ["expression" .= e]+      AOSource a s e -> tja "stat" a s ["expression" .= e]+    -- TODO toEncoding++instance ToJSON a => ToJSON (Use a) where+    toJSON     = \case+      UseRename a s eLocal eUse -> tja "rename" a s+        [ "local" .= eLocal, "use" .= eUse ]+      UseID     a s e           -> tja "id"     a s ["name" .= e]+    -- TODO toEncoding++instance ToJSON a => ToJSON (ProcInterface a) where+    toJSON     = \case+      ProcInterfaceName a s e -> tja "name" a s ["name" .= e]+      ProcInterfaceType a s t -> tja "type" a s ["type" .= t]+    -- TODO toEncoding++instance ToJSON a => ToJSON (ProcDecl a) where+    toJSON     = gtj $ jcProdDrop "procDecl"+    toEncoding = gte $ jcProdDrop "procDecl"++-- depends on statement, expression+instance ToJSON a => ToJSON (DoSpecification a) where+    toJSON     = gtj $ jcProdDrop "doSpec"+    toEncoding = gte $ jcProdDrop "doSpec"++instance ToJSON a => ToJSON (Index a) where+  toJSON idx = case idx of+    IxSingle a s nm e    -> tja "single" a s ["name" .= nm, "index" .= e]+    IxRange  a s l  u st -> tja "range"  a s+        ["lower" .= l, "upper" .= u, "stride" .= st]+    -- TODO toEncoding++instance ToJSON a => ToJSON (Argument a) where+    toJSON     = gtj $ jcProdDrop "argument"+    toEncoding = gte $ jcProdDrop "argument"++-- weird part of the AST due to annotations and naming+instance ToJSON a => ToJSON (ArgumentExpression a) where+    toJSON     = gtj $ jcSumDrop "Arg"+    toEncoding = gte $ jcSumDrop "Arg"++instance ToJSON a => ToJSON (ForallHeader a) where+    toJSON     = gtj $ jcProdDrop "forallHeader"+    toEncoding = gte $ jcProdDrop "forallHeader"++instance ToJSON a => ToJSON (ForallHeaderPart a) where+    toJSON     = gtj $ jcProdDrop "forallHeaderPart"+    toEncoding = gte $ jcProdDrop "forallHeaderPart"++instance ToJSON MetaInfo where+    toJSON     = gtj $ jcSumDrop "mi"+    toEncoding = gte $ jcSumDrop "mi"++instance ToJSON a => ToJSON (ProgramFile a) where+    toJSON     = gtj $ jcProdDrop "programFile"+    toEncoding = gte $ jcProdDrop "programFile"++instance ToJSON a => ToJSON (Expression a) where+    toJSON = \case+      ExpValue          a s val      ->+        tja "value"          a s ["value" .= val]+      ExpBinary         a s op el er ->+        tja "binary"         a s ["op" .= op, "left" .= el, "right" .= er]+      ExpUnary          a s op e ->+        tja "unary"          a s ["op" .= op, "expression" .= e]+      ExpSubscript      a s e idxs ->+        tja "subscript"      a s ["expression" .= e, "indices" .= idxs]+      ExpDataRef        a s e1 e2 ->+        tja "deref"          a s ["expression" .= e1, "field" .= e2]+      ExpFunctionCall   a s fn args ->+        tja "function_call"  a s ["function" .= fn, "arguments" .= args]+      ExpImpliedDo      a s exps spec ->+        tja "implied_do"     a s ["expressions" .= exps, "do_spec" .= spec]+      ExpInitialisation a s exps ->+        tja "initialisation" a s ["expressions" .= exps]+      ExpReturnSpec     a s tgt  ->+        tja "return_spec"    a s ["target" .= tgt]+    -- TODO toEncoding++instance ToJSON a => ToJSON (Block a) where+    toJSON = \case+      BlStatement a s l st -> tja "statement" a s+        ["label" .= l, "statement" .= st]+      BlIf a s l nm conds blocks endlabel -> tja "if" a s+        [ "label"      .= l+        , "name"       .= nm+        , "conditions" .= conds+        , "blocks"     .= blocks+        , "end_label"  .= endlabel+        ]+      BlCase a s l nm scrut ranges blocks endlabel -> tja "case" a s+        [ "label"     .= l+        , "name"      .= nm+        , "scrutinee" .= scrut+        , "ranges"    .= ranges+        , "blocks"    .= blocks+        , "end_label" .= endlabel+        ]+      BlDo a s l nm target dospec body endlabel -> tja "do" a s+        [ "label"     .= l+        , "name"      .= nm+        , "target"    .= target+        , "do_spec"   .= dospec+        , "body"      .= body+        , "end_label" .= endlabel+        ]+      BlDoWhile a s l nm target cond body endlabel -> tja "do_while" a s+        [ "label"     .= l+        , "name"      .= nm+        , "target"    .= target+        , "condition" .= cond+        , "body"      .= body+        , "end_label" .= endlabel+        ]+      BlInterface a s l decls blocks _ -> tja "interface" a s+        ["label" .= l, "declarations" .= decls, "blocks" .= blocks]+      BlForall a s ml mn h bs mel -> tja "forall" a s+        [ "label"     .= ml+        , "name"      .= mn+        , "header"    .= h+        , "blocks"    .= bs+        , "end_label" .= mel+        ]+      BlAssociate a s ml mn abbrevs bs mel -> tja "associate" a s+        [ "label"     .= ml+        , "name"      .= mn+        , "abbrevs"   .= abbrevs+        , "blocks"    .= bs+        , "end_label" .= mel+        ]+      BlComment a s c -> tja "comment" a s ["comment" .= c]+    -- TODO toEncoding++instance ToJSON a => ToJSON (ProgramUnit a) where+    toJSON = \case+      PUMain a s name blocks pus -> tja "main" a s+        ["name" .= name, "blocks" .= blocks, "subprograms" .= pus]+      PUModule a s name blocks pus -> tja "module" a s+        ["name" .= name, "blocks" .= blocks, "subprograms" .= pus]+      PUSubroutine a s pfxsfx name args blocks pus -> tja "subroutine" a s+        [ "name"        .= name+        , "arguments"   .= args+        , "blocks"      .= blocks+        , "subprograms" .= pus+        , "options"     .= pfxsfx+        ]+      PUFunction a s t _ name args res blocks pus -> tja "function" a s+        [ "name" .= name+        , "type" .= t+        , "arguments" .= args+        , "blocks" .= blocks+        , "result" .= res+        , "subprograms" .= pus+        ]+      PUBlockData a s name blocks -> tja "block_data" a s+        ["name" .= name, "blocks" .= blocks]+      PUComment a s c -> tja "comment" a s ["comment" .= c]+    -- TODO toEncoding++instance ToJSON a => ToJSON (Statement a) where+    toJSON st = case st of+      StOptional    a s es -> tja "optional"  a s ["vars" .= es]+      StPublic      a s es -> tja "public"    a s ["vars" .= es]+      StPrivate     a s es -> tja "private"   a s ["vars" .= es]+      StProtected   a s es -> tja "protected" a s ["vars" .= es]+      StExternal    a s es -> tja "external"  a s ["vars" .= es]+      StIntrinsic   a s es -> tja "intrinsic" a s ["vars" .= es]++      StDimension    a s ds -> tja "dimension"    a s ["declarators" .= ds]+      StAllocatable  a s ds -> tja "allocatable"  a s ["declarators" .= ds]+      StAsynchronous a s ds -> tja "asynchronous" a s ["declarators" .= ds]+      StPointer      a s ds -> tja "pointer"      a s ["declarators" .= ds]+      StTarget       a s ds -> tja "target"       a s ["declarators" .= ds]+      StValue        a s ds -> tja "value"        a s ["declarators" .= ds]+      StVolatile     a s ds -> tja "volatile"     a s ["declarators" .= ds]+      StParameter    a s ds -> tja "parameter"    a s ["declarators" .= ds]+      StAutomatic    a s ds -> tja "automatic"    a s ["declarators" .= ds]+      StStatic       a s ds -> tja "static"       a s ["declarators" .= ds]++      StDeclaration a s t attrs ds -> tja "declaration" a s+        ["type" .= t, "attributes" .= attrs, "declarators" .= ds]+      StStructure a s name ds -> tja "structure" a s+        ["name" .= name, "fields" .= ds]+      StIntent a s intent es      -> tja "intent" a s+        ["intent" .= intent, "vars" .= es]++      StSave a s args -> tja "save" a s ["vars" .= args]++      StData a s args     -> tja "data" a s ["data_groups" .= args]+      StNamelist a s nls -> tja "namelist" a s ["namelists" .= nls]+      StCommon a s args -> tja "common" a s ["common_groups" .= args]+      StEquivalence a s args -> tja "equivalence" a s ["groups" .= args]+      StFormat a s fis -> tja "format" a s ["parts" .= fis]+      StImplicit a s itms    -> tja "implicit" a s ["items" .= itms]+      StEntry a s v args r -> tja "entry" a s+        ["name" .= v, "args" .= args, "return" .= r]+      StInclude a s path blocks -> tja "include" a s+        ["path" .= path, "blocks" .= blocks]++      StDo      a s nm lbl spec -> tja "do"       a s+        ["name" .= nm, "label" .= lbl, "do_spec" .= spec]+      StDoWhile a s nm lbl cond -> tja "do_while" a s+        ["name" .= nm, "label" .= lbl, "condition" .= cond]+      StEnddo   a s nm          -> tja "end_do"   a s ["name" .= nm]++      StCycle a s v -> tja "cycle" a s ["var" .= v]+      StExit  a s v -> tja "exit"  a s ["var" .= v]++      StFormatBogus a s fmt -> tja "format" a s ["format" .= fmt]++      StForallStatement a s h stmt -> tja "forall_statement" a s+        ["header" .= h, "statement" .= stmt]++      StIfLogical a s cond stmt -> tja "if_logical" a s+        ["condition" .= cond, "statement" .= stmt]+      StIfArithmetic a s e lt eq gt -> tja "if_arithmetic" a s+        [ "expression"    .= e+        , "less"    .= lt+        , "equal"   .= eq+        , "greater" .= gt ]++      StSelectCase a s nm e    -> tja "select_case" a s+        ["name" .= nm, "expression" .= e]+      StCase       a s nm idxs -> tja "case"        a s+        ["name" .= nm, "indices" .= idxs]+      StEndcase    a s nm      -> tja "end_select"  a s+        ["name" .= nm]++      StFunction a s fn args body -> tja "function" a s+        ["name" .= fn, "arguments" .= args, "body" .= body]++      StExpressionAssign a s tgt e     -> tja "assign_expression" a s+        ["target" .= tgt, "expression" .= e]+      StPointerAssign    a s eFrom eTo -> tja "assign_pointer"    a s+        ["target" .= eFrom, "expression" .= eTo]+      StLabelAssign      a s lbl tgt   -> tja "assign_label"      a s+        ["target" .= tgt, "label" .= lbl]++      StGotoUnconditional a s tgt      -> tja "goto"          a s+        ["target" .= tgt]+      StGotoAssigned      a s tgt lbls -> tja "goto_assigned" a s+        ["target" .= tgt, "labels" .= lbls]+      StGotoComputed      a s lbls tgt -> tja "goto_computed" a s+        ["target" .= tgt, "labels" .= lbls]++      StCall   a s fn args -> tja "call"   a s+        ["function" .= fn, "arguments" .= args]+      StReturn a s tgt     -> tja "return" a s+        ["span" .= s, "target" .= tgt]++      StContinue a s     -> tja "continue" a s []+      StStop     a s msg -> tja "stop"     a s ["message" .= msg]+      StPause    a s msg -> tja "pause"    a s ["message" .= msg]++      StRead      a s fmt args -> tja "read"  a s+        ["format" .= fmt, "arguments" .= args]+      StRead2     a s fmt args -> tja "read2" a s+        ["format" .= fmt, "arguments" .= args]+      StWrite     a s fmt args -> tja "write" a s+        ["format" .= fmt, "arguments" .= args]+      StPrint     a s fmt args -> tja "print" a s+        ["format" .= fmt, "arguments" .= args]+      StTypePrint a s fmt args -> tja "type_print"  a s+        ["format" .= fmt, "arguments" .= args]++      StOpen       a s spec -> tja "open"       a s ["specification" .= spec]+      StClose      a s spec -> tja "close"      a s ["specification" .= spec]+      StFlush      a s spec -> tja "flush"      a s ["specification" .= spec]+      StInquire    a s spec -> tja "inquire"    a s ["specification" .= spec]+      StRewind     a s spec -> tja "rewind"     a s ["specification" .= spec]+      StRewind2    a s spec -> tja "rewind2"    a s ["specification" .= spec]+      StBackspace  a s spec -> tja "backspace"  a s ["specification" .= spec]+      StBackspace2 a s spec -> tja "backspace2" a s ["specification" .= spec]+      StEndfile    a s spec -> tja "endfile"    a s ["specification" .= spec]+      StEndfile2   a s spec -> tja "endfile2"   a s ["specification" .= spec]++      StAllocate   a s t es os -> tja "allocate"   a s+        ["type" .= t, "pointers" .= es, "options" .= os]+      StNullify    a s es      -> tja "nullify"    a s+        ["pointers" .= es]+      StDeallocate a s es os   -> tja "deallocate" a s+        ["pointers" .= es, "options" .= os]++      StWhere a s e asn -> tja "where" a s+        ["expression" .= e, "assignment" .= asn]++      StWhereConstruct a s nm e -> tja "where_start" a s+        ["name" .= nm, "expression" .= e]+      StElsewhere      a s nm e -> tja "elsewhere"   a s+        ["name" .= nm, "expression" .= e]+      StEndWhere       a s nm   -> tja "end_where"   a s+        ["name" .= nm]++      StUse a s nm mn only imports -> tja "use" a s+        ["module" .= nm, "nature" .= mn, "only" .= only, "import" .= imports]+      StModuleProcedure a s vs -> tja "module_procedure" a s+        ["procedures" .= vs]++      StType    a s attrs nm -> tja "type"     a s+        ["attributes" .= attrs, "name" .= nm]+      StEndType a s       nm -> tja "end_type" a s+        ["name" .= nm]++      StSequence a s -> tja "sequence" a s []++      StForall    a s nm h -> tja "forall"     a s ["name" .= nm, "header" .= h]+      StEndForall a s nm   -> tja "end_forall" a s ["name" .= nm]++      StProcedure a s iface attrs decls -> tja "procedure" a s+        ["interface" .= iface, "attributes" .= attrs, "declarations" .= decls]++      StImport a s nms -> tja "import" a s ["names" .= nms]++      StEnum       a s ->       tja "enum"       a s []+      StEnumerator a s decls -> tja "enumerator" a s ["declarators" .= decls]+      StEndEnum    a s ->       tja "end_enum"   a s []++    -- TODO toEncoding

@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}++{- | Helpers for defining Aeson instances for fortran-src types.++To work around dependency awkwardness, we have to write an unusual concrete+context @'ToJSON' 'SrcSpan'@. It seems to work fine.+-}++module Language.Fortran.Extras.JSON.Helpers+  ( toJSONAnnoMerge+  , toJSONAnnoTaggedObj+  , jcProd, jcProdDrop+  , jcSum, jcSumDrop+  , jcEnum, jcEnumDrop+  , tja, gtj, gte+  ) where++import Data.Aeson hiding ( Value )+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson+import Language.Fortran.Util.Position ( SrcSpan )+import Data.Text ( Text )++import GHC.Generics ( Generic, Rep )++-- | Shortcut for writing a 'toJSON' definition for a fortran-src AST node type,+--   intended to be used for sum types.+--+-- Flat/concise version which merges all keys into the same object.+toJSONAnnoMerge+    :: (ToJSON a, ToJSON SrcSpan)+    => Text -> a -> SrcSpan -> [Aeson.Pair] -> Aeson.Value+toJSONAnnoMerge t a ss m = object $+  [ "anno"     .= a+  , "span"     .= ss+  , "tag"      .= t ] <> m++-- | Shortcut for writing a 'toJSON' definition for a fortran-src AST node type,+--   intended to be used for sum types.+--+-- "Safe" version which approximates Aeson's default 'Data.Aeson.TaggedObject'+-- sum encoding strategy, but with two extra fields extracted out.+toJSONAnnoTaggedObj+    :: (ToJSON a, ToJSON SrcSpan)+    => Text -> a -> SrcSpan -> [Aeson.Pair] -> Aeson.Value+toJSONAnnoTaggedObj t a ss m = object+  [ "anno"     .= a+  , "span"     .= ss+  , "tag"      .= t+  , "contents" .= object m ]++-- | Shortcut for selected fortran-src AST node type 'toJSON' strategy.+tja :: (ToJSON a, ToJSON SrcSpan)+    => Text -> a -> SrcSpan -> [Aeson.Pair] -> Aeson.Value+tja = toJSONAnnoMerge++-- | Base Aeson generic deriver config for product types.+jcProd :: (String -> String) -> Aeson.Options+jcProd f = Aeson.defaultOptions+  { Aeson.rejectUnknownFields = True+  , Aeson.fieldLabelModifier = Aeson.camelTo2 '_' . f+  }++jcProdDrop :: String -> Aeson.Options+jcProdDrop x = jcProd (drop (length x))++-- | Base Aeson generic deriver config for sum types.+jcSum :: (String -> String) -> String -> String -> Aeson.Options+jcSum f tag contents = Aeson.defaultOptions+  { Aeson.rejectUnknownFields = True+  , Aeson.constructorTagModifier = Aeson.camelTo2 '_' . f+  , Aeson.sumEncoding = Aeson.TaggedObject+    { Aeson.tagFieldName = tag+    , Aeson.contentsFieldName = contents+    }+  }++jcSumDrop :: String -> Aeson.Options+jcSumDrop x = jcSum (drop (length x)) "tag" "contents"++-- | Base Aeson generic deriver config for enum types (no fields in any cons).+jcEnum :: (String -> String) -> Aeson.Options+jcEnum f = Aeson.defaultOptions+  { Aeson.rejectUnknownFields = True+  , Aeson.constructorTagModifier = Aeson.camelTo2 '_' . f+  }++jcEnumDrop :: String -> Aeson.Options+jcEnumDrop = jcEnum . drop . length++-- | Shortcut for common function 'genericToJSON'+gtj :: (Generic a, Aeson.GToJSON' Aeson.Value Aeson.Zero (Rep a)) => Aeson.Options -> a -> Aeson.Value+gtj = genericToJSON++-- | Shortcut for common function 'genericToEncoding'+gte :: (Generic a, Aeson.GToJSON' Aeson.Encoding Aeson.Zero (Rep a)) => Aeson.Options -> a -> Aeson.Encoding+gte = genericToEncoding

@@ -0,0 +1,31 @@+-- | Aeson instances for definitions used for representing Fortran literals.++{-# OPTIONS_GHC -fno-warn-orphans #-}++module Language.Fortran.Extras.JSON.Literals() where++import Language.Fortran.Extras.JSON.Helpers+import Language.Fortran.Extras.JSON.Supporting()+import Data.Aeson+import Language.Fortran.AST.Literal+import qualified Language.Fortran.AST.Literal.Boz as Boz+import Language.Fortran.AST.Literal.Boz+import qualified Language.Fortran.AST.Literal.Real as Real+import Language.Fortran.AST.Literal.Real+import Language.Fortran.AST.Literal.Complex++instance ToJSON a => ToJSON (KindParam a) where toJSON = gtj $ jcSumDrop "KindParam"++-- TODO override to reparse/print?+instance ToJSON Boz.Conforming where toJSON = gtj $ jcEnum id+instance ToJSON BozPrefix where toJSON = gtj $ jcEnumDrop "BozPrefix"+instance ToJSON Boz where toJSON = gtj $ jcProd $ drop $ length "boz"++-- TODO override to reparse/print?+instance ToJSON Real.ExponentLetter where toJSON = gtj $ jcEnumDrop "ExpLetter"+instance ToJSON Real.Exponent where toJSON = gtj $ jcProdDrop "exponent"+instance ToJSON RealLit where toJSON = gtj $ jcProdDrop "realLit"++-- TODO override to reparse/print?+instance ToJSON a => ToJSON (ComplexPart a) where toJSON = gtj $ jcSumDrop "ComplexPart"+instance ToJSON a => ToJSON (ComplexLit a) where toJSON = gtj $ jcProdDrop "complexLit"

@@ -0,0 +1,74 @@+-- | Aeson instances for "small" definitions used in representing Fortran code.++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings #-}++module Language.Fortran.Extras.JSON.Supporting() where++import Language.Fortran.Extras.JSON.Helpers+import Language.Fortran.Extras.Util+import Data.Aeson+import Language.Fortran.Util.Position+import Language.Fortran.Version+import Language.Fortran.AST.AList++instance (ToJSON (t a), ToJSON a) => ToJSON (AList t a) where+    toJSON     = gtj $ jcProdDrop "alist"+    toEncoding = gte $ jcProdDrop "alist"+instance (ToJSON a, ToJSON (t1 a), ToJSON (t2 a)) => ToJSON (ATuple t1 t2 a) where+    toJSON     = gtj $ jcProdDrop "atuple"+    toEncoding = gte $ jcProdDrop "atuple"++instance ToJSON FortranVersion where+    toJSON     = gtj $ jcEnumDrop mempty+    toEncoding = gte $ jcEnumDrop mempty++instance ToJSON Position where+    toJSON     = String . tshow+    toEncoding = toEncoding . tshow+instance ToJSON SrcSpan where+    toJSON     = String . tshow+    toEncoding = toEncoding . tshow++{- FromJSON instances++import Text.Megaparsec+import Text.Megaparsec.Char+import Text.Megaparsec.Char.Lexer qualified as L+import Data.Void ( Void )+import Data.Text ( Text )+import Data.Functor ( void )++-- TODO better error reporting+instance FromJSON Position where+    parseJSON  = withText "position" $ \t ->+        case parseMaybe pPosition t of+          Nothing  -> fail "failed to parse position"+          Just pos -> pure pos++-- TODO better error reporting+instance FromJSON SrcSpan where+    parseJSON  = withText "SrcSpan" $ \t ->+        case parseMaybe pSrcSpan t of+          Nothing -> fail "failed to parse SrcSpan"+          Just ss -> pure ss++type Parser = Parsec Void Text++pPosition :: Parser Position+pPosition = do+    posLine'   <- L.decimal+    void $ char ':'+    posColumn' <- L.decimal+    return initPosition { posLine = posLine', posColumn = posColumn' }++pSrcSpan :: Parser SrcSpan+pSrcSpan = do+    void $ char '('+    posFrom <- pPosition+    void $ string ")-("+    void $ char ')'+    posTo   <- pPosition+    return $ SrcSpan posFrom posTo++-}

@@ -11,9 +11,6 @@ where  import qualified Data.ByteString.Char8         as B-import           Data.Char                      ( toLower )-import           Data.List                      ( isInfixOf )-import           Data.Semigroup                 ( (<>) ) import           Language.Fortran.Version       ( FortranVersion(..)                                                 , selectFortranVersion                                                 )

@@ -0,0 +1,8 @@+module Language.Fortran.Extras.Util where++import qualified Data.Text as Text+import Data.Text ( Text )++tshow :: Show a => a -> Text+tshow = Text.pack . show+