-- -----------------------------------------------------------------------------
-- 
-- Alex.hs, part of Alex
--
-- (c) Chris Dornan 1995-2000, Simon Marlow 2003
--
-- ----------------------------------------------------------------------------}

module Text.Alex (
    runAlex
  , CLIFlags(..)
  , alex
  , optsToInject
  , importsToInject
  
  , parseScript, Target(..)
  ) where

import AbsSyn
import CharSet
import DFA
import DFAMin
import NFA
import Info
import Map ( Map )
import qualified Map hiding ( Map )
import Output
import ParseMonad ( runP )
import Parser
import Scan

import Data.Char ( chr )



runAlex :: [CLIFlags] -> Maybe FilePath -> String -> (String,String)
runAlex :: [CLIFlags] -> Maybe String -> String -> (String, String)
runAlex [CLIFlags]
cli Maybe String
file String
prg =
  let script :: (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
script = Maybe String
-> String
-> (Maybe (AlexPosn, String), [Directive], Scanner,
    Maybe (AlexPosn, String))
parseScript Maybe String
file String
prg in
  [CLIFlags]
-> (Maybe (AlexPosn, String), [Directive], Scanner,
    Maybe (AlexPosn, String))
-> (String, String)
alex [CLIFlags]
cli (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
script

parseScript :: Maybe FilePath -> String
  -> (Maybe (AlexPosn,Code), [Directive], Scanner, Maybe (AlexPosn,Code))
parseScript :: Maybe String
-> String
-> (Maybe (AlexPosn, String), [Directive], Scanner,
    Maybe (AlexPosn, String))
parseScript Maybe String
maybeFile String
prg =
  let file :: String
file = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"<no file>" String -> String
forall a. a -> a
id Maybe String
maybeFile in
  case String
-> (Map String CharSet, Map String RExp)
-> P (Maybe (AlexPosn, String), [Directive], Scanner,
      Maybe (AlexPosn, String))
-> Either
     ParseError
     (Maybe (AlexPosn, String), [Directive], Scanner,
      Maybe (AlexPosn, String))
forall a.
String
-> (Map String CharSet, Map String RExp)
-> P a
-> Either ParseError 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
-> (Maybe (AlexPosn, String), [Directive], Scanner,
    Maybe (AlexPosn, String))
forall a. HasCallStack => String -> a
error (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
-> (Maybe (AlexPosn, String), [Directive], Scanner,
    Maybe (AlexPosn, String))
forall a. HasCallStack => String -> a
error (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 (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
script -> (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
script



alex :: [CLIFlags]
     -> (Maybe (AlexPosn, Code), [Directive], Scanner, Maybe (AlexPosn, Code))
     -> (String,String)
alex :: [CLIFlags]
-> (Maybe (AlexPosn, String), [Directive], Scanner,
    Maybe (AlexPosn, String))
-> (String, String)
alex [CLIFlags]
cli (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
script =
  let 
    target :: Target
target = if CLIFlags
OptGhcTarget CLIFlags -> [CLIFlags] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli then Target
GhcTarget else Target
HaskellTarget
    encoding :: Encoding
encoding
      | CLIFlags
OptLatin1 CLIFlags -> [CLIFlags] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli = Encoding
Latin1   
      | Bool
otherwise            = Encoding
UTF8
    (Maybe (AlexPosn, String)
maybe_header, [Directive]
directives, Scanner
scanner1, Maybe (AlexPosn, String)
maybe_footer) = (Maybe (AlexPosn, String), [Directive], Scanner,
 Maybe (AlexPosn, String))
script
    (Scanner
scanner2, [Int]
scs, String -> String
sc_hdr) = Scanner -> (Scanner, [Int], String -> String)
encodeStartCodes Scanner
scanner1
    (Scanner
scanner_final, String -> String
actions) = Scanner -> (Scanner, String -> String)
extractActions Scanner
scanner2
    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
  in
   ((String -> String)
-> ((AlexPosn, String) -> String -> String)
-> Maybe (AlexPosn, String)
-> String
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String -> String
forall a. a -> a
id (String -> String -> String
forall a. [a] -> [a] -> [a]
(++) (String -> String -> String)
-> ((AlexPosn, String) -> String)
-> (AlexPosn, String)
-> String
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AlexPosn, String) -> String
forall a b. (a, b) -> b
snd) (Maybe (AlexPosn, String)
maybe_header) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ 
     (String -> String)
-> ((AlexPosn, String) -> String -> String)
-> Maybe (AlexPosn, String)
-> String
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String -> String
forall a. a -> a
id ((String -> String -> String) -> String -> String -> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> String
forall a. [a] -> [a] -> [a]
(++) (String -> String -> String)
-> ((AlexPosn, String) -> String)
-> (AlexPosn, String)
-> String
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AlexPosn, String) -> String
forall a b. (a, b) -> b
snd) (Maybe (AlexPosn, String)
maybe_footer) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ 
     Target -> Int -> String -> DFA Int String -> String -> String
outputDFA Target
target Int
1 String
nm DFA Int String
min_dfa String
"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
actions String
"") String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
sc_hdr String
"")
      ,(Int -> String -> DFA Int String -> String -> String
infoDFA Int
1 String
nm DFA Int String
min_dfa String
""))

optsToInject :: Target -> [CLIFlags] -> String
optsToInject :: Target -> [CLIFlags] -> String
optsToInject Target
GhcTarget [CLIFlags]
_ = String
"{-# OPTIONS -fglasgow-exts -cpp #-}\n"
optsToInject Target
_         [CLIFlags]
_ = String
"{-# OPTIONS -cpp #-}\n"

importsToInject :: Target -> [CLIFlags] -> String
importsToInject :: Target -> [CLIFlags] -> String
importsToInject Target
_ [CLIFlags]
cli = 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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CLIFlags]
cli    = String
import_glaexts
                       | Bool
otherwise                  = String
""

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

-- CPP is turned on for -fglasogw-exts, so we can use conditional
-- compilation.  We need to #include "config.h" to get hold of
-- WORDS_BIGENDIAN (see GenericTemplate.hs).

always_imports :: String
always_imports :: String
always_imports = String
"#if __GLASGOW_HASKELL__ >= 603\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"#include \"ghcconfig.h\"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"#elif defined(__GLASGOW_HASKELL__)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"#include \"config.h\"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"#endif\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"#if __GLASGOW_HASKELL__ >= 503\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"import Data.Array\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"import Data.Char (ord)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"import Data.Array.Base (unsafeAt)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"#else\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"import Array\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"import Char (ord)\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"#endif\n"

import_glaexts :: String
import_glaexts :: String
import_glaexts = String
"#if __GLASGOW_HASKELL__ >= 503\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"import GHC.Exts\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"#else\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"import GlaExts\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"#endif\n"

import_debug :: String 
import_debug :: String
import_debug   = String
"#if __GLASGOW_HASKELL__ >= 503\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"import System.IO\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"import System.IO.Unsafe\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"import Debug.Trace\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"#else\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"import IO\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"import IOExts\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                 String
"#endif\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
  | OptInfoFile (Maybe FilePath)
  | OptLatin1
  | DumpHelp
  | DumpVersion
  deriving CLIFlags -> CLIFlags -> Bool
(CLIFlags -> CLIFlags -> Bool)
-> (CLIFlags -> CLIFlags -> Bool) -> Eq CLIFlags
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CLIFlags -> CLIFlags -> Bool
$c/= :: CLIFlags -> CLIFlags -> Bool
== :: CLIFlags -> CLIFlags -> Bool
$c== :: CLIFlags -> CLIFlags -> Bool
Eq