-------------------------------------------------------------------------------

--                  ALEX SCANNER AND LITERATE PREPROCESSOR

--

-- This Script defines the grammar used to generate the Alex scanner and a

-- preprocessing scanner for dealing with literate scripts.  The actions for

-- the Alex scanner are given separately in the Alex module.

--

-- See the Alex manual for a discussion of the scanners defined here.

--

-- Chris Dornan, Aug-95, 4-Jun-96, 10-Jul-96, 29-Sep-97

-------------------------------------------------------------------------------

{

module Scan (lexer, AlexPosn(..), Token(..), Tkn(..), tokPosn) where

import Data.Char

import ParseMonad

--import Debug.Trace

}

$digit    = 0-9

$hexdig   = [0-9 A-F a-f]

$octal    = 0-7

$lower    = a-z

$upper    = A-Z

$alpha    = [$upper $lower]

$alphanum = [$alpha $digit]

$idchar   = [$alphanum \_ \']

$special    = [\.\;\,\$\|\*\+\?\#\~\-\{\}\(\)\[\]\^\/]

$graphic    = $printable # $white

$nonspecial = $graphic # [$special \%]

@id     = $alpha $idchar*

@smac   = \$ @id | \$ \{ @id \}

@rmac   = \@ @id | \@ \{ @id \}

@comment = "--".*

@ws      = $white+ | @comment

alex :-

@ws                             { skip }     -- white space; ignore

<0> \" [^\"]* \"                { string }

<0> (@id @ws?)? \:\-            { bind }

<0> \{ / (\n | [^$digit])       { code }

<0> $special                    { special }  -- note: matches {

<0> \% "wrapper"                { wrapper }

<0> \% "encoding"               { encoding }

<0> \% "action"                 { actionty }

<0> \% "token"                  { tokenty }

<0> \% "typeclass"              { typeclass }

<0> \\ $digit+                  { decch }

<0> \\ x $hexdig+               { hexch }

<0> \\ o $octal+                { octch }

<0> \\ $printable               { escape }

<0> $nonspecial # [\<]          { char }

<0> @smac                       { smac }

<0> @rmac                       { rmac }

<0> @smac @ws? \=               { smacdef }

<0> @rmac @ws? \=               { rmacdef }

-- identifiers are allowed to be unquoted in startcode lists

<0>             \<              { special `andBegin` startcodes }

<startcodes>    0               { zero }

<startcodes>    @id             { startcode }

<startcodes>    \,              { special }

<startcodes>    \>              { special `andBegin` afterstartcodes }

-- After a <..> startcode sequence, we can have a {...} grouping of rules,

-- so don't try to interpret the opening { as a code block.

<afterstartcodes> \{ (\n | [^$digit ])  { special `andBegin` 0 }

<afterstartcodes> ()            { skip `andBegin` 0 }  -- note: empty pattern

{

-- -----------------------------------------------------------------------------

-- Token type

data Token = T AlexPosn Tkn

  deriving Show

tokPosn (T p _) = p

data Tkn

  = SpecialT Char

  | CodeT String

  | ZeroT

  | IdT String

  | StringT String

  | BindT String

  | CharT Char

  | SMacT String

  | RMacT String

  | SMacDefT String

  | RMacDefT String

  | NumT Int

  | WrapperT

  | EncodingT

  | ActionTypeT

  | TokenTypeT

  | TypeClassT

  | EOFT

  deriving Show

-- -----------------------------------------------------------------------------

-- Token functions

special, zero, string, bind, escape, decch, hexch, octch, char :: Action

smac, rmac, smacdef, rmacdef, startcode, wrapper, encoding :: Action

actionty, tokenty, typeclass :: Action

special   (p,_,str) _  = return $ T p (SpecialT  (head str))

zero      (p,_,_)   _  = return $ T p ZeroT

string    (p,_,str) ln = return $ T p (StringT (extract ln str))

bind      (p,_,str) _  = return $ T p (BindT (takeWhile isIdChar str))

escape    (p,_,str) _  = return $ T p (CharT (esc str))

decch     (p,_,str) ln = return $ T p (CharT (do_ech 10 ln (take (ln-1) (tail str))))

hexch     (p,_,str) ln = return $ T p (CharT (do_ech 16 ln (take (ln-2) (drop 2 str))))

octch     (p,_,str) ln = return $ T p (CharT (do_ech 8  ln (take (ln-2) (drop 2 str))))

char      (p,_,str) _  = return $ T p (CharT (head str))

smac      (p,_,str) ln = return $ T p (SMacT (mac ln str))

rmac      (p,_,str) ln = return $ T p (RMacT (mac ln str))

smacdef   (p,_,str) ln = return $ T p (SMacDefT (macdef ln str))

rmacdef   (p,_,str) ln = return $ T p (RMacDefT (macdef ln str))

startcode (p,_,str) ln = return $ T p (IdT (take ln str))

wrapper   (p,_,_)   _  = return $ T p WrapperT

encoding  (p,_,_)   _  = return $ T p EncodingT

actionty  (p,_,_)   _  = return $ T p ActionTypeT

tokenty   (p,_,_)   _  = return $ T p TokenTypeT

typeclass (p,_,_)   _  = return $ T p TypeClassT

isIdChar :: Char -> Bool

isIdChar c = isAlphaNum c || c `elem` "_'"

extract :: Int -> String -> String

extract ln str = take (ln-2) (tail str)

do_ech :: Int -> Int -> String -> Char

do_ech radix _ln str = chr (parseInt radix str)

mac :: Int -> String -> String

mac ln str = take (ln-1) $ tail str

-- TODO : replace not . isSpace with (\c -> not (isSpace c) && c /= '=')

macdef :: Int -> String -> String

macdef _ln str = takeWhile (\c -> not (isSpace c) && c /= '=') $ tail str

esc :: String -> Char

esc str =

  case head $ tail str of

    'a' -> '\a'

    'b' -> '\b'

    'f' -> '\f'

    'n' -> '\n'

    'r' -> '\r'

    't' -> '\t'

    'v' -> '\v'

    c   ->  c

parseInt :: Int -> String -> Int

parseInt radix ds = foldl1 (\n d -> n * radix + d) (map digitToInt ds)

-- In brace-delimited code, we have to be careful to match braces

-- within the code, but ignore braces inside strings and character

-- literals.  We do an approximate job (doing it properly requires

-- implementing a large chunk of the Haskell lexical syntax).

code :: Action

code (p,_,_inp) _ = do

  currentInput <- getInput

  go currentInput 1 ""

  where

    go :: AlexInput -> Int -> String -> P Token

    go inp 0 cs = do

      setInput inp

      return (T p (CodeT (reverse (tail cs))))

    go inp n cs = do

      case alexGetChar inp of

        Nothing       -> err inp

        Just (c,inp2) ->

          case c of

            '{'  -> go inp2 (n+1) (c:cs)

            '}'  -> go inp2 (n-1) (c:cs)

            '\'' -> go_char inp2 n (c:cs)

            '\"' -> go_str inp2 n (c:cs) '\"'

            c2   -> go inp2 n (c2:cs)

    go_char :: AlexInput -> Int -> String -> P Token

    -- try to catch multiple occurrences of ' at identifier end

    go_char inp n cs@('\'':'\'':_) = go inp n cs

    -- try to catch occurrences of ' within an identifier

    go_char inp n cs@('\'':c2:_)

      | isAlphaNum c2              = go inp n cs

    go_char inp n cs               = go_str inp n cs '\''

    go_str :: AlexInput -> Int -> String -> Char -> P Token

    go_str inp n cs end = do

      case alexGetChar inp of

          Nothing -> err inp

          Just (c,inp2)

            | c == end  -> go inp2 n (c:cs)

            | otherwise ->

              case c of

                '\\' -> case alexGetChar inp2 of

                          Nothing       -> err inp2

                          Just (d,inp3) -> go_str inp3 n (d:c:cs) end

                c2   -> go_str inp2 n (c2:cs) end

    err inp = do setInput inp; lexError "lexical error in code fragment"

lexError :: String -> P a

lexError s = do

  (_,_,_,input) <- getInput

  failP (s ++ (if (not (null input))

                  then " at " ++ show (head input)

                  else " at end of file"))

lexer :: (Token -> P a) -> P a

lexer cont = lexToken >>= cont

lexToken :: P Token

lexToken = do

  inp@(p,c,_,s) <- getInput

  sc <- getStartCode

  case alexScan inp sc of

    AlexEOF -> return (T p EOFT)

    AlexError _ -> lexError "lexical error"

    AlexSkip inp1 _ -> do

      setInput inp1

      lexToken

    AlexToken inp1 len t -> do

      setInput inp1

      t (p,c,s) len

type Action = (AlexPosn,Char,String) -> Int -> P Token

skip :: Action

skip _ _ = lexToken

andBegin :: Action -> StartCode -> Action

andBegin act sc inp len = setStartCode sc >> act inp len

}