{- ---------------------------------------------------------------------------
Flags are all the choices and information given to the compiler in the
argument list. Here a data type Flags is defined for holding this information,
a function processArgs to obtain a value of type Flags from the argument list,
and a simple function pF for printing information demanded by a flag.
-}
module Flags
( FileFlags(..)
, Flags(..)
, processArgs
-- , processMoreArgs
-- , splitArgs
, pF
, printUsage
, getFileFlags
, allOpts
, calcRootPath
) where
import IO
import Util.OsOnly(fixRootDir,fixTypeFile,fixObjectFile)
import Char(isDigit)
import System.FilePath
import Util.Text
import Util.Extra
import Building (Compiler(..),compiler)
import System.Console.GetOpt
{- File flags are things which are specific to each compiled file -}
data FileFlags = FileFF {
sSourceFile :: String, -- name of source file as given
sModuleName :: String, -- name of the module
sTypeFile :: String, -- full path to the .hi file
sObjectFile :: String, -- full path to the .hbc file
sCoreFile :: String, -- full path to the .ycr file
sWrapFile :: String -- full path to the .c wrapper
}
instance Show FileFlags where
show ff = unlines [ "sourceFile = "++sSourceFile ff,
"moduleName = "++sModuleName ff,
"typeFile = "++sTypeFile ff,
"objFile = "++sObjectFile ff,
"coreFile = "++sCoreFile ff,
"wrapFile = "++sWrapFile ff]
getFileFlags :: Flags -> FilePath -> String -> FileFlags
getFileFlags flags sourcefile modname | compiler==Yhc =
FileFF sourcefile modname typefile objfile corefile wrapfile
where
typefile = fileForModule (sTypeDst flags) "hi"
objfile = fileForModule (sObjectDst flags) "hbc"
corefile = fileForModule (sObjectDst flags) "ycr"
wrapfile = fileForModule (sWrapDst flags) "c"
-- if modname == "Main" that means that the file may not be "Main", but could be something else
name = if modname == "Main" then takeBaseName sourcefile else modname
rootPath = calcRootPath sourcefile modname
fileForModule root ext =
if sHideObj flags then
addExtension (combine rootPath (joinPath [ext, name])) ext
else
replaceExtension (combine (rootPath </> root)
(joinPath $ splitList "." name)) ext
getFileFlags flags sourcefile modname | compiler==Nhc98 =
case sFileArgs flags of
[source] -> FileFF source modname (hiFile source) (hcFile source)
(core source) undefined
[source,hi,hc]
-> FileFF source modname hi hc (core source) undefined
[realfile,source,hi,hc]
-> FileFF realfile modname hi hc (core source) undefined
_ -> error (printUsage undefined)
where
hiFile f = let (rootdir,file) = fixRootDir (sUnix flags) f
in fixTypeFile (sUnix flags) rootdir file
hcFile f = let (rootdir,file) = fixRootDir (sUnix flags) f
in fixObjectFile (sUnix flags) rootdir file
core f = f++".ycr"
-- | Figure out how far up the directory tree you have to go to get the root
calcRootPath :: FilePath -> String -> FilePath
calcRootPath filename modname = joinPath $ take tsize orig
where
orig = splitPath filename
tsize = length orig - depthmod + depthfil - 1
depthmod = length $ filter (== '.') modname
depthfil = length $ filter (== '.') $ takeFileName $ dropExtension filename
{- Flags are flags that apply to every file -}
data Flags = FF
{sRootFile :: String -- full path to root source code
,sFileArgs :: [String] -- all filenames given on commandline
,sIncludes :: [String]
,sPreludes :: [String]
,sBasePath :: String
,sTypeDst :: String -- where generated .hi should go
,sObjectDst :: String -- where generated bcode should be
,sWrapDst :: String -- b-code where generated wrappers should go
,sHideObj :: Bool -- hide object code
--v Flags to control actions
,sViewCore :: [String]
--v Flags to control compilation
,sRedefine :: Bool -- allow redefinitions of imported identifiers
,sCompileOne :: Bool -- compile one file only
,sUnix :: Bool -- either unix or RiscOS
,sUnlit :: Bool -- unliterate the source code
,sCpp :: Bool -- preprocess the source code
,sHiSuffix :: String -- set the interface file suffix (usually .hi)
,sHat :: Bool
,sProfile :: Bool -- turn on heap profiling
,sTprof :: Bool -- turn on time profiling
,sZap :: Bool -- zap unused args / stack positions
,sPrelude :: Bool -- keep prelude defns in interface file
,sLib :: Bool -- compiling a library
,sPart :: Bool -- compiling part of a lib
,sKeepCase :: Bool -- don't lift case, we fix those later
,sUnifyHack :: Bool -- enables type hackery that's required to make the prelude compile ...
,sDotNet :: Bool -- generate .NET IL (implies -no-bytecode)
,sNoBytecode :: Bool -- don't generate any bytecode (typically used with -core)
--v Flags for machine architecture / configuration
,sAnsiC :: Bool -- generate bytecode via ANSI-C
,sNplusK :: Bool -- allow (n+k) patterns
,sUnderscore :: Bool -- force H'98 underscores
,sPuns :: Bool -- allow named-field puns
,s98 :: Bool -- Haskell 98 mode
--v debugging flags - show program / import tables (after each compiler phase)
,sLex :: Bool -- input after lexing
,sILex :: Bool -- input after lexing imported interface files
,sParse :: Bool -- ast after parsing
,sNeed :: Bool -- need table before imports
,sINeed :: Bool -- need table after all imports
,sIINeed :: Bool -- need table after each import
,sIRename :: Bool -- rename table after all imports
,sIIRename :: Bool -- rename table after each import
,sImport :: Bool -- imported filenames
,sRImport :: Bool -- imports actually used
,sDepend :: Bool -- imported ids (not currently used)
,sRename :: Bool -- ast after rename
,sDerive :: Bool -- ast after deriving
,sRemove :: Bool -- ast after named-field removal
,sScc :: Bool -- ast after strongly-connected-components
,sType :: Bool -- ast after type check
,sFixSyntax :: Bool -- ast after removing newtypes
,sLift :: Bool -- stg tree after lambda lifting
,sCase :: Bool -- stg tree after case pattern simplification
,sPrim :: Bool -- stg tree after inserting primitives
,sArity :: Bool -- stg tree after arity analysis
,sAtom :: Bool -- stg tree after only atoms in applications
,sFree :: Bool -- stg code with explicit free variables
-- | Yhc
,sBcodeCompile :: Bool -- b-code
,sBcodeMem :: Bool -- b-code after NNEDHEAP analysis
,sBcodeFlatten :: Bool -- b-code after flattening
,sBcodeWrapper :: Bool -- b-code generate wrappers
,sBcodeRel :: Bool
-- | nhc98
,sGcode :: Bool -- g-code
,sGcodeFix :: Bool -- g-code after large constant fix
,sGcodeMem :: Bool -- g-code after NEEDHEAP analysis
,sGcodeOpt1 :: Bool -- g-code after optimisation phase 1
,sGcodeRel :: Bool -- g-code after relative offset analysis
,sGcodeOpt2 :: Bool -- g-code after optimisation phase 2
,sFunNames :: Bool -- insert position and name of functions in the code
--v debugging flags - show symbol table (after each compiler phase)
,sIBound :: Bool -- after all imports
,sIIBound :: Bool -- after each import
,sRBound :: Bool -- after rename
,sDBound :: Bool -- after deriving
,sEBound :: Bool -- after extract
,sTBound :: Bool -- after type checking
,sFSBound :: Bool -- after fixsyntax
,sLBound :: Bool -- after lambda-lifting
,sCBound :: Bool -- after case
,sPBound :: Bool -- after inserting prims
,sABound :: Bool -- after only atoms in applications
--v miscellaneous flags
,sShowType :: Bool -- report type of "main" (for hmake interactive)
,sShowWidth :: Int -- width for showing intermediate program
,sShowIndent :: Int -- indentation for nesting shown intermediate program
,sShowQualified :: Bool -- show qualified ids as far as possible
,sShowCore :: Bool -- show Core
,sGenCore :: Bool -- generate a .ycr file
,sLinkCore :: Bool -- link all the core files together
--export control flags
,sExportAll :: Bool -- ignore what the module decl says, just export the lot
,sHelp :: Bool
,sVersion :: Bool
}
deriving (Show)
{- Default values for flags -}
defaultFlags = FF
{sRootFile = ""
,sFileArgs = []
,sIncludes = []
,sPreludes = []
,sBasePath = ""
,sTypeDst = "."
,sObjectDst = "."
,sWrapDst = "."
,sHideObj = False
--v Flags to control actions
,sViewCore = []
--v Flags to control compilation
,sRedefine = False
,sPart = False
,sCompileOne = False
,sUnix = True
,sUnlit = False
,sCpp = False
,sHiSuffix = "hi"
,sHat = False
,sProfile = False
,sTprof = False
,sZap = True
,sPrelude = False
,sLib = False
,sKeepCase = False
,sUnifyHack = False
,sDotNet = False
,sNoBytecode = False
--v Flags for machine architecture / configuration
,sAnsiC = True
,sNplusK = True
,sUnderscore = False
,sPuns = False
,s98 = False
--v debugging flags - show program / import tables (after each compiler phase)
,sLex = False
,sILex = False
,sParse = False
,sNeed = False
,sINeed = False
,sIINeed = False
,sIRename = False
,sIIRename = False
,sImport = False
,sRImport = False
,sDepend = False
,sRename = False
,sDerive = False
,sRemove = False
,sScc = False
,sType = False
,sFixSyntax = False
,sLift = False
,sCase = False
,sPrim = False
,sArity = False
,sAtom = False
,sFree = False
-- Yhc
,sBcodeCompile = False
,sBcodeMem = False
,sBcodeFlatten = False
,sBcodeWrapper = False
,sBcodeRel = False
-- nhc98
,sGcode = False
,sGcodeFix = False
,sGcodeMem = False
,sGcodeOpt1 = False
,sGcodeRel = False
,sGcodeOpt2 = False
,sFunNames = False
--v debugging flags - show symbol table (after each compiler phase)
,sIBound = False
,sIIBound = False
,sRBound = False
,sDBound = False
,sEBound = False
,sTBound = False
,sFSBound = False
,sLBound = False
,sCBound = False
,sPBound = False
,sABound = False
--v miscellaneous flags
,sShowType = False
,sShowWidth = 80
,sShowIndent = 2
,sShowQualified = True
,sShowCore = False
,sGenCore = False
,sLinkCore = False
--export control flags
,sExportAll = False
,sHelp = False
,sVersion = False
}
-- All option descriptions
allOpts :: [ OptDescr (Flags->Flags) ]
allOpts =
-- OptGroup "Help Options"
[ Option "v" ["version"]
(NoArg (\f -> f{sVersion=True})) "Show version information"
, Option "?h" ["help"]
(NoArg (\f -> f{sHelp=True})) "Show options and usage information"
-- OptGroup "Inputs and Outputs"
, Option "I" ["includes","imports"]
(ReqArg (\x f-> f{sIncludes = x:sIncludes f}) "dir")
"Include/import directories"
, Option "P" ["preludes"]
(ReqArg (\x f-> f{sPreludes = x:sPreludes f}) "dir")
"Prelude directories"
, Option "d" ["dst","objdir"]
(ReqArg (\x f-> f{sObjectDst=x}) "dir")
"destination path for generated bytecode files"
, Option "i" ["hidst","hidir"]
(ReqArg (\x f-> f{sTypeDst=x}) "dir")
"destination path for generated .hi files"
, Option "w" ["wrapdst","ffidir"]
(ReqArg (\x f-> f{sWrapDst=x}) "dir")
"destination path for generated FFI wrapper"
, Option "" ["hide"]
(NoArg (\f -> f{sHideObj=True})) "hide object files"
-- OptGroup "Generation Options"
, Option "" ["hat"]
(NoArg (\f -> f{sHat=True})) "compile with Hat debugging support"
, Option "" ["dotnet"]
(NoArg (\f -> f{sDotNet=True})) "Generate .NET IL code (implies -no-bytecode)"
, Option "" ["no-bytecode"]
(NoArg (\f -> f{sNoBytecode=True})) "Do not generate any bytecode"
, Option "W" ["genwrapper"]
(NoArg (\f -> f{sBcodeWrapper=True})) "generate FFI wrapper"
, Option "" ["hi-suffix","hisuf"]
(ReqArg (\x f -> f{sHiSuffix=x}) "SUF")
"change the default \".hi\" suffix"
, Option "" ["exportall"]
(NoArg (\f -> f{sExportAll=True}))
"export all identifiers from a module, ignoring export list"
-- OptGroup "Action Flags"
, Option "" ["viewcore"]
(ReqArg (\x f -> f{sViewCore= x:sViewCore f}) "FILE")
"View named Core file (.ycr)"
, Option "c" ["compile"]
(NoArg (\f -> f{sCompileOne=True})) "Compile one file only"
-- OptGroup "Compilation Options"
, Option "" ["redefine"]
(NoArg (\f-> f{sRedefine=True}))
"Don't complain if redefining an imported identifier"
, Option "" ["nounix"]
(NoArg (\f -> f{sUnix=False})) "Use unix file names"
, Option "" ["unlit"]
(NoArg (\f -> f{sUnlit=True})) "Unliterate the source code"
, Option "" ["cpp"]
(NoArg (\f -> f{sCpp=True})) "Pre-process the file first"
, Option "" ["prelude"]
(NoArg (\f -> f{sPrelude=True}))
"Keep prelude definitions in interface file"
, Option "" ["lib"]
(NoArg (\f -> f{sLib=True}))
"Compiling a lib, don't complain if importing modules with \
\ names that differ from their filename."
, Option "" ["part"]
(NoArg (\f -> f{sPart=True}))
"Compiling part of a lib, so don't complain if module \
\ name differs from file name and don't create profiling \
\ information for this module"
, Option "" ["unifyhack"]
(NoArg (\f -> f{sUnifyHack=True}))
"Enable nasty type hack needed to make the prelude compile"
, Option "" ["zap"]
(NoArg (\f -> f{sZap=True})) "Zap unused args/stack positions"
, Option "" ["nozap"]
(NoArg (\f -> f{sZap=False})) "Don't zap unused args/stack positions"
-- OptGroup "Profiling"
, Option "p" ["profile"]
(NoArg (\f -> f{sProfile=True})) "Generate code for heap profiling"
, Option "z" ["tprof"]
(NoArg (\f -> f{sTprof=True})) "Generate code for time profiling"
-- OptGroup "Compliance Options"
, Option "" ["ansiC"]
(NoArg (\f -> f{sAnsiC=True})) "Generate bytecode via ANSI-C"
, Option "" ["noansiC"]
(NoArg (\f -> f{sAnsiC=False})) "Generate bytecode via assembler"
, Option "" ["nplusk","nkpat"]
(NoArg (\f -> f{sNplusK=True})) "Allow (n+k) patterns"
, Option "" ["nonplusk","nonkpat"]
(NoArg (\f -> f{sNplusK=False})) "Disallow (n+k) patterns"
, Option "" ["underscore"]
(NoArg (\f -> f{sUnderscore=True})) "H98 underscore-is-lower-case"
, Option "" ["nounderscore"]
(NoArg (\f -> f{sUnderscore=False})) "Enable underscore-is-invisible"
, Option "" ["puns"]
(NoArg (\f -> f{sPuns=True})) "Enable pre-98 named-field puns"
, Option "" ["nopuns"]
(NoArg (\f -> f{sPuns=False})) "Disable named-field puns"
, Option "" ["98"]
(NoArg (\f -> f{s98=True})) "Haskell 98 compliance"
, Option "" ["no98"]
(NoArg (\f -> f{s98=False})) "Turn off strict Haskell 98 compliance"
-- OptGroup "Core Options"
, Option "" ["core"]
(NoArg (\f -> f{sGenCore=True})) "generate a .ycr binary file"
, Option "" ["showcore"]
(NoArg (\f -> f{sShowCore=True})) "show the Core language"
, Option "" ["linkcore"]
(NoArg (\f -> f{sLinkCore=True,sGenCore=True}))
"generate a linked .yca binary file"
-- OptGroup "Debug Options"
, Option "" ["lex"]
(NoArg (\f -> f{sLex=True})) "show lexical input"
, Option "" ["parse"]
(NoArg (\f -> f{sParse=True})) "show syntax tree after parser"
, Option "" ["need"]
(NoArg (\f -> f{sNeed=True})) "show need table before import"
, Option "" ["ineed"]
(NoArg (\f -> f{sINeed=True})) "show need table after import"
, Option "" ["irename"]
(NoArg (\f -> f{sIRename=True})) "show rename table after import"
, Option "" ["iineed"]
(NoArg (\f -> f{sIINeed=True}))
"show need table between all import files"
, Option "" ["iirename"]
(NoArg (\f -> f{sIIRename=True}))
"show rename table between all imports"
, Option "" ["rename"]
(NoArg (\f -> f{sRename=True})) "show syntax tree after rename"
, Option "" ["derive"]
(NoArg (\f -> f{sDerive=True})) "show syntax tree after derive"
, Option "" ["remove"]
(NoArg (\f -> f{sRemove=True}))
"show syntax tree after fields are translated into selectors"
, Option "" ["scc"]
(NoArg (\f -> f{sScc=True}))
"show syntax tree after splitting into strongly connected groups"
, Option "" ["type"]
(NoArg (\f -> f{sType=True})) "show syntax tree after type check"
, Option "" ["fixsyntax"]
(NoArg (\f -> f{sFixSyntax=True}))
"show syntax tree after removing newtype constructors and fixing \
\ Class.Type.method"
, Option "" ["lift"]
(NoArg (\f -> f{sLift=True})) "show syntax tree after lambda lifting"
, Option "" ["case"]
(NoArg (\f -> f{sCase=True}))
"show stg tree after simplification of patterns"
, Option "" ["prim"]
(NoArg (\f -> f{sPrim=True}))
"show stg tree after inserting primitive functions"
, Option "" ["bcodecompile"]
(NoArg (\f -> f{sBcodeCompile=True})) "show B code after compile"
, Option "" ["bcodemem"]
(NoArg (\f -> f{sBcodeMem=True}))
"show B code after heap usage analysis"
, Option "" ["bcodeflatten"]
(NoArg (\f -> f{sBcodeFlatten=True})) "show B code after flattening"
, Option "" ["bcoderel"]
(NoArg (\f -> f{sBcodeRel=True}))
"show B code after converting to relative jumps"
, Option "" ["keepcase"]
(NoArg (\f -> f{sKeepCase=True}))
"Don't lift case, we fix those later"
, Option "" ["arity"]
(NoArg (\f -> f{sArity=True})) "show stg tree after arity"
, Option "" ["ibound"]
(NoArg (\f -> f{sIBound=True})) "show symbol table after import"
, Option "" ["iibound"]
(NoArg (\f -> f{sIIBound=True}))
"show symbol table between all import files"
, Option "" ["rbound"]
(NoArg (\f -> f{sRBound=True})) "show symbol table after rename"
, Option "" ["dbound"]
(NoArg (\f -> f{sDBound=True})) "show symbol table after derive"
, Option "" ["pbound"]
(NoArg (\f -> f{sPBound=True}))
"show symbol table after inserting primitive functions"
, Option "" ["ebound"]
(NoArg (\f -> f{sEBound=True})) "show symbol table after extract"
, Option "" ["tbound"]
(NoArg (\f -> f{sTBound=True})) "show symbol table after type check"
, Option "" ["fsbound"]
(NoArg (\f -> f{sFSBound=True}))
"show symbol table after adding Class.Type.method info"
, Option "" ["lbound"]
(NoArg (\f -> f{sLBound=True}))
"show symbol table after lambda lifting"
, Option "" ["cbound"]
(NoArg (\f -> f{sCBound=True}))
"show symbol table after simplification of pattern"
, Option "" ["abound"]
(NoArg (\f -> f{sABound=True}))
"show symbol table after only atoms in applications"
, Option "" ["import"]
(NoArg (\f -> f{sImport=True})) "print name of imported files"
, Option "" ["depend"]
(NoArg (\f -> f{sDepend=True}))
"print imported identifiers that are used (alpha quality)"
, Option "" ["free"]
(NoArg (\f -> f{sFree=True}))
"show stg tree with explicitly free variables"
, Option "" ["atom"]
(NoArg (\f -> f{sAtom=True}))
"show stg tree after only atoms in applications"
, Option "" ["funnames"]
(NoArg (\f -> f{sFunNames=True}))
"insert position and name of functions in the code"
, Option "" ["ilex"]
(NoArg ( \f -> f{sILex=True})) "show lexical input"
, Option "" ["report-imports"]
(NoArg (\f -> f{sRImport=True})) "show only imports actually used"
, Option "" ["showtype"]
(NoArg (\f -> f{sShowType=True})) "report type of \"main\""
, Option "" ["showwidth"]
(ReqArg (\x f -> f{sShowWidth=read x}) "NUM")
"set width for showing intermediate program"
, Option "" ["showindent"]
(ReqArg (\x f -> f{sShowIndent=read x}) "NUM")
"set indentation for nesting"
, Option "" ["showqualified"]
(NoArg (\f -> f{sShowQualified=True}))
"show qualified ids as far as possible"
, Option "" ["noshowqualified"]
(NoArg (\f -> f{sShowQualified=False})) "show always unqualified ids"
]
-- Parse etc.
processArgs :: [String] -> Flags
processArgs ss =
let (funs, nonopts, errors) = getOpt Permute allOpts ss
in (if not (null errors) then
error ("Could not parse cmd-line options: "++unlines errors)
else if compiler==Yhc && length nonopts > 1 then
warning ("ignoring extra options or files:\n"
++unlines (tail nonopts))
else if compiler==Nhc98 && length nonopts > 4 then
warning ("ignoring extra options or files:\n"
++unlines (drop 4 nonopts))
else if compiler==Yhc then
(\f-> f{sRootFile=head nonopts})
else
(\f-> f{sFileArgs=nonopts})
) (foldr ($) defaultFlags funs)
printUsage :: Bool -> String
printUsage _ | compiler==Yhc =
flip usageInfo allOpts (unlines $
[ "yhc - York Haskell Compiler"
, "A cross platform Haskell compiler"
, ""
, " yhc [options] file"
, ""
, "file: Name of the source file to compile, i.e. main.hs"
, "options: "
])
printUsage _ | compiler==Nhc98 =
usageInfo "nhc98comp [options] file.hs" allOpts
{- If first argument is True, then print second and third with formatting -}
pF :: Bool -> [Char] -> [Char] -> IO ()
pF flag title text =
if flag
then hPutStr stderr ( "======\t"++title++":\n"++text++"\n")
else return ()
|
