{-# 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 :: String -> IO String
alexReadFile String
file = Handle -> IO String
hGetContents (Handle -> IO String) -> IO Handle -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IOMode -> IO Handle
alexOpenFile String
file IOMode
ReadMode

-- We need to force every file we write to be written
-- to as UTF8
alexOpenFile :: FilePath -> IOMode -> IO Handle
alexOpenFile :: String -> IOMode -> IO Handle
alexOpenFile String
file IOMode
mode = do
  Handle
h <- String -> IOMode -> IO Handle
openFile String
file IOMode
mode
  Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8
  Handle -> IO Handle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h

-- `main' decodes the command line arguments and calls `alex'.

main:: IO ()
IO ()
main = do
  [String]
args <- IO [String]
getArgs
  case ArgOrder CLIFlags
-> [OptDescr CLIFlags]
-> [String]
-> ([CLIFlags], [String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder CLIFlags
forall a. ArgOrder a
Permute [OptDescr CLIFlags]
argInfo [String]
args of
    ([CLIFlags]
cli,[String]
_,[]) | CLIFlags
DumpHelp CLIFlags -> [CLIFlags] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli -> do
        String
prog <- IO String
getProgramName
        String -> IO ()
forall a. String -> IO a
bye (String -> [OptDescr CLIFlags] -> String
forall a. String -> [OptDescr a] -> String
usageInfo (String -> String
usageHeader String
prog) [OptDescr CLIFlags]
argInfo)
    ([CLIFlags]
cli,[String]
_,[]) | CLIFlags
DumpVersion CLIFlags -> [CLIFlags] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli ->
        String -> IO ()
forall a. String -> IO a
bye String
copyright
    ([CLIFlags]
cli,[String]
_,[]) | CLIFlags
DumpNumericVersion CLIFlags -> [CLIFlags] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli ->
        String -> IO ()
forall a. String -> IO a
bye String
projectVersion
    ([CLIFlags]
cli,[String]
_,[]) | CLIFlags
OptVerbose CLIFlags -> [CLIFlags] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli ->
        String -> IO ()
forall a. String -> IO a
failure String
"Option '--verbose' not yet implemented"
    ([CLIFlags]
cli,[String
file],[]) ->
        [CLIFlags] -> String -> IO ()
runAlex [CLIFlags]
cli String
file
    ([CLIFlags]
_,[String]
_,[String]
errors) ->
        String -> IO ()
forall a. String -> IO a
failure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String]
errors
  where
    failure :: String -> IO b
failure String
err = do
      String
prog <- IO String
getProgramName
      String -> IO b
forall a. String -> IO a
die (String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [OptDescr CLIFlags] -> String
forall a. String -> [OptDescr a] -> String
usageInfo (String -> String
usageHeader String
prog) [OptDescr CLIFlags]
argInfo)

projectVersion :: String
projectVersion :: String
projectVersion = Version -> String
showVersion Version
version

copyright :: String
copyright :: String
copyright = String
"Alex version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
projectVersion String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", (c) 2003 Chris Dornan and Simon Marlow\n"

usageHeader :: String -> String
usageHeader :: String -> String
usageHeader String
prog = String
"Usage: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
prog String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [OPTION...] file\n"

runAlex :: [CLIFlags] -> FilePath -> IO ()
runAlex :: [CLIFlags] -> String -> IO ()
runAlex [CLIFlags]
cli String
file = do
  String
basename <- case (String -> String
forall a. [a] -> [a]
reverse String
file) of
                Char
'x':Char
'.':String
r -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
forall a. [a] -> [a]
reverse String
r)
                String
_         -> String -> IO String
forall a. String -> IO a
die (String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": filename must end in \'.x\'\n")

  String
prg <- String -> IO String
alexReadFile String
file
  (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
script <- String
-> String
-> IO
     (Maybe (AlexPosn, String), [Directive], Scanner,
      Maybe (AlexPosn, String))
parseScript String
file String
prg
  [CLIFlags]
-> String
-> String
-> (Maybe (AlexPosn, String), [Directive], Scanner,
    Maybe (AlexPosn, String))
-> IO ()
alex [CLIFlags]
cli String
file String
basename (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
script

parseScript :: FilePath -> String
  -> IO (Maybe (AlexPosn,Code), [Directive], Scanner, Maybe (AlexPosn,Code))
parseScript :: String
-> String
-> IO
     (Maybe (AlexPosn, String), [Directive], Scanner,
      Maybe (AlexPosn, String))
parseScript String
file String
prg =
  case String
-> (Map String CharSet, Map String RExp)
-> P (Maybe (AlexPosn, String), [Directive], Scanner,
      Maybe (AlexPosn, String))
-> Either
     ParseError
     ([Warning],
      (Maybe (AlexPosn, String), [Directive], Scanner,
       Maybe (AlexPosn, String)))
forall a.
String
-> (Map String CharSet, Map String RExp)
-> P a
-> Either ParseError ([Warning], a)
runP String
prg (Map String CharSet, Map String RExp)
initialParserEnv P (Maybe (AlexPosn, String), [Directive], Scanner,
   Maybe (AlexPosn, String))
parse of
        Left (Just (AlexPn Int
_ Int
line Int
col),String
err) ->
                String
-> IO
     (Maybe (AlexPosn, String), [Directive], Scanner,
      Maybe (AlexPosn, String))
forall a. String -> IO a
die (String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
line String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
col
                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")
        Left (Maybe AlexPosn
Nothing, String
err) ->
                String
-> IO
     (Maybe (AlexPosn, String), [Directive], Scanner,
      Maybe (AlexPosn, String))
forall a. String -> IO a
die (String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")

        Right ([Warning]
warnings, script :: (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
script@(Maybe (AlexPosn, String)
_, [Directive]
_, Scanner
scanner, Maybe (AlexPosn, String)
_)) -> do
          -- issue 46: give proper error when lexer definition is empty
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([RECtx] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([RECtx] -> Bool) -> [RECtx] -> Bool
forall a b. (a -> b) -> a -> b
$ Scanner -> [RECtx]
scannerTokens Scanner
scanner) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
forall a. String -> IO a
dieAlex (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" contains no lexer rules\n"
          -- issue 71: warn about nullable regular expressions
          (Warning -> IO ()) -> [Warning] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Warning -> IO ()
printWarning [Warning]
warnings
          (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
-> IO
     (Maybe (AlexPosn, String), [Directive], Scanner,
      Maybe (AlexPosn, String))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
script
  where
  printWarning :: Warning -> IO ()
printWarning (WarnNullableRExp (AlexPn Int
_ Int
line Int
col) String
msg) =
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ String
"Warning: "
      , String
file , String
":", Int -> String
forall a. Show a => a -> String
show Int
line , String
":" , Int -> String
forall a. Show a => a -> String
show Int
col , String
": "
      , String
msg
      ]

alex :: [CLIFlags]
     -> FilePath
     -> FilePath
     -> (Maybe (AlexPosn, Code), [Directive], Scanner, Maybe (AlexPosn, Code))
     -> IO ()
alex :: [CLIFlags]
-> String
-> String
-> (Maybe (AlexPosn, String), [Directive], Scanner,
    Maybe (AlexPosn, String))
-> IO ()
alex [CLIFlags]
cli String
file String
basename (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
script = do
   (String -> IO ()
put_info, IO ()
finish_info) <-
      case [ Maybe String
f | OptInfoFile Maybe String
f <- [CLIFlags]
cli ] of
           []  -> (String -> IO (), IO ()) -> IO (String -> IO (), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (\String
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (), () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
           [Maybe String
Nothing] -> String -> String -> IO (String -> IO (), IO ())
infoStart String
file (String
basename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".info")
           [Just String
f]  -> String -> String -> IO (String -> IO (), IO ())
infoStart String
file String
f
           [Maybe String]
_   -> String -> IO (String -> IO (), IO ())
forall a. String -> IO a
dieAlex String
"multiple -i/--info options"

   String
o_file <- case [ String
f | OptOutputFile String
f <- [CLIFlags]
cli ] of
                []  -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
basename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".hs")
                [String
f] -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
f
                [String]
_   -> String -> IO String
forall a. String -> IO a
dieAlex String
"multiple -o/--outfile options"

   Int
tab_size <- case [ String
s | OptTabSize String
s <- [CLIFlags]
cli ] of
                []  -> Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
8 :: Int)
                [String
s] -> case ReadS Int
forall a. Read a => ReadS a
reads String
s of
                        [(Int
n,String
"")] -> Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n
                        [(Int, String)]
_        -> String -> IO Int
forall a. String -> IO a
dieAlex String
"-s/--tab-size option is not a valid integer"
                [String]
_   -> String -> IO Int
forall a. String -> IO a
dieAlex String
"multiple -s/--tab-size options"

   let target :: Target
target
        | CLIFlags
OptGhcTarget CLIFlags -> [CLIFlags] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli = Target
GhcTarget
        | Bool
otherwise               = Target
HaskellTarget

   let encodingsCli :: [Encoding]
encodingsCli
        | CLIFlags
OptLatin1 CLIFlags -> [CLIFlags] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli = [Encoding
Latin1]
        | Bool
otherwise            = []

   String
template_dir  <- IO String -> [CLIFlags] -> IO String
templateDir IO String
getDataDir [CLIFlags]
cli

   let maybe_header, maybe_footer :: Maybe (AlexPosn, Code)
       directives                 :: [Directive]
       scanner1                   :: Scanner
       (Maybe (AlexPosn, String)
maybe_header, [Directive]
directives, Scanner
scanner1, Maybe (AlexPosn, String)
maybe_footer) = (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
script

   Scheme
scheme <- [Directive] -> IO Scheme
getScheme [Directive]
directives

   -- open the output file; remove it if we encounter an error
   IO Handle -> (Handle -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (String -> IOMode -> IO Handle
alexOpenFile String
o_file IOMode
WriteMode)
        (\Handle
h -> do Handle -> IO ()
hClose Handle
h; String -> IO ()
removeFile String
o_file)
        ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
out_h -> do

   let   scanner2, scanner_final :: Scanner
         scs                     :: [StartCode]
         sc_hdr, actions         :: ShowS
         encodingsScript         :: [Encoding]

         (Scanner
scanner2, [Int]
scs, String -> String
sc_hdr) = Scanner -> (Scanner, [Int], String -> String)
encodeStartCodes Scanner
scanner1
         (Scanner
scanner_final, String -> String
actions) = Scheme -> Scanner -> (Scanner, String -> String)
extractActions Scheme
scheme Scanner
scanner2
         encodingsScript :: [Encoding]
encodingsScript = [ Encoding
e | EncodingDirective Encoding
e <- [Directive]
directives ]

   Encoding
encoding <- case [Encoding] -> [Encoding]
forall a. Eq a => [a] -> [a]
nub ([Encoding]
encodingsCli [Encoding] -> [Encoding] -> [Encoding]
forall a. [a] -> [a] -> [a]
++ [Encoding]
encodingsScript) of
     []  -> Encoding -> IO Encoding
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Encoding
UTF8 -- default
     [Encoding
e] -> Encoding -> IO Encoding
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Encoding
e
     [Encoding]
_ | [Encoding] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Encoding]
encodingsCli -> String -> IO Encoding
forall a. String -> IO a
dieAlex String
"conflicting %encoding directives"
       | Bool
otherwise -> String -> IO Encoding
forall a. String -> IO a
dieAlex String
"--latin1 flag conflicts with %encoding directive"

   (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
out_h) (Target -> [CLIFlags] -> [String]
optsToInject Target
target [CLIFlags]
cli)
   Maybe (AlexPosn, String) -> String -> Handle -> IO ()
injectCode Maybe (AlexPosn, String)
maybe_header String
file Handle
out_h

   Handle -> String -> IO ()
hPutStr Handle
out_h (Target -> [CLIFlags] -> String
importsToInject Target
target [CLIFlags]
cli)

   -- add the wrapper, if necessary
   case Scheme -> Maybe [String]
wrapperCppDefs Scheme
scheme of
     Maybe [String]
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
     Just [String]
cppDefs -> do
       let wrapper_name :: String
wrapper_name = String
template_dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/AlexWrappers.hs"
       (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
out_h)
         [ [String] -> String
unwords [String
"#define", String
i, String
"1"]
         | String
i <- [String]
cppDefs ]
       String
str <- String -> IO String
alexReadFile String
wrapper_name
       Handle -> String -> IO ()
hPutStr Handle
out_h String
str

   -- Inject the tab size
   Handle -> String -> IO ()
hPutStrLn Handle
out_h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"alex_tab_size :: Int"
   Handle -> String -> IO ()
hPutStrLn Handle
out_h (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"alex_tab_size = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
tab_size :: Int)

   let dfa :: DFA Int String
dfa = Encoding -> Scanner -> [Int] -> DFA Int String
scanner2dfa Encoding
encoding Scanner
scanner_final [Int]
scs
       min_dfa :: DFA Int String
min_dfa = DFA Int String -> DFA Int String
forall a. Ord a => DFA Int a -> DFA Int a
minimizeDFA DFA Int String
dfa
       nm :: String
nm  = Scanner -> String
scannerName Scanner
scanner_final
       usespreds :: UsesPreds
usespreds = DFA Int String -> UsesPreds
forall s a. DFA s a -> UsesPreds
usesPreds DFA Int String
min_dfa


   String -> IO ()
put_info String
"\nStart codes\n"
   String -> IO ()
put_info ([Int] -> String
forall a. Show a => a -> String
show ([Int] -> String) -> [Int] -> String
forall a b. (a -> b) -> a -> b
$ [Int]
scs)
   String -> IO ()
put_info String
"\nScanner\n"
   String -> IO ()
put_info (Scanner -> String
forall a. Show a => a -> String
show (Scanner -> String) -> Scanner -> String
forall a b. (a -> b) -> a -> b
$ Scanner
scanner_final)
   String -> IO ()
put_info String
"\nNFA\n"
   String -> IO ()
put_info (NFA -> String
forall a. Show a => a -> String
show (NFA -> String) -> NFA -> String
forall a b. (a -> b) -> a -> b
$ Encoding -> Scanner -> [Int] -> NFA
scanner2nfa Encoding
encoding Scanner
scanner_final [Int]
scs)
   String -> IO ()
put_info String
"\nDFA"
   String -> IO ()
put_info (Int -> String -> DFA Int String -> String -> String
infoDFA Int
1 String
nm DFA Int String
dfa String
"")
   String -> IO ()
put_info String
"\nMinimized DFA"
   String -> IO ()
put_info (Int -> String -> DFA Int String -> String -> String
infoDFA Int
1 String
nm DFA Int String
min_dfa String
"")
   Handle -> String -> IO ()
hPutStr Handle
out_h (Target
-> Int -> String -> Scheme -> DFA Int String -> String -> String
outputDFA Target
target Int
1 String
nm Scheme
scheme DFA Int String
min_dfa String
"")

   Handle -> String -> IO ()
hPutStr Handle
out_h (String -> String
sc_hdr String
"")
   Handle -> String -> IO ()
hPutStr Handle
out_h (String -> String
actions String
"")

   -- add the template
   do
     let cppDefs :: [String]
cppDefs = Target -> Encoding -> UsesPreds -> [CLIFlags] -> [String]
templateCppDefs Target
target Encoding
encoding UsesPreds
usespreds [CLIFlags]
cli
     (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
out_h)
       [ [String] -> String
unwords [String
"#define", String
i, String
"1"]
       | String
i <- [String]
cppDefs ]
     String
tmplt <- String -> IO String
alexReadFile (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
template_dir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/AlexTemplate.hs"
     Handle -> String -> IO ()
hPutStr Handle
out_h String
tmplt

   Maybe (AlexPosn, String) -> String -> Handle -> IO ()
injectCode Maybe (AlexPosn, String)
maybe_footer String
file Handle
out_h

   Handle -> IO ()
hClose Handle
out_h
   IO ()
finish_info

getScheme :: [Directive] -> IO Scheme
getScheme :: [Directive] -> IO Scheme
getScheme [Directive]
directives =
  do
    Maybe String
token <- case [ String
ty | TokenType String
ty <- [Directive]
directives ] of
      [] -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
      [String
res] -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
res)
      [String]
_ -> String -> IO (Maybe String)
forall a. String -> IO a
dieAlex String
"multiple %token directives"

    Maybe String
action <- case [ String
ty | ActionType String
ty <- [Directive]
directives ] of
      [] -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
      [String
res] -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
res)
      [String]
_ -> String -> IO (Maybe String)
forall a. String -> IO a
dieAlex String
"multiple %action directives"

    Maybe String
typeclass <- case [ String
tyclass | TypeClass String
tyclass <- [Directive]
directives ] of
      [] -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
      [String
res] -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just String
res)
      [String]
_ -> String -> IO (Maybe String)
forall a. String -> IO a
dieAlex String
"multiple %typeclass directives"

    case [ String
f | WrapperDirective String
f <- [Directive]
directives ] of
        []  ->
          case (Maybe String
typeclass, Maybe String
token, Maybe String
action) of
            (Maybe String
Nothing, Maybe String
Nothing, Maybe String
Nothing) ->
              Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Default { defaultTypeInfo :: Maybe (Maybe String, String)
defaultTypeInfo = Maybe (Maybe String, String)
forall a. Maybe a
Nothing }
            (Maybe String
Nothing, Maybe String
Nothing, Just String
actionty) ->
              Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Default { defaultTypeInfo :: Maybe (Maybe String, String)
defaultTypeInfo = (Maybe String, String) -> Maybe (Maybe String, String)
forall a. a -> Maybe a
Just (Maybe String
forall a. Maybe a
Nothing, String
actionty) }
            (Just String
_, Maybe String
Nothing, Just String
actionty) ->
              Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Default { defaultTypeInfo :: Maybe (Maybe String, String)
defaultTypeInfo = (Maybe String, String) -> Maybe (Maybe String, String)
forall a. a -> Maybe a
Just (Maybe String
typeclass, String
actionty) }
            (Maybe String
_, Just String
_, Maybe String
_) ->
              String -> IO Scheme
forall a. String -> IO a
dieAlex String
"%token directive only allowed with a wrapper"
            (Just String
_, Maybe String
Nothing, Maybe String
Nothing) ->
              String -> IO Scheme
forall a. String -> IO a
dieAlex String
"%typeclass directive without %token directive"
        [String
single]
          | String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"gscan" ->
            case (Maybe String
typeclass, Maybe String
token, Maybe String
action) of
              (Maybe String
Nothing, Maybe String
Nothing, Maybe String
Nothing) ->
                Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GScan { gscanTypeInfo :: Maybe (Maybe String, String)
gscanTypeInfo = Maybe (Maybe String, String)
forall a. Maybe a
Nothing }
              (Maybe String
Nothing, Just String
tokenty, Maybe String
Nothing) ->
                Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GScan { gscanTypeInfo :: Maybe (Maybe String, String)
gscanTypeInfo = (Maybe String, String) -> Maybe (Maybe String, String)
forall a. a -> Maybe a
Just (Maybe String
forall a. Maybe a
Nothing, String
tokenty) }
              (Just String
_, Just String
tokenty, Maybe String
Nothing) ->
                Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GScan { gscanTypeInfo :: Maybe (Maybe String, String)
gscanTypeInfo = (Maybe String, String) -> Maybe (Maybe String, String)
forall a. a -> Maybe a
Just (Maybe String
typeclass, String
tokenty) }
              (Maybe String
_, Maybe String
_, Just String
_) ->
                String -> IO Scheme
forall a. String -> IO a
dieAlex String
"%action directive not allowed with a wrapper"
              (Just String
_, Maybe String
Nothing, Maybe String
Nothing) ->
                String -> IO Scheme
forall a. String -> IO a
dieAlex String
"%typeclass directive without %token directive"
          | String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"basic" Bool -> Bool -> Bool
|| String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"basic-bytestring" Bool -> Bool -> Bool
||
            String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"strict-bytestring" Bool -> Bool -> Bool
|| String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"strict-text" ->
            let
              strty :: StrType
strty = case String
single of
                String
"basic" -> StrType
Str
                String
"basic-bytestring" -> StrType
Lazy
                String
"strict-bytestring" -> StrType
Strict
                String
"strict-text" -> StrType
StrictText
                String
_ -> String -> StrType
forall a. HasCallStack => String -> a
error String
"Impossible case"
            in case (Maybe String
typeclass, Maybe String
token, Maybe String
action) of
              (Maybe String
Nothing, Maybe String
Nothing, Maybe String
Nothing) ->
                Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Basic { basicStrType :: StrType
basicStrType = StrType
strty,
                               basicTypeInfo :: Maybe (Maybe String, String)
basicTypeInfo = Maybe (Maybe String, String)
forall a. Maybe a
Nothing }
              (Maybe String
Nothing, Just String
tokenty, Maybe String
Nothing) ->
                Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Basic { basicStrType :: StrType
basicStrType = StrType
strty,
                               basicTypeInfo :: Maybe (Maybe String, String)
basicTypeInfo = (Maybe String, String) -> Maybe (Maybe String, String)
forall a. a -> Maybe a
Just (Maybe String
forall a. Maybe a
Nothing, String
tokenty) }
              (Just String
_, Just String
tokenty, Maybe String
Nothing) ->
                Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Basic { basicStrType :: StrType
basicStrType = StrType
strty,
                               basicTypeInfo :: Maybe (Maybe String, String)
basicTypeInfo = (Maybe String, String) -> Maybe (Maybe String, String)
forall a. a -> Maybe a
Just (Maybe String
typeclass, String
tokenty) }
              (Maybe String
_, Maybe String
_, Just String
_) ->
                String -> IO Scheme
forall a. String -> IO a
dieAlex String
"%action directive not allowed with a wrapper"
              (Just String
_, Maybe String
Nothing, Maybe String
Nothing) ->
                String -> IO Scheme
forall a. String -> IO a
dieAlex String
"%typeclass directive without %token directive"
          | String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"posn" Bool -> Bool -> Bool
|| String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"posn-bytestring" Bool -> Bool -> Bool
|| String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"posn-strict-text" ->
            let
              strty :: StrType
strty = case String
single of
                String
"posn" -> StrType
Str
                String
"posn-bytestring" -> StrType
Strict
                String
"posn-strict-text" -> StrType
StrictText
                String
_ -> String -> StrType
forall a. HasCallStack => String -> a
error String
"invalid str type for posn"
            in case (Maybe String
typeclass, Maybe String
token, Maybe String
action) of
              (Maybe String
Nothing, Maybe String
Nothing, Maybe String
Nothing) ->
                Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Posn { posnStrType :: StrType
posnStrType = StrType
strty,
                              posnTypeInfo :: Maybe (Maybe String, String)
posnTypeInfo = Maybe (Maybe String, String)
forall a. Maybe a
Nothing }
              (Maybe String
Nothing, Just String
tokenty, Maybe String
Nothing) ->
                Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Posn { posnStrType :: StrType
posnStrType = StrType
strty,
                              posnTypeInfo :: Maybe (Maybe String, String)
posnTypeInfo = (Maybe String, String) -> Maybe (Maybe String, String)
forall a. a -> Maybe a
Just (Maybe String
forall a. Maybe a
Nothing, String
tokenty) }
              (Just String
_, Just String
tokenty, Maybe String
Nothing) ->
                Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Posn { posnStrType :: StrType
posnStrType = StrType
strty,
                              posnTypeInfo :: Maybe (Maybe String, String)
posnTypeInfo = (Maybe String, String) -> Maybe (Maybe String, String)
forall a. a -> Maybe a
Just (Maybe String
typeclass, String
tokenty) }
              (Maybe String
_, Maybe String
_, Just String
_) ->
                  String -> IO Scheme
forall a. String -> IO a
dieAlex String
"%action directive not allowed with a wrapper"
              (Just String
_, Maybe String
Nothing, Maybe String
Nothing) ->
                String -> IO Scheme
forall a. String -> IO a
dieAlex String
"%typeclass directive without %token directive"
          | String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monad" Bool -> Bool -> Bool
|| String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monad-bytestring" Bool -> Bool -> Bool
|| String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monad-strict-text" Bool -> Bool -> Bool
||
            String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monadUserState" Bool -> Bool -> Bool
||
            String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monadUserState-bytestring" Bool -> Bool -> Bool
||
            String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monadUserState-strict-text" ->
            let
              isText :: Bool
isText = String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monad-strict-text" Bool -> Bool -> Bool
||
                       String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monadUserState-strict-text"
              isByteString :: Bool
isByteString = String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monad-bytestring" Bool -> Bool -> Bool
||
                             String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monadUserState-bytestring"
              userState :: Bool
userState = String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monadUserState" Bool -> Bool -> Bool
||
                          String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monadUserState-bytestring" Bool -> Bool -> Bool
||
                          String
single String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"monadUserState-strict-text"
            in case (Maybe String
typeclass, Maybe String
token, Maybe String
action) of
              (Maybe String
Nothing, Maybe String
Nothing, Maybe String
Nothing) ->
                Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Monad { monadStrType :: StrType
monadStrType = if Bool
isByteString then StrType
Lazy else if Bool
isText then StrType
StrictText else StrType
Str,
                               monadUserState :: Bool
monadUserState = Bool
userState,
                               monadTypeInfo :: Maybe (Maybe String, String)
monadTypeInfo = Maybe (Maybe String, String)
forall a. Maybe a
Nothing }
              (Maybe String
Nothing, Just String
tokenty, Maybe String
Nothing) ->
                Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Monad { monadStrType :: StrType
monadStrType = if Bool
isByteString then StrType
Lazy else if Bool
isText then StrType
StrictText else StrType
Str,
                               monadUserState :: Bool
monadUserState = Bool
userState,
                               monadTypeInfo :: Maybe (Maybe String, String)
monadTypeInfo = (Maybe String, String) -> Maybe (Maybe String, String)
forall a. a -> Maybe a
Just (Maybe String
forall a. Maybe a
Nothing, String
tokenty) }
              (Just String
_, Just String
tokenty, Maybe String
Nothing) ->
                Scheme -> IO Scheme
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Monad { monadStrType :: StrType
monadStrType = if Bool
isByteString then StrType
Lazy else if Bool
isText then StrType
StrictText else StrType
Str,
                               monadUserState :: Bool
monadUserState = Bool
userState,
                               monadTypeInfo :: Maybe (Maybe String, String)
monadTypeInfo = (Maybe String, String) -> Maybe (Maybe String, String)
forall a. a -> Maybe a
Just (Maybe String
typeclass, String
tokenty) }
              (Maybe String
_, Maybe String
_, Just String
_) ->
                  String -> IO Scheme
forall a. String -> IO a
dieAlex String
"%action directive not allowed with a wrapper"
              (Just String
_, Maybe String
Nothing, Maybe String
Nothing) ->
                String -> IO Scheme
forall a. String -> IO a
dieAlex String
"%typeclass directive without %token directive"
          | Bool
otherwise -> String -> IO Scheme
forall a. String -> IO a
dieAlex (String
"unknown wrapper type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
single)
        [String]
_many -> String -> IO Scheme
forall a. String -> IO a
dieAlex String
"multiple %wrapper directives"

-- inject some code, and add a {-# LINE #-} pragma at the top
injectCode :: Maybe (AlexPosn,Code) -> FilePath -> Handle -> IO ()
injectCode :: Maybe (AlexPosn, String) -> String -> Handle -> IO ()
injectCode Maybe (AlexPosn, String)
Nothing String
_ Handle
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
injectCode (Just (AlexPn Int
_ Int
ln Int
_,String
code)) String
filename Handle
hdl = do
  Handle -> String -> IO ()
hPutStrLn Handle
hdl (String
"{-# LINE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ln String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
filename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" #-}")
  Handle -> String -> IO ()
hPutStrLn Handle
hdl String
code

optsToInject :: Target -> [CLIFlags] -> [String]
optsToInject :: Target -> [CLIFlags] -> [String]
optsToInject Target
target [CLIFlags]
_ = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [String]
optNoWarnings
  , [ String
"{-# LANGUAGE CPP #-}" ]
  , [ String
"{-# LANGUAGE MagicHash #-}" | Target
target Target -> Target -> Bool
forall a. Eq a => a -> a -> Bool
== 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 :: [String]
optNoWarnings =
  (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"{-# OPTIONS_GHC -fno-warn-" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" #-}"))
    [ String
"missing-signatures"
    , String
"tabs"
    , String
"unused-binds"
    , String
"unused-imports"
    ]

importsToInject :: Target -> [CLIFlags] -> String
importsToInject :: Target -> [CLIFlags] -> String
importsToInject Target
_ [CLIFlags]
cli = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
  [String]
always_imports [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
debug_imports [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
glaexts_import
  where
        glaexts_import :: [String]
glaexts_import | CLIFlags
OptGhcTarget CLIFlags -> [CLIFlags] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli    = [String]
import_glaexts
                       | Bool
otherwise                  = []

        debug_imports :: [String]
debug_imports  | CLIFlags
OptDebugParser CLIFlags -> [CLIFlags] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli = [String]
import_debug
                       | Bool
otherwise                 = []

-- We need to #include "ghcconfig.h" to get hold of
-- WORDS_BIGENDIAN (see AlexTemplate.hs).

always_imports :: [String]
always_imports :: [String]
always_imports =
  [ String
"#include \"ghcconfig.h\""
  , String
"import qualified Data.Array"
  , String
"import qualified Data.Char"
  ]

import_glaexts :: [String]
import_glaexts :: [String]
import_glaexts =
  [ String
"import Data.Array.Base (unsafeAt)"
  , String
"import GHC.Exts (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
imports String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
  , String
"import qualified GHC.Exts"
  ]
  where
    -- We can import anything mentioning # safely,
    -- assuming the user code does not make use of
    -- MagicHash.
    imports :: String
imports = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
","
      [ String
"Addr#"
      , String
"Int#"
      , String
"Int(I#)"
      , String
"(*#)"
      , String
"(+#)"
      , String
"(-#)"
      , String
"(==#)"
      , String
"(>=#)"
      , String
"indexCharOffAddr#"
      , String
"indexInt16OffAddr#"
      , String
"indexInt32OffAddr#"
      , String
"int2Word#"
      , String
"narrow16Int#"
      , String
"narrow32Int#"
      , String
"negateInt#"
      , String
"or#"
      , String
"ord#"
      , String
"uncheckedShiftL#"
      , String
"word2Int#"
      ]

import_debug :: [String]
import_debug :: [String]
import_debug =
  [ String
"import qualified Debug.Trace"
  ]

templateDir :: IO FilePath -> [CLIFlags] -> IO FilePath
templateDir :: IO String -> [CLIFlags] -> IO String
templateDir IO String
def [CLIFlags]
cli
  = case [ String
d | OptTemplateDir String
d <- [CLIFlags]
cli ] of
      [] -> IO String
def
      [String]
ds -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> String
forall a. HasCallStack => [a] -> a
last [String]
ds)

templateCppDefs :: Target -> Encoding -> UsesPreds -> [CLIFlags] -> [String]
templateCppDefs :: Target -> Encoding -> UsesPreds -> [CLIFlags] -> [String]
templateCppDefs Target
target Encoding
encoding UsesPreds
usespreds [CLIFlags]
cli =
  (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"ALEX_" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
"GHC"    | Target
target Target -> Target -> Bool
forall a. Eq a => a -> a -> Bool
== Target
GhcTarget ]
    , [ String
"LATIN1" | Encoding
encoding Encoding -> Encoding -> Bool
forall a. Eq a => a -> a -> Bool
== Encoding
Latin1  ]
    , [ String
"NOPRED" | UsesPreds
usespreds UsesPreds -> UsesPreds -> Bool
forall a. Eq a => a -> a -> Bool
== UsesPreds
DoesntUsePreds  ]
    , [ String
"DEBUG"  | CLIFlags
OptDebugParser CLIFlags -> [CLIFlags] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli  ]
    ]

infoStart :: FilePath -> FilePath -> IO (String -> IO (), IO ())
infoStart :: String -> String -> IO (String -> IO (), IO ())
infoStart String
x_file String
info_file = do
  IO Handle
-> (Handle -> IO ())
-> (Handle -> IO (String -> IO (), IO ()))
-> IO (String -> IO (), IO ())
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracketOnError
        (String -> IOMode -> IO Handle
alexOpenFile String
info_file IOMode
WriteMode)
        (\Handle
h -> do Handle -> IO ()
hClose Handle
h; String -> IO ()
removeFile String
info_file)
        (\Handle
h -> do Handle -> String -> IO ()
infoHeader Handle
h String
x_file
                  (String -> IO (), IO ()) -> IO (String -> IO (), IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> String -> IO ()
hPutStr Handle
h, Handle -> IO ()
hClose Handle
h)
        )

infoHeader :: Handle -> FilePath -> IO ()
infoHeader :: Handle -> String -> IO ()
infoHeader Handle
h String
file = do
--  hSetBuffering h NoBuffering
  Handle -> String -> IO ()
hPutStrLn Handle
h (String
"Info file produced by Alex version " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
projectVersion String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
", from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file)
  Handle -> String -> IO ()
hPutStrLn Handle
h String
hline
  Handle -> String -> IO ()
hPutStr Handle
h String
"\n"

initialParserEnv :: (Map String CharSet, Map String RExp)
initialParserEnv :: (Map String CharSet, Map String RExp)
initialParserEnv = (Map String CharSet
initSetEnv, Map String RExp
initREEnv)

initSetEnv :: Map String CharSet
initSetEnv :: Map String CharSet
initSetEnv = [(String, CharSet)] -> Map String CharSet
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String
"white", String -> CharSet
charSet String
" \t\n\v\f\r"),
                           (String
"printable", Char -> Char -> CharSet
charSetRange (Int -> Char
chr Int
32) (Int -> Char
chr Int
0x10FFFF)), -- FIXME: Look it up the unicode standard
                           (String
".", CharSet -> CharSet
charSetComplement CharSet
emptyCharSet
                            CharSet -> CharSet -> CharSet
`charSetMinus` Char -> CharSet
charSetSingleton Char
'\n')]

initREEnv :: Map String RExp
initREEnv :: Map String RExp
initREEnv = Map String RExp
forall k a. Map k a
Map.empty

-- -----------------------------------------------------------------------------
-- Command-line flags

data CLIFlags
  = OptDebugParser
  | OptGhcTarget
  | OptOutputFile FilePath
  | OptInfoFile (Maybe FilePath)
  | OptTabSize String
  | OptTemplateDir FilePath
  | OptLatin1
  | OptVerbose
  | DumpHelp
  | DumpVersion
  | DumpNumericVersion
  deriving CLIFlags -> CLIFlags -> Bool
(CLIFlags -> CLIFlags -> Bool)
-> (CLIFlags -> CLIFlags -> Bool) -> Eq CLIFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CLIFlags -> CLIFlags -> Bool
== :: CLIFlags -> CLIFlags -> Bool
$c/= :: CLIFlags -> CLIFlags -> Bool
/= :: CLIFlags -> CLIFlags -> Bool
Eq

argInfo :: [OptDescr CLIFlags]
argInfo :: [OptDescr CLIFlags]
argInfo  = [
   String
-> [String] -> ArgDescr CLIFlags -> String -> OptDescr CLIFlags
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'o'] [String
"outfile"] ((String -> CLIFlags) -> String -> ArgDescr CLIFlags
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> CLIFlags
OptOutputFile String
"FILE")
        String
"write the output to FILE (default: file.hs)",
   String
-> [String] -> ArgDescr CLIFlags -> String -> OptDescr CLIFlags
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'i'] [String
"info"] ((Maybe String -> CLIFlags) -> String -> ArgDescr CLIFlags
forall a. (Maybe String -> a) -> String -> ArgDescr a
OptArg Maybe String -> CLIFlags
OptInfoFile String
"FILE")
        String
"put detailed state-machine info in FILE (or file.info)",
   String
-> [String] -> ArgDescr CLIFlags -> String -> OptDescr CLIFlags
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
't'] [String
"template"] ((String -> CLIFlags) -> String -> ArgDescr CLIFlags
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> CLIFlags
OptTemplateDir String
"DIR")
        String
"look in DIR for template files",
   String
-> [String] -> ArgDescr CLIFlags -> String -> OptDescr CLIFlags
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'g'] [String
"ghc"]    (CLIFlags -> ArgDescr CLIFlags
forall a. a -> ArgDescr a
NoArg CLIFlags
OptGhcTarget)
        String
"use GHC extensions",
   String
-> [String] -> ArgDescr CLIFlags -> String -> OptDescr CLIFlags
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'l'] [String
"latin1"]    (CLIFlags -> ArgDescr CLIFlags
forall a. a -> ArgDescr a
NoArg CLIFlags
OptLatin1)
        String
"generated lexer will use the Latin-1 encoding instead of UTF-8",
   String
-> [String] -> ArgDescr CLIFlags -> String -> OptDescr CLIFlags
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
's'] [String
"tab-size"] ((String -> CLIFlags) -> String -> ArgDescr CLIFlags
forall a. (String -> a) -> String -> ArgDescr a
ReqArg String -> CLIFlags
OptTabSize String
"NUMBER")
        String
"set tab size to be used in the generated lexer (default: 8)",
   String
-> [String] -> ArgDescr CLIFlags -> String -> OptDescr CLIFlags
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'd'] [String
"debug"] (CLIFlags -> ArgDescr CLIFlags
forall a. a -> ArgDescr a
NoArg CLIFlags
OptDebugParser)
        String
"produce a debugging scanner",
   String
-> [String] -> ArgDescr CLIFlags -> String -> OptDescr CLIFlags
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'v'] [String
"verbose"] (CLIFlags -> ArgDescr CLIFlags
forall a. a -> ArgDescr a
NoArg CLIFlags
OptVerbose)
        String
"be verbose (not yet implemented)",
   String
-> [String] -> ArgDescr CLIFlags -> String -> OptDescr CLIFlags
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'?'] [String
"help"] (CLIFlags -> ArgDescr CLIFlags
forall a. a -> ArgDescr a
NoArg CLIFlags
DumpHelp)
        String
"display this help and exit",
   String
-> [String] -> ArgDescr CLIFlags -> String -> OptDescr CLIFlags
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [Char
'V'] [String
"version"] (CLIFlags -> ArgDescr CLIFlags
forall a. a -> ArgDescr a
NoArg CLIFlags
DumpVersion)
        String
"output version information and exit"
  ,String
-> [String] -> ArgDescr CLIFlags -> String -> OptDescr CLIFlags
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option [] [String
"numeric-version"] (CLIFlags -> ArgDescr CLIFlags
forall a. a -> ArgDescr a
NoArg CLIFlags
DumpNumericVersion)
        String
"output the version number and exit"
  ]

-- -----------------------------------------------------------------------------
-- Utils

getProgramName :: IO String
getProgramName :: IO String
getProgramName = (String -> String) -> IO String -> IO String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> String -> String
forall {a}. Eq a => [a] -> [a] -> [a]
`withoutSuffix` String
".bin") IO String
getProgName
   where [a]
str withoutSuffix :: [a] -> [a] -> [a]
`withoutSuffix` [a]
suff
            | [a]
suff [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` [a]
str = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
str Int -> Int -> Int
forall a. Num a => a -> a -> a
- [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
suff) [a]
str
            | Bool
otherwise             = [a]
str

bye :: String -> IO a
bye :: forall a. String -> IO a
bye String
s = String -> IO ()
putStr String
s IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess

die :: String -> IO a
die :: forall a. String -> IO a
die String
s = Handle -> String -> IO ()
hPutStr Handle
stderr String
s IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)

dieAlex :: String -> IO a
dieAlex :: forall a. String -> IO a
dieAlex String
s = IO String
getProgramName IO String -> (String -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
prog -> String -> IO a
forall a. String -> IO a
die (String
prog String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)