{- Copyright 2016, Dominic Orchard, Andrew Rice, Mistral Contrastin, Matthew Danish Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -} {-# LANGUAGE DoAndIfThenElse, ScopedTypeVariables #-} module Main (main) where import Camfort.Analysis.Logger (LogLevel(..)) import Camfort.Functionality import Camfort.Specification.Hoare (PrimReprOption(..)) import Camfort.Specification.Units.Monad (LiteralsOpt(LitMixed)) import Control.Exception import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import GHC.Stack import Language.Fortran.ParserMonad (FortranVersion(..), selectFortranVersion) import Options.Applicative import System.Directory (getCurrentDirectory) import System.Exit main :: IO () main = catch realMain stacktrace where stacktrace (e::AsyncException) = do putStrLn "Call stack:" stack <- currentCallStack mapM_ putStrLn stack putStrLn "Exception:" print e realMain :: IO () realMain = do currentDir <- getCurrentDirectory cmd <- execParser (info (commandParser currentDir) idm) code <- runCommand cmd if code == 0 then exitWith ExitSuccess else exitWith $ ExitFailure code where env ro lo = CamfortEnv { ceInputSources = inputSource ro , ceIncludeDir = includeDir ro , ceExcludeFiles = getExcludes ro , ceLogLevel = logLevel lo , ceSourceSnippets = snippets lo , ceFortranVersion = fortranVersion ro } getExcludes = fromMaybe [] . exclude getOutputFile _ (WriteFile f) = f getOutputFile inp WriteInplace = inp runRO ro lo f = f (env ro lo) runSIO sio f = let ro = sioReadOptions sio lo = sioLogOptions sio useEval = sioUseEval sio in runRO ro lo (f useEval) runSSO sso f = let ao = ssoAnnotationOptions sso wo = ssoWriteOptions sso ro = ssoReadOptions sso lo = ssoLogOptions sso inFile = inputSource ro in runRO ro lo (f (annotationType ao) (getOutputFile inFile wo)) runDSO dso f = let ao = dsoAnnotationOptions dso wo = dsoWriteOptions dso ro = dsoReadOptions dso lo = dsoLogOptions dso inFile = inputSource ro in runRO ro lo (f (annotationType ao) (getOutputFile inFile wo)) runUO uo f = let ro = uoReadOptions uo lo = uoLogOptions uo in runRO ro lo (f (literals uo)) runUWO uwo f = let uo = uwoUnitsOptions uwo ro = uoReadOptions uo wo = uwoWriteOptions uwo inFile = inputSource ro in runUO uo (f (getOutputFile inFile wo)) runUSO uso f = let uwo = usoUnitsWriteOptions uso ao = usoAnnotationOptions uso in runUWO uwo (f (annotationType ao)) runIO io f = let ro = ioReadOptions io lo = ioLogOptions io pro = ioPrimReprOption io in runRO ro lo (f pro) runRFO rfo f = let ro = rfoReadOptions rfo lo = rfoLogOptions rfo wo = rfoWriteOptions rfo inFile = inputSource ro in runRO ro lo (f (getOutputFile inFile wo)) runCommand :: Command -> IO Int runCommand (CmdAST ro lo) = runRO ro lo ast >> return 0 runCommand (CmdCount ro lo) = runRO ro lo countVarDecls runCommand (CmdStencilsCheck ro lo) = runRO ro lo stencilsCheck runCommand (CmdStencilsInfer so) = runSIO so stencilsInfer runCommand (CmdStencilsSynth sso) = runSSO sso stencilsSynth runCommand (CmdUnitsSuggest uo) = runUO uo unitsCriticals runCommand (CmdUnitsCheck uo) | uoDumpMode uo = runUO uo unitsDump | otherwise = runUO uo unitsCheck runCommand (CmdUnitsInfer uo) = runUO uo $ unitsInfer (uoShowAST uo) runCommand (CmdUnitsSynth uso) = runUSO uso unitsSynth runCommand (CmdUnitsCompile uo) = runUO uo unitsCompile runCommand (CmdInvariantsCheck io) = runIO io invariantsCheck runCommand (CmdRefactCommon rfo) = runRFO rfo common runCommand (CmdRefactDead rfo) = runRFO rfo dead runCommand (CmdRefactEquivalence rfo) = runRFO rfo equivalences runCommand (CmdInferDDT ro lo) = runRO ro lo ddtInfer runCommand (CmdSynthDDT dso) = runDSO dso ddtSynth runCommand (CmdCheckDDT ro lo) = runRO ro lo ddtCheck runCommand (CmdRefactDDT rfo) = runRFO rfo ddtRefactor runCommand (CmdCompileDDT ro lo) = runRO ro lo ddtCompile runCommand (CmdImplicitNone ro lo) = runRO ro lo (implicitNone False) runCommand (CmdImplicitNoneAll ro lo) = runRO ro lo (implicitNone True) runCommand (CmdAllocCheck ro lo) = runRO ro lo allocCheck runCommand (CmdFPCheck ro lo) = runRO ro lo fpCheck runCommand (CmdUseCheck ro lo) = runRO ro lo useCheck runCommand (CmdArrayCheck ro lo) = runRO ro lo arrayCheck runCommand (CmdBasicChecks ro lo) = maximum <$> mapM (runRO ro lo) basicChecks runCommand (CmdInit dir) = camfortInitialize dir >> return 0 runCommand CmdTopVersion = displayVersion >> return 0 basicChecks :: [CamfortEnv -> IO Int] basicChecks = [allocCheck, arrayCheck, fpCheck, implicitNone False, useCheck] -- | Commands supported by CamFort. data Command = CmdCount ReadOptions LogOptions | CmdAST ReadOptions LogOptions | CmdStencilsCheck ReadOptions LogOptions | CmdStencilsInfer StencilsInferOptions | CmdStencilsSynth StencilsSynthOptions | CmdUnitsSuggest UnitsOptions | CmdUnitsCheck UnitsOptions | CmdUnitsInfer UnitsOptions | CmdUnitsCompile UnitsOptions | CmdUnitsSynth UnitsSynthOptions | CmdInvariantsCheck InvariantsOptions | CmdRefactCommon RefactOptions | CmdRefactDead RefactOptions | CmdRefactEquivalence RefactOptions | CmdInferDDT ReadOptions LogOptions | CmdSynthDDT DDTSynthOptions | CmdCheckDDT ReadOptions LogOptions | CmdRefactDDT RefactOptions | CmdCompileDDT ReadOptions LogOptions | CmdImplicitNone ReadOptions LogOptions | CmdImplicitNoneAll ReadOptions LogOptions | CmdAllocCheck ReadOptions LogOptions | CmdFPCheck ReadOptions LogOptions | CmdUseCheck ReadOptions LogOptions | CmdArrayCheck ReadOptions LogOptions | CmdBasicChecks ReadOptions LogOptions | CmdInit FilePath | CmdTopVersion -- | Options for reading files. data ReadOptions = ReadOptions { inputSource :: String , includeDir :: Maybe String , exclude :: Maybe [String] , fortranVersion :: Maybe FortranVersion } data LogOptions = LogOptions { logLevel :: LogLevel , snippets :: Bool } -- | Options for writing to files. -- -- User can choose to either specify which file to write, or have -- the input files be written over. data WriteOptions = WriteFile { _outputFile :: String } | WriteInplace -- | Options used by all unit commands. data UnitsOptions = UnitsOptions { uoReadOptions :: ReadOptions , uoLogOptions :: LogOptions , literals :: LiteralsOpt , uoDumpMode :: Bool , uoShowAST :: Bool } data UnitsWriteOptions = UnitsWriteOptions { uwoUnitsOptions :: UnitsOptions , uwoWriteOptions :: WriteOptions } newtype AnnotationOptions = AnnotationOptions { annotationType :: AnnotationType } data UnitsSynthOptions = UnitsSynthOptions { usoUnitsWriteOptions :: UnitsWriteOptions , usoAnnotationOptions :: AnnotationOptions } data StencilsInferOptions = StencilsInferOptions { sioReadOptions :: ReadOptions , sioLogOptions :: LogOptions , sioUseEval :: Bool } data StencilsSynthOptions = StencilsSynthOptions { ssoReadOptions :: ReadOptions , ssoLogOptions :: LogOptions , ssoWriteOptions :: WriteOptions , ssoAnnotationOptions :: AnnotationOptions } data DDTSynthOptions = DDTSynthOptions { dsoReadOptions :: ReadOptions , dsoLogOptions :: LogOptions , dsoWriteOptions :: WriteOptions , dsoAnnotationOptions :: AnnotationOptions } data InvariantsOptions = InvariantsOptions { ioReadOptions :: ReadOptions , ioLogOptions :: LogOptions , ioPrimReprOption :: PrimReprOption } -- | Options used by refactoring commands. data RefactOptions = RefactOptions { rfoReadOptions :: ReadOptions , rfoLogOptions :: LogOptions , rfoWriteOptions :: WriteOptions } -- | Parser for an argument representing an individual file or directory. fileArgument :: Mod ArgumentFields String -> Parser String fileArgument m = strArgument (metavar "FILENAME" <> action "file" <> m) -- | Parser for an argument representing an individual directory. directoryArgument :: Mod ArgumentFields String -> Parser String directoryArgument m = strArgument (metavar "DIRECTORY" <> action "directory" <> m) -- | Parser for file options with multiple files specified -- | as a comma-separated list. multiFileOption :: Mod OptionFields [String] -> Parser [String] multiFileOption m = option (list str) (metavar "FILE..." <> action "file" <> m) where list :: ReadM String -> ReadM [String] list = fmap (splitBy ',') splitBy _ [] = [] splitBy c xs = case break (==c) xs of (xs', []) -> [xs'] (xs', _:cs) -> xs' : splitBy c cs excludeOption :: Parser [String] excludeOption = multiFileOption $ long "exclude" <> short 'e' <> help "files to exclude (comma separated list, no spaces)" fortranVersionOption :: Parser FortranVersion fortranVersionOption = option parseFortranVersion $ long "fortranVersion" <> short 'F' <> metavar "VERSION" <> help "version of Fortran to parse" where parseFortranVersion = eitherReader $ \ s -> case selectFortranVersion s of Just v -> Right v Nothing -> Left "unable to parse the supplied Fortran version string" -- | Parse options for 'ReadOptions'. readOptions :: Parser ReadOptions readOptions = fmap ReadOptions (fileArgument $ help "input file") <*> optional includeDirOption <*> optional excludeOption <*> optional fortranVersionOption where dirOption m = strOption (metavar "DIR" <> action "directory" <> m) includeDirOption = dirOption ( long "include-dir" <> short 'I' <> help "directory to search for precompiled files") logOptions :: Parser LogOptions logOptions = LogOptions <$> logLevelOption <*> snippetsOption where logLevelOption = let toLogLevel debug = if debug then LogDebug else LogInfo in toLogLevel <$> switch (long "debug" <> help "enable debug output") snippetsOption = switch (long "snippets" <> help "show code snippets") -- | User must specify either an ouput file, or say that the file -- | should be rewritten in place. writeOptions :: Parser WriteOptions writeOptions = (fmap WriteFile . fileArgument $ help "file to write output to") <|> (pure WriteInplace <* flag' () ( long "inplace" <> help "write in place (replaces input files)")) stencilsInferOptions :: Parser StencilsInferOptions stencilsInferOptions = fmap StencilsInferOptions readOptions <*> logOptions <*> evalOption where evalOption = switch ( long "eval" <> help "provide additional evaluation reporting" <> internal) stencilsSynthOptions :: Parser StencilsSynthOptions stencilsSynthOptions = fmap StencilsSynthOptions readOptions <*> logOptions <*> writeOptions <*> annotationOptions unitsOptions :: Parser UnitsOptions unitsOptions = fmap UnitsOptions readOptions <*> logOptions <*> literalsOption <*> dumpModFileOption <*> showASTOption where literalsOption = option parseLiterals $ long "units-literals" <> short 'l' <> metavar "ID" <> completeWith ["Unitless", "Poly", "Mixed"] <> value LitMixed <> help "units-of-measure literals mode. ID = Unitless, Poly, or Mixed" dumpModFileOption = switch (long "dump-mod-file" <> help "show contents of fsmod file") showASTOption = switch (long "show-ast" <> help "show units at each AST node") parseLiterals = fmap read str invariantsOptions :: Parser InvariantsOptions invariantsOptions = fmap InvariantsOptions readOptions <*> logOptions <*> reprOption where reprOption = flag PROIdealized PROPrecise $ long "precise-reprs" <> short 'p' <> help "use precise data representations, in invariant verification, at\ \the cost of speed and provability; see documentation in\ \Language.Model.Fortran.Repr.Prim" unitsWriteOptions :: Parser UnitsWriteOptions unitsWriteOptions = fmap UnitsWriteOptions unitsOptions <*> writeOptions annotationOptions :: Parser AnnotationOptions annotationOptions = fmap AnnotationOptions $ flag ATDefault Doxygen (long "doxygen" <> help "synthesise annotations compatible with Doxygen") <|> flag ATDefault Ford (long "ford" <> help "synthesise annotations compatible with Ford") unitsSynthOptions :: Parser UnitsSynthOptions unitsSynthOptions = fmap UnitsSynthOptions unitsWriteOptions <*> annotationOptions refactOptions :: Parser RefactOptions refactOptions = fmap RefactOptions readOptions <*> logOptions <*> writeOptions ddtSynthOptions :: Parser DDTSynthOptions ddtSynthOptions = fmap DDTSynthOptions readOptions <*> logOptions <*> writeOptions <*> annotationOptions cmdCount, cmdAST :: Parser Command cmdCount = fmap CmdCount readOptions <*> logOptions cmdAST = fmap CmdAST readOptions <*> logOptions cmdStencilsCheck, cmdStencilsInfer, cmdStencilsSynth :: Parser Command cmdStencilsCheck = fmap CmdStencilsCheck readOptions <*> logOptions cmdStencilsInfer = fmap CmdStencilsInfer stencilsInferOptions cmdStencilsSynth = fmap CmdStencilsSynth stencilsSynthOptions cmdUnitsSuggest, cmdUnitsCheck, cmdUnitsInfer, cmdUnitsCompile, cmdUnitsSynth :: Parser Command cmdUnitsSuggest = fmap CmdUnitsSuggest unitsOptions cmdUnitsCheck = fmap CmdUnitsCheck unitsOptions cmdUnitsInfer = fmap CmdUnitsInfer unitsOptions cmdUnitsCompile = fmap CmdUnitsCompile unitsOptions cmdUnitsSynth = fmap CmdUnitsSynth unitsSynthOptions cmdImplicitNone, cmdImplicitNoneAll, cmdInvariantsCheck, cmdAllocCheck, cmdFPCheck :: Parser Command cmdArrayCheck, cmdUseCheck, cmdBasicChecks :: Parser Command cmdInvariantsCheck = fmap CmdInvariantsCheck invariantsOptions cmdImplicitNone = fmap CmdImplicitNone readOptions <*> logOptions cmdImplicitNoneAll = fmap CmdImplicitNoneAll readOptions <*> logOptions cmdAllocCheck = fmap CmdAllocCheck readOptions <*> logOptions cmdFPCheck = fmap CmdFPCheck readOptions <*> logOptions cmdUseCheck = fmap CmdUseCheck readOptions <*> logOptions cmdArrayCheck = fmap CmdArrayCheck readOptions <*> logOptions cmdBasicChecks = fmap CmdBasicChecks readOptions <*> logOptions cmdRefactCommon, cmdRefactDead, cmdRefactEquivalence :: Parser Command cmdRefactCommon = fmap CmdRefactCommon refactOptions cmdRefactDead = fmap CmdRefactDead refactOptions cmdRefactEquivalence = fmap CmdRefactEquivalence refactOptions cmdInferDDT, cmdSynthDDT, cmdCheckDDT, cmdRefactDDT, cmdCompileDDT :: Parser Command cmdInferDDT = fmap CmdInferDDT readOptions <*> logOptions cmdSynthDDT = fmap CmdSynthDDT ddtSynthOptions cmdCheckDDT = fmap CmdCheckDDT readOptions <*> logOptions cmdRefactDDT = fmap CmdRefactDDT refactOptions cmdCompileDDT = fmap CmdCompileDDT readOptions <*> logOptions -- | Helper for building a command alias. -- -- Command aliases will not show up in the help text, nor be subject to completion. commandAlias :: String -> Parser Command -> Mod CommandFields Command commandAlias alias cmdParser = command alias . info cmdParser $ mempty -- | Helper for building a parser for a group of commands. commandsParser :: String -> [(String, [String], Parser Command, String)] -> Parser Command commandsParser groupName commands = hsubparser (mconcat (fmap (\(name, _, cmdParser, description) -> (command name . info cmdParser . progDesc $ description)) commands) <> commandGroup groupName) <|> aliasSubParser where aliasSubParser = subparser $ mconcat (fmap (\(_, aliases, cmdParser, _) -> mconcat $ fmap (`commandAlias` cmdParser) aliases) commands) <> internal analysesParser :: Parser Command analysesParser = commandsParser "Analysis Commands" analysesCommands where analysesCommands = [ ("count", [], cmdCount, "count variable declarations") , ("implicit-none", [], cmdImplicitNone, "check 'implicit none' completeness") , ("implicit-none-all", [], cmdImplicitNoneAll, "check 'implicit none' completeness (all program units)") , ("ast", [], cmdAST, "print the raw AST -- for development purposes") , ("stencils-check", ["stencil-check", "check-stencils", "check-stencil"], cmdStencilsCheck, "stencil spec checking") , ("stencils-infer", ["stencil-infer", "infer-stencils", "infer-stencil"], cmdStencilsInfer, "stencil spec inference") , ("stencils-synth", ["stencil-synth", "synth-stencils", "synth-stencil"], cmdStencilsSynth, "stencil spec synthesis") , ("units-suggest", ["unit-suggest", "suggest-units", "suggest-unit"], cmdUnitsSuggest, "suggest variables to annotate with units-of-measure for maximum coverage") , ("units-check", ["unit-check", "check-units", "check-unit"], cmdUnitsCheck, "unit-of-measure checking") , ("units-infer", ["unit-infer", "infer-units", "infer-unit"], cmdUnitsInfer, "unit-of-measure inference") , ("units-summarise", ["unit-compile", "units-summarize", "units-compile", "compile-units", "compile-unit"], cmdUnitsCompile, "unit-of-measure summarisation") , ("units-synth", ["unit-synth", "synth-units", "synth-unit"], cmdUnitsSynth, "unit-of-measure synthesise specs") , ("invariants-check", ["invariants-check","check-invariants", "check-hoare", "hoare-check"], cmdInvariantsCheck, "hoare logic invariant checking") , ("alloc-check", [], cmdAllocCheck, "check allocate/deallocate statement usage") , ("fp-check", [], cmdFPCheck, "check floating point usage") , ("use-check", [], cmdUseCheck, "check usage of module USE") , ("array-check", [], cmdArrayCheck, "check usage of arrays") , ("basic-checks", [], cmdBasicChecks, "run a series of basic checks: alloc, array, fp, implicit-none, use") ] refactoringsParser :: Parser Command refactoringsParser = commandsParser "Refactoring Commands" refactoringsCommands where refactoringsCommands = [ ("common", [], cmdRefactCommon, "common block elimination") , ("equivalence", [], cmdRefactEquivalence, "equivalence elimination") , ("dead", [], cmdRefactDead, "dead-code elimination") ] derivedDatatypeParser :: Parser Command derivedDatatypeParser = commandsParser "Derived Datatype Commands" derivedDatatypeCommands where derivedDatatypeCommands = [ ("ddt-infer", ["infer-ddt"], cmdInferDDT, "infer derived datatypes") , ("ddt-synth", ["synth-ddt"], cmdSynthDDT, "synthesise comments for derived datatypes") , ("ddt-check", ["check-ddt"], cmdCheckDDT, "check comments for derived datatypes") , ("ddt-refactor", ["refactor-ddt"], cmdRefactDDT, "refactor marked derived datatypes from comments") , ("ddt-compile", ["compile-ddt"], cmdCompileDDT, "compile derived datatypes info")] topLevelCommands :: Parser Command topLevelCommands = versionOption where versionOption = pure CmdTopVersion <* switch ( long "version" <> short 'v' <> short '?' <> help "show version number") cmdInit :: FilePath -> Parser Command cmdInit currDir = fmap CmdInit . directoryArgument $ help "project directory" <> value currDir projectParser :: FilePath -> Parser Command projectParser currDir = commandsParser "Project Commands" projectCommands where projectCommands = [ ("init", [], cmdInit currDir, "initialize CamFort for the project") ] -- | Collective parser for all CamFort commands. commandParser :: FilePath -> Parser Command commandParser currDir = helper <*> ( projectParser currDir <|> analysesParser <|> refactoringsParser <|> derivedDatatypeParser <|> topLevelCommands) -- | Current CamFort version. version :: String version = "1.0" -- | Full CamFort version string. versionMessage :: String versionMessage = "CamFort " ++ version ++ " - Cambridge Fortran Infrastructure." -- | Print the full version string. displayVersion :: IO () displayVersion = putStrLn versionMessage