diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/app/Language/Fortran/Extras/CLI/Serialize.hs b/app/Language/Fortran/Extras/CLI/Serialize.hs new file mode 100644 --- /dev/null +++ b/app/Language/Fortran/Extras/CLI/Serialize.hs @@ -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)) diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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)) diff --git a/app/Raehik/CLI/Stream.hs b/app/Raehik/CLI/Stream.hs new file mode 100644 --- /dev/null +++ b/app/Raehik/CLI/Stream.hs @@ -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 @@ for 'Std'. +inStreamFileName :: Stream 'In s -> FilePath +inStreamFileName = \case Std -> "" + Path' (Path fp) -> fp + +-- | Returns @@ for 'Std'. +outStreamFileName :: Stream 'Out s -> FilePath +outStreamFileName = \case Std -> "" + Path' (Path fp) -> fp diff --git a/fortran-src-extras.cabal b/fortran-src-extras.cabal --- a/fortran-src-extras.cabal +++ b/fortran-src-extras.cabal @@ -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 diff --git a/src/Language/Fortran/Extras.hs b/src/Language/Fortran/Extras.hs --- a/src/Language/Fortran/Extras.hs +++ b/src/Language/Fortran/Extras.hs @@ -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' diff --git a/src/Language/Fortran/Extras/Encoding.hs b/src/Language/Fortran/Extras/Encoding.hs --- a/src/Language/Fortran/Extras/Encoding.hs +++ b/src/Language/Fortran/Extras/Encoding.hs @@ -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 diff --git a/src/Language/Fortran/Extras/JSON.hs b/src/Language/Fortran/Extras/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Extras/JSON.hs @@ -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 diff --git a/src/Language/Fortran/Extras/JSON/Helpers.hs b/src/Language/Fortran/Extras/JSON/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Extras/JSON/Helpers.hs @@ -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 diff --git a/src/Language/Fortran/Extras/JSON/Literals.hs b/src/Language/Fortran/Extras/JSON/Literals.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Extras/JSON/Literals.hs @@ -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" diff --git a/src/Language/Fortran/Extras/JSON/Supporting.hs b/src/Language/Fortran/Extras/JSON/Supporting.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Extras/JSON/Supporting.hs @@ -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 + +-} diff --git a/src/Language/Fortran/Extras/RunOptions.hs b/src/Language/Fortran/Extras/RunOptions.hs --- a/src/Language/Fortran/Extras/RunOptions.hs +++ b/src/Language/Fortran/Extras/RunOptions.hs @@ -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 ) diff --git a/src/Language/Fortran/Extras/Util.hs b/src/Language/Fortran/Extras/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Fortran/Extras/Util.hs @@ -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 +