camfort-0.904: src/Main.hs
{-
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 #-}
module Main (main) where
import Camfort.Input (defaultValue)
import Camfort.Functionality
import Camfort.Specification.Stencils.InferenceFrontend (InferMode(..))
import Camfort.Specification.Units.Monad (LiteralsOpt(LitMixed))
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Options.Applicative
-- | Commands supported by CamFort.
data Command = CmdCount ReadOptions
| CmdAST ReadOptions
| CmdStencilsCheck ReadOptions
| CmdStencilsInfer StencilsOptions
| CmdStencilsSynth StencilsSynthOptions
| CmdUnitsSuggest UnitsOptions
| CmdUnitsCheck UnitsOptions
| CmdUnitsInfer UnitsOptions
| CmdUnitsSynth UnitsSynthOptions
| CmdUnitsCompile UnitsWriteOptions
| CmdRefactCommon RefactOptions
| CmdRefactDead RefactOptions
| CmdRefactEquivalence RefactOptions
| CmdTopVersion
-- | Options for reading files.
data ReadOptions = ReadOptions
{ inputSource :: String
, exclude :: Maybe [String]
}
-- | 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 stencil commands.
data StencilsOptions = StencilsOptions
{ soReadOptions :: ReadOptions
, soInferMode :: InferMode
}
-- | Options used by all unit commands.
data UnitsOptions = UnitsOptions
{ uoReadOptions :: ReadOptions
, literals :: LiteralsOpt
, debug :: Bool
, includeDir :: Maybe String
}
data UnitsWriteOptions = UnitsWriteOptions
{ uwoUnitsOptions :: UnitsOptions
, uwoWriteOptions :: WriteOptions
}
newtype AnnotationOptions =
AnnotationOptions { annotationType :: AnnotationType }
data UnitsSynthOptions = UnitsSynthOptions
{ usoUnitsWriteOptions :: UnitsWriteOptions
, usoAnnotationOptions :: AnnotationOptions
}
data StencilsSynthOptions = StencilsSynthOptions
{ ssoStencilsOptions :: StencilsOptions
, ssoWriteOptions :: WriteOptions
, ssoAnnotationOptions :: AnnotationOptions
}
-- | Options used by refactoring commands.
data RefactOptions = RefactOptions
{ rfoReadOptions :: ReadOptions
, 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 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 (Maybe [String])
excludeOption = optional $ multiFileOption $
long "exclude"
<> short 'e'
<> help "files to exclude (comma separated list, no spaces)"
-- | Parse options for 'ReadOptions'.
readOptions :: Parser ReadOptions
readOptions = fmap ReadOptions
(fileArgument $ help "input file")
<*> excludeOption
-- | 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)"))
stencilsOptions :: Parser StencilsOptions
stencilsOptions = fmap StencilsOptions
readOptions <*> evalOption
where
evalOption = flag AssignMode EvalMode
( long "eval"
<> help "provide additional evaluation reporting"
<> internal)
stencilsSynthOptions :: Parser StencilsSynthOptions
stencilsSynthOptions = fmap StencilsSynthOptions
stencilsOptions <*> writeOptions <*> annotationOptions
unitsOptions :: Parser UnitsOptions
unitsOptions = fmap UnitsOptions
readOptions
<*> literalsOption
<*> debugOption
<*> optional includeDirOption
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"
parseLiterals = fmap read str
debugOption = switch (long "debug" <> help "enable debug mode")
dirOption m = strOption (metavar "DIR" <> action "directory" <> m)
includeDirOption = dirOption
( long "include-dir"
<> short 'I'
<> help "directory to search for precompiled files")
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 <*> writeOptions
cmdCount, cmdAST :: Parser Command
cmdCount = fmap CmdCount readOptions
cmdAST = fmap CmdAST readOptions
cmdStencilsCheck, cmdStencilsInfer, cmdStencilsSynth :: Parser Command
cmdStencilsCheck = fmap CmdStencilsCheck readOptions
cmdStencilsInfer = fmap CmdStencilsInfer stencilsOptions
cmdStencilsSynth = fmap CmdStencilsSynth stencilsSynthOptions
cmdUnitsSuggest, cmdUnitsCheck, cmdUnitsInfer
, cmdUnitsSynth, cmdUnitsCompile :: Parser Command
cmdUnitsSuggest = fmap CmdUnitsSuggest unitsOptions
cmdUnitsCheck = fmap CmdUnitsCheck unitsOptions
cmdUnitsInfer = fmap CmdUnitsInfer unitsOptions
cmdUnitsSynth = fmap CmdUnitsSynth unitsSynthOptions
cmdUnitsCompile = fmap CmdUnitsCompile unitsWriteOptions
cmdRefactCommon, cmdRefactDead, cmdRefactEquivalence :: Parser Command
cmdRefactCommon = fmap CmdRefactCommon refactOptions
cmdRefactDead = fmap CmdRefactDead refactOptions
cmdRefactEquivalence = fmap CmdRefactEquivalence refactOptions
-- | 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")
, ("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-synth",
["unit-synth", "synth-units", "synth-unit"],
cmdUnitsSynth, "unit-of-measure synthesise specs")
, ("units-compile",
["unit-compile", "compile-units", "compile-unit"],
cmdUnitsCompile, "units-of-measure compile module information") ]
refactoringsParser :: Parser Command
refactoringsParser = commandsParser "Refactoring Commands" refactoringsCommands
where
refactoringsCommands =
[ ("common", [], cmdRefactCommon, "common block elimination")
, ("equivalence", [], cmdRefactEquivalence, "equivalence elimination")
, ("dead", [], cmdRefactDead, "dead-code elimination") ]
topLevelCommands :: Parser Command
topLevelCommands = versionOption
where versionOption = pure CmdTopVersion <* switch
( long "version"
<> short 'v'
<> short '?'
<> help "show version number")
-- | Collective parser for all CamFort commands.
commandParser :: Parser Command
commandParser =
helper <*> (analysesParser <|> refactoringsParser <|> topLevelCommands)
main :: IO ()
main = do
cmd <- execParser (info commandParser idm)
runCommand cmd
where
getExcludes = fromMaybe [] . exclude
getOutputFile _ (WriteFile f) = f
getOutputFile inp WriteInplace = inp
runRO ro f = f (inputSource ro) (getExcludes ro)
runSO so f =
runRO (soReadOptions so) f (soInferMode so)
runSSO sso f =
let ao = ssoAnnotationOptions sso
wo = ssoWriteOptions sso
so = ssoStencilsOptions sso
ro = soReadOptions so
inFile = inputSource ro
in runSO so f (annotationType ao) (getOutputFile inFile wo)
runUO uo f =
let ro = uoReadOptions uo
in runRO ro f (literals uo) (debug uo) (includeDir 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)
runRFO rfo f =
let ro = rfoReadOptions rfo
wo = rfoWriteOptions rfo
inFile = inputSource ro
in runRO ro f (getOutputFile inFile wo)
runCommand (CmdAST ro) = runRO ro ast
runCommand (CmdCount ro) = runRO ro countVarDecls
runCommand (CmdStencilsCheck ro) = runRO ro stencilsCheck
runCommand (CmdStencilsInfer so) = runSO so stencilsInfer
runCommand (CmdStencilsSynth sso) = runSSO sso stencilsSynth
runCommand (CmdUnitsSuggest uo) = runUO uo unitsCriticals
runCommand (CmdUnitsCheck uo) = runUO uo unitsCheck
runCommand (CmdUnitsInfer uo) = runUO uo unitsInfer
runCommand (CmdUnitsSynth uso) = runUSO uso unitsSynth
runCommand (CmdUnitsCompile uwo) = runUWO uwo unitsCompile
runCommand (CmdRefactCommon rfo) = runRFO rfo common
runCommand (CmdRefactDead rfo) = runRFO rfo dead
runCommand (CmdRefactEquivalence rfo) = runRFO rfo equivalences
runCommand CmdTopVersion = displayVersion
-- | Current CamFort version.
version = "0.904"
-- | Full CamFort version string.
versionMessage = "CamFort " ++ version ++ " - Cambridge Fortran Infrastructure."
-- | Print the full version string.
displayVersion :: IO ()
displayVersion = putStrLn versionMessage