alex-3.5.4.0: src/Main.hs
{-# LANGUAGE NondecreasingIndentation #-}
-- -----------------------------------------------------------------------------
--
-- Main.hs, part of Alex
--
-- (c) Chris Dornan 1995-2000, Simon Marlow 2003
--
-- ----------------------------------------------------------------------------}
module Main (main) where
import AbsSyn
import CharSet
import DFA
import DFAMin
import NFA
import Info
import Output
import ParseMonad ( runP, Warning(..) )
import Parser
import Scan
import Util ( hline )
import Paths_alex ( version, getDataDir )
import Control.Exception ( bracketOnError )
import Control.Monad ( when, liftM )
import Data.Char ( chr )
import Data.List ( intercalate, isSuffixOf, nub )
import Data.Map ( Map )
import Data.Version ( showVersion )
import System.Console.GetOpt ( getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..) )
import System.Directory ( removeFile )
import System.Environment ( getProgName, getArgs )
import System.Exit ( ExitCode(..), exitWith )
import System.IO ( stderr, Handle, IOMode(..), openFile, hClose, hPutStr, hPutStrLn
, hGetContents, hSetEncoding, utf8 )
import qualified Data.Map as Map
-- We need to force every file we open to be read in
-- as UTF8
alexReadFile :: FilePath -> IO String
alexReadFile file = hGetContents =<< alexOpenFile file ReadMode
-- We need to force every file we write to be written
-- to as UTF8
alexOpenFile :: FilePath -> IOMode -> IO Handle
alexOpenFile file mode = do
h <- openFile file mode
hSetEncoding h utf8
return h
-- `main' decodes the command line arguments and calls `alex'.
main:: IO ()
main = do
args <- getArgs
case getOpt Permute argInfo args of
(cli,_,[]) | DumpHelp `elem` cli -> do
prog <- getProgramName
bye (usageInfo (usageHeader prog) argInfo)
(cli,_,[]) | DumpVersion `elem` cli ->
bye copyright
(cli,_,[]) | DumpNumericVersion `elem` cli ->
bye projectVersion
(cli,_,[]) | OptVerbose `elem` cli ->
failure "Option '--verbose' not yet implemented"
(cli,[file],[]) ->
runAlex cli file
(_,_,errors) ->
failure $ concat errors
where
failure err = do
prog <- getProgramName
die (err ++ usageInfo (usageHeader prog) argInfo)
projectVersion :: String
projectVersion = showVersion version
copyright :: String
copyright = "Alex version " ++ projectVersion ++ ", (c) 2003 Chris Dornan and Simon Marlow\n"
usageHeader :: String -> String
usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file\n"
runAlex :: [CLIFlags] -> FilePath -> IO ()
runAlex cli file = do
basename <- case (reverse file) of
'x':'.':r -> return (reverse r)
_ -> die (file ++ ": filename must end in \'.x\'\n")
prg <- alexReadFile file
script <- parseScript file prg
alex cli file basename script
parseScript :: FilePath -> String
-> IO (Maybe (AlexPosn,Code), [Directive], Scanner, Maybe (AlexPosn,Code))
parseScript file prg =
case runP prg initialParserEnv parse of
Left (Just (AlexPn _ line col),err) ->
die (file ++ ":" ++ show line ++ ":" ++ show col
++ ": " ++ err ++ "\n")
Left (Nothing, err) ->
die (file ++ ": " ++ err ++ "\n")
Right (warnings, script@(_, _, scanner, _)) -> do
-- issue 46: give proper error when lexer definition is empty
when (null $ scannerTokens scanner) $
dieAlex $ file ++ " contains no lexer rules\n"
-- issue 71: warn about nullable regular expressions
mapM_ printWarning warnings
return script
where
printWarning (WarnNullableRExp (AlexPn _ line col) msg) =
hPutStrLn stderr $ concat
[ "Warning: "
, file , ":", show line , ":" , show col , ": "
, msg
]
alex :: [CLIFlags]
-> FilePath
-> FilePath
-> (Maybe (AlexPosn, Code), [Directive], Scanner, Maybe (AlexPosn, Code))
-> IO ()
alex cli file basename script = do
(put_info, finish_info) <-
case [ f | OptInfoFile f <- cli ] of
[] -> return (\_ -> return (), return ())
[Nothing] -> infoStart file (basename ++ ".info")
[Just f] -> infoStart file f
_ -> dieAlex "multiple -i/--info options"
o_file <- case [ f | OptOutputFile f <- cli ] of
[] -> return (basename ++ ".hs")
[f] -> return f
_ -> dieAlex "multiple -o/--outfile options"
tab_size <- case [ s | OptTabSize s <- cli ] of
[] -> return (8 :: Int)
[s] -> case reads s of
[(n,"")] -> return n
_ -> dieAlex "-s/--tab-size option is not a valid integer"
_ -> dieAlex "multiple -s/--tab-size options"
let target
| OptGhcTarget `elem` cli = GhcTarget
| otherwise = HaskellTarget
let encodingsCli
| OptLatin1 `elem` cli = [Latin1]
| otherwise = []
template_dir <- templateDir getDataDir cli
let maybe_header, maybe_footer :: Maybe (AlexPosn, Code)
directives :: [Directive]
scanner1 :: Scanner
(maybe_header, directives, scanner1, maybe_footer) = script
scheme <- getScheme directives
-- open the output file; remove it if we encounter an error
bracketOnError
(alexOpenFile o_file WriteMode)
(\h -> do hClose h; removeFile o_file)
$ \out_h -> do
let scanner2, scanner_final :: Scanner
scs :: [StartCode]
sc_hdr, actions :: ShowS
encodingsScript :: [Encoding]
(scanner2, scs, sc_hdr) = encodeStartCodes scanner1
(scanner_final, actions) = extractActions scheme scanner2
encodingsScript = [ e | EncodingDirective e <- directives ]
encoding <- case nub (encodingsCli ++ encodingsScript) of
[] -> return UTF8 -- default
[e] -> return e
_ | null encodingsCli -> dieAlex "conflicting %encoding directives"
| otherwise -> dieAlex "--latin1 flag conflicts with %encoding directive"
mapM_ (hPutStrLn out_h) (optsToInject target cli)
injectCode maybe_header file out_h
hPutStr out_h (importsToInject target cli)
-- add the wrapper, if necessary
case wrapperCppDefs scheme of
Nothing -> return ()
Just cppDefs -> do
let wrapper_name = template_dir ++ "/AlexWrappers.hs"
mapM_ (hPutStrLn out_h)
[ unwords ["#define", i, "1"]
| i <- cppDefs ]
str <- alexReadFile wrapper_name
hPutStr out_h str
-- Inject the tab size
hPutStrLn out_h $ "alex_tab_size :: Int"
hPutStrLn out_h $ "alex_tab_size = " ++ show (tab_size :: Int)
let dfa = scanner2dfa encoding scanner_final scs
min_dfa = minimizeDFA dfa
nm = scannerName scanner_final
usespreds = usesPreds min_dfa
put_info "\nStart codes\n"
put_info (show $ scs)
put_info "\nScanner\n"
put_info (show $ scanner_final)
put_info "\nNFA\n"
put_info (show $ scanner2nfa encoding scanner_final scs)
put_info "\nDFA"
put_info (infoDFA 1 nm dfa "")
put_info "\nMinimized DFA"
put_info (infoDFA 1 nm min_dfa "")
hPutStr out_h (outputDFA target 1 nm scheme min_dfa "")
hPutStr out_h (sc_hdr "")
hPutStr out_h (actions "")
-- add the template
do
let cppDefs = templateCppDefs target encoding usespreds cli
mapM_ (hPutStrLn out_h)
[ unwords ["#define", i, "1"]
| i <- cppDefs ]
tmplt <- alexReadFile $ template_dir ++ "/AlexTemplate.hs"
hPutStr out_h tmplt
injectCode maybe_footer file out_h
hClose out_h
finish_info
getScheme :: [Directive] -> IO Scheme
getScheme directives =
do
token <- case [ ty | TokenType ty <- directives ] of
[] -> return Nothing
[res] -> return (Just res)
_ -> dieAlex "multiple %token directives"
action <- case [ ty | ActionType ty <- directives ] of
[] -> return Nothing
[res] -> return (Just res)
_ -> dieAlex "multiple %action directives"
typeclass <- case [ tyclass | TypeClass tyclass <- directives ] of
[] -> return Nothing
[res] -> return (Just res)
_ -> dieAlex "multiple %typeclass directives"
case [ f | WrapperDirective f <- directives ] of
[] ->
case (typeclass, token, action) of
(Nothing, Nothing, Nothing) ->
return Default { defaultTypeInfo = Nothing }
(Nothing, Nothing, Just actionty) ->
return Default { defaultTypeInfo = Just (Nothing, actionty) }
(Just _, Nothing, Just actionty) ->
return Default { defaultTypeInfo = Just (typeclass, actionty) }
(_, Just _, _) ->
dieAlex "%token directive only allowed with a wrapper"
(Just _, Nothing, Nothing) ->
dieAlex "%typeclass directive without %token directive"
[single]
| single == "gscan" ->
case (typeclass, token, action) of
(Nothing, Nothing, Nothing) ->
return GScan { gscanTypeInfo = Nothing }
(Nothing, Just tokenty, Nothing) ->
return GScan { gscanTypeInfo = Just (Nothing, tokenty) }
(Just _, Just tokenty, Nothing) ->
return GScan { gscanTypeInfo = Just (typeclass, tokenty) }
(_, _, Just _) ->
dieAlex "%action directive not allowed with a wrapper"
(Just _, Nothing, Nothing) ->
dieAlex "%typeclass directive without %token directive"
| single == "basic" || single == "basic-bytestring" ||
single == "strict-bytestring" || single == "strict-text" ->
let
strty = case single of
"basic" -> Str
"basic-bytestring" -> Lazy
"strict-bytestring" -> Strict
"strict-text" -> StrictText
_ -> error "Impossible case"
in case (typeclass, token, action) of
(Nothing, Nothing, Nothing) ->
return Basic { basicStrType = strty,
basicTypeInfo = Nothing }
(Nothing, Just tokenty, Nothing) ->
return Basic { basicStrType = strty,
basicTypeInfo = Just (Nothing, tokenty) }
(Just _, Just tokenty, Nothing) ->
return Basic { basicStrType = strty,
basicTypeInfo = Just (typeclass, tokenty) }
(_, _, Just _) ->
dieAlex "%action directive not allowed with a wrapper"
(Just _, Nothing, Nothing) ->
dieAlex "%typeclass directive without %token directive"
| single == "posn" || single == "posn-bytestring" || single == "posn-strict-text" ->
let
strty = case single of
"posn" -> Str
"posn-bytestring" -> Strict
"posn-strict-text" -> StrictText
_ -> error "invalid str type for posn"
in case (typeclass, token, action) of
(Nothing, Nothing, Nothing) ->
return Posn { posnStrType = strty,
posnTypeInfo = Nothing }
(Nothing, Just tokenty, Nothing) ->
return Posn { posnStrType = strty,
posnTypeInfo = Just (Nothing, tokenty) }
(Just _, Just tokenty, Nothing) ->
return Posn { posnStrType = strty,
posnTypeInfo = Just (typeclass, tokenty) }
(_, _, Just _) ->
dieAlex "%action directive not allowed with a wrapper"
(Just _, Nothing, Nothing) ->
dieAlex "%typeclass directive without %token directive"
| single == "monad" || single == "monad-bytestring" || single == "monad-strict-text" ||
single == "monadUserState" ||
single == "monadUserState-bytestring" ||
single == "monadUserState-strict-text" ->
let
isText = single == "monad-strict-text" ||
single == "monadUserState-strict-text"
isByteString = single == "monad-bytestring" ||
single == "monadUserState-bytestring"
userState = single == "monadUserState" ||
single == "monadUserState-bytestring" ||
single == "monadUserState-strict-text"
in case (typeclass, token, action) of
(Nothing, Nothing, Nothing) ->
return Monad { monadStrType = if isByteString then Lazy else if isText then StrictText else Str,
monadUserState = userState,
monadTypeInfo = Nothing }
(Nothing, Just tokenty, Nothing) ->
return Monad { monadStrType = if isByteString then Lazy else if isText then StrictText else Str,
monadUserState = userState,
monadTypeInfo = Just (Nothing, tokenty) }
(Just _, Just tokenty, Nothing) ->
return Monad { monadStrType = if isByteString then Lazy else if isText then StrictText else Str,
monadUserState = userState,
monadTypeInfo = Just (typeclass, tokenty) }
(_, _, Just _) ->
dieAlex "%action directive not allowed with a wrapper"
(Just _, Nothing, Nothing) ->
dieAlex "%typeclass directive without %token directive"
| otherwise -> dieAlex ("unknown wrapper type " ++ single)
_many -> dieAlex "multiple %wrapper directives"
-- inject some code, and add a {-# LINE #-} pragma at the top
injectCode :: Maybe (AlexPosn,Code) -> FilePath -> Handle -> IO ()
injectCode Nothing _ _ = return ()
injectCode (Just (AlexPn _ ln _,code)) filename hdl = do
hPutStrLn hdl ("{-# LINE " ++ show ln ++ " \"" ++ filename ++ "\" #-}")
hPutStrLn hdl code
optsToInject :: Target -> [CLIFlags] -> [String]
optsToInject target _ = concat
[ optNoWarnings
, [ "{-# LANGUAGE CPP #-}" ]
, [ "{-# LANGUAGE MagicHash #-}" | target == GhcTarget ]
]
-- List here all harmless warnings caused by Alex-generated code.
--
-- These will be suppressed so that they are not printed
-- when users turn on @-Wall@ in their lexer project.
--
optNoWarnings :: [String]
optNoWarnings =
map (("{-# OPTIONS_GHC -fno-warn-" ++) . (++ " #-}"))
[ "missing-signatures"
, "tabs"
, "unused-binds"
, "unused-imports"
]
importsToInject :: Target -> [CLIFlags] -> String
importsToInject _ cli = unlines $
always_imports ++ debug_imports ++ glaexts_import
where
glaexts_import | OptGhcTarget `elem` cli = import_glaexts
| otherwise = []
debug_imports | OptDebugParser `elem` cli = import_debug
| otherwise = []
-- We need to #include "ghcconfig.h" to get hold of
-- WORDS_BIGENDIAN (see AlexTemplate.hs).
always_imports :: [String]
always_imports =
[ "#include \"ghcconfig.h\""
, "import qualified Data.Array"
, "import qualified Data.Char"
]
import_glaexts :: [String]
import_glaexts =
[ "import Data.Array.Base (unsafeAt)"
, "import GHC.Exts (" ++ imports ++ ")"
, "import qualified GHC.Exts"
]
where
-- We can import anything mentioning # safely,
-- assuming the user code does not make use of
-- MagicHash.
imports = intercalate ","
[ "Addr#"
, "Int#"
, "Int(I#)"
, "(*#)"
, "(+#)"
, "(-#)"
, "(==#)"
, "(>=#)"
, "indexCharOffAddr#"
, "indexInt16OffAddr#"
, "indexInt32OffAddr#"
, "int2Word#"
, "narrow16Int#"
, "narrow32Int#"
, "negateInt#"
, "or#"
, "ord#"
, "uncheckedShiftL#"
, "word2Int#"
]
import_debug :: [String]
import_debug =
[ "import qualified Debug.Trace"
]
templateDir :: IO FilePath -> [CLIFlags] -> IO FilePath
templateDir def cli
= case [ d | OptTemplateDir d <- cli ] of
[] -> def
ds -> return (last ds)
templateCppDefs :: Target -> Encoding -> UsesPreds -> [CLIFlags] -> [String]
templateCppDefs target encoding usespreds cli =
map ("ALEX_" ++) $ concat
[ [ "GHC" | target == GhcTarget ]
, [ "LATIN1" | encoding == Latin1 ]
, [ "NOPRED" | usespreds == DoesntUsePreds ]
, [ "DEBUG" | OptDebugParser `elem` cli ]
]
infoStart :: FilePath -> FilePath -> IO (String -> IO (), IO ())
infoStart x_file info_file = do
bracketOnError
(alexOpenFile info_file WriteMode)
(\h -> do hClose h; removeFile info_file)
(\h -> do infoHeader h x_file
return (hPutStr h, hClose h)
)
infoHeader :: Handle -> FilePath -> IO ()
infoHeader h file = do
-- hSetBuffering h NoBuffering
hPutStrLn h ("Info file produced by Alex version " ++ projectVersion ++
", from " ++ file)
hPutStrLn h hline
hPutStr h "\n"
initialParserEnv :: (Map String CharSet, Map String RExp)
initialParserEnv = (initSetEnv, initREEnv)
initSetEnv :: Map String CharSet
initSetEnv = Map.fromList [("white", charSet " \t\n\v\f\r"),
("printable", charSetRange (chr 32) (chr 0x10FFFF)), -- FIXME: Look it up the unicode standard
(".", charSetComplement emptyCharSet
`charSetMinus` charSetSingleton '\n')]
initREEnv :: Map String RExp
initREEnv = Map.empty
-- -----------------------------------------------------------------------------
-- Command-line flags
data CLIFlags
= OptDebugParser
| OptGhcTarget
| OptOutputFile FilePath
| OptInfoFile (Maybe FilePath)
| OptTabSize String
| OptTemplateDir FilePath
| OptLatin1
| OptVerbose
| DumpHelp
| DumpVersion
| DumpNumericVersion
deriving Eq
argInfo :: [OptDescr CLIFlags]
argInfo = [
Option ['o'] ["outfile"] (ReqArg OptOutputFile "FILE")
"write the output to FILE (default: file.hs)",
Option ['i'] ["info"] (OptArg OptInfoFile "FILE")
"put detailed state-machine info in FILE (or file.info)",
Option ['t'] ["template"] (ReqArg OptTemplateDir "DIR")
"look in DIR for template files",
Option ['g'] ["ghc"] (NoArg OptGhcTarget)
"use GHC extensions",
Option ['l'] ["latin1"] (NoArg OptLatin1)
"generated lexer will use the Latin-1 encoding instead of UTF-8",
Option ['s'] ["tab-size"] (ReqArg OptTabSize "NUMBER")
"set tab size to be used in the generated lexer (default: 8)",
Option ['d'] ["debug"] (NoArg OptDebugParser)
"produce a debugging scanner",
Option ['v'] ["verbose"] (NoArg OptVerbose)
"be verbose (not yet implemented)",
Option ['?'] ["help"] (NoArg DumpHelp)
"display this help and exit",
Option ['V'] ["version"] (NoArg DumpVersion)
"output version information and exit"
,Option [] ["numeric-version"] (NoArg DumpNumericVersion)
"output the version number and exit"
]
-- -----------------------------------------------------------------------------
-- Utils
getProgramName :: IO String
getProgramName = liftM (`withoutSuffix` ".bin") getProgName
where str `withoutSuffix` suff
| suff `isSuffixOf` str = take (length str - length suff) str
| otherwise = str
bye :: String -> IO a
bye s = putStr s >> exitWith ExitSuccess
die :: String -> IO a
die s = hPutStr stderr s >> exitWith (ExitFailure 1)
dieAlex :: String -> IO a
dieAlex s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)