{
{- |
  Module      :  Lighttpd.Conf.Lexer
  Copyright   :  (c) Matt Morrow 2008
  License     :  BSD3

  Maintainer  :  Matt Morrow <mjm2002@gmail.com>
  Stability   :  unstable
  Portability :  portable
-}

module Lighttpd.Conf.Lexer (
    scanTokens,
    Token(..)
) where

import Data.Char (isDigit,toLower)
import Data.Maybe (fromJust)
import Data.Monoid hiding (All)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B

-----------------------------------------------------------------------------
}

$digit      = 0-9
@decimal    = $digit+
$whitechar  = [ \t\n\r\f\v]
$large      = [A-Z \xc0-\xd6 \xd8-\xde]
$small      = [a-z \xdf-\xf6 \xf8-\xff \_]
$alpha      = [$small $large]
$graphic    = [$small $large $digit]
$cntrl      = [$large \@\[\\\]\^\_]
@ascii      = \^ $cntrl | NUL | SOH | STX | ETX | EOT | ENQ | ACK
            | BEL | BS  | HT  | LF  | VT  | FF  | CR  | SO  | SI | DLE
            | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM
            | SUB | ESC | FS  | GS  | RS  | US  | SP  | DEL
$charesc    = [abfnrtv\\\"\'\&]
@escape     = \\ ($charesc | @ascii | @decimal)
@gap        = \\ $whitechar+ \\
@string     = $graphic # [\"] | $printable # [\"] | " " | @escape | @gap
$idchar     = [$alpha $digit \-]
@name       = $alpha $idchar*
@fieldname  = \$ $large+
@splice     = \$ $small [$alpha $digit \']*

lighttpd :-

  $whitechar+     ;
  \# .*           {\s -> TComment (B.tail s)}
  \-? @decimal    {\s -> TInteger (atoiBS s)}
  global          {\_ -> TGlobal}
  \" enable \"    {\_ -> TBoolean True}
  \" disable \"   {\_ -> TBoolean False}
  \"@string*\"    {\s -> TString . B.tail . B.init $ s}
  include_shell   {\_ -> TIncludeShell}
  include         {\_ -> TIncludeValue}
  else            {\_ -> TElse}
  @splice         {\s -> TSplice (B.tail s)}
  @fieldname      {\s -> TFieldName (B.tail s)}
  @name           {\s -> TName s}
  \=\=            {\_ -> TEq}
  \!\=            {\_ -> TNEq}
  \=\~            {\_ -> TMatch}
  \!\~            {\_ -> TNotMatch}
  \=\>            {\_ -> TArrayValOp}
  \=              {\_ -> TOptionOp}
  \+\=            {\_ -> TMergeOp}
  \+              {\_ -> TPlusVal}
  \,              {\_ -> TComma}
  \.              {\_ -> TDot}
  \(              {\_ -> TOParen}
  \)              {\_ -> TCParen}
  \[              {\_ -> TOBrack}
  \]              {\_ -> TCBrack}
  \{              {\_ -> TOBrace}
  \}              {\_ -> TCBrace}
  .               ;

{
-----------------------------------------------------------------------------

data Token
  = TSplice ByteString            -- \$haskellVar
  | TComment ByteString           -- # ..
  | TGlobal                       -- global
  | TInteger Int                  -- 42
  | TString ByteString            -- "asdf"
  | TBoolean Bool                 -- enable disable
  | TName ByteString              -- var
  | TQName ByteString ByteString  -- modulename.key
  | TFieldName ByteString         -- HTTP
  | TIncludeValue                 -- include
  | TIncludeShell                 -- include_shell
  | TElse                         -- else
  | TEq                           -- ==
  | TNEq                          -- !=
  | TMatch                        -- =~
  | TNotMatch                     -- !~
  | TOptionOp                     -- =
  | TMergeOp                      -- +=
  | TPlusVal                      -- +
  | TArrayValOp                   -- =>
  | TDot
  | TComma                        -- ,
  | TOParen                       -- (
  | TCParen                       -- )
  | TOBrack                       -- [
  | TCBrack                       -- ]
  | TOBrace                       -- {
  | TCBrace                       -- }
  | TEOF
  deriving (Eq,Show)

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

type AlexInput = (Char, ByteString)

alexGetChar :: AlexInput -> Maybe (Char, AlexInput)
alexGetChar ~(c,bs)
    | bs==mempty = Nothing
    | otherwise = Just (c', (c', B.tail bs))
        where c' = B.head bs

alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar ~(c,bs) = c

data LexerReturn a = LexRet {
    tokLen    :: Int,
    lexInput  :: Maybe AlexInput,
    tokAction :: Maybe a
    }

instance Show (LexerReturn a) where
    show x = "LexRet ("++
        (show . tokLen $ x)++") ("++
        (show . lexInput $ x)++")"

fromAlexReturn :: AlexReturn a -> LexerReturn a
fromAlexReturn aret = case aret of
    AlexError rest       -> LexRet 0   (Just rest) Nothing
    AlexSkip rest len    -> LexRet len (Just rest) Nothing
    AlexToken rest len f -> LexRet len (Just rest) (Just f)
    _                    -> LexRet 0   Nothing     Nothing

applyTokenAction :: ByteString -> LexerReturn (ByteString -> Token)
                            -> ([Token], (ByteString, Maybe AlexInput))
applyTokenAction x lret =  case lret of
    LexRet _ _ (Just f) -> ([f y], (ys, rest))
    _                   -> ([]   , (ys, rest))
    where
        (y,ys) = B.splitAt (fromIntegral $ tokLen lret) x
        rest   = lexInput lret

scanTokens :: ByteString -> [Token]
scanTokens s = scanTokens' (s, Just ('\n',s))

scanTokens' :: (ByteString, Maybe AlexInput) -> [Token]
scanTokens' (_, Nothing) = []
scanTokens' (s, Just inp) =
    let (xs, (s', inp')) = (applyTokenAction s)
                                . fromAlexReturn
                                    $ alexScan inp 0
    in   xs ++ (scanTokens' (s', inp'))

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

-- the code in this section if old and nasty and
-- needs to be cleaned up/replaced

safeTail :: ByteString -> ByteString
safeTail bs = if bs==B.empty then B.empty else B.tail bs

isFloatChar :: Char -> Bool
isFloatChar c = foldr1 (||) $ fmap ($ c) [isDigit, (=='.')]

itod :: Integer -> Double
itod n = encodeFloat n 0

-- | Exception on error (error called by atoiBS)
readDoubleBS :: ByteString -> [(Double, ByteString)]
readDoubleBS s = [(z,y)]
    where
        (x0,y) = B.span isFloatChar s
        (xa,x0') = B.break (=='.') x0
        xb = B.takeWhile isDigit (safeTail x0')
        f = itod . toInteger . atoiBS
        za = if xa==B.empty then 0 else f xa
        zb = if xb==B.empty then 0 else (f xb)
                / (10 ** (itod . toInteger . B.length) xb)
        z = (za + zb)

atodBS :: ByteString -> Double
atodBS s
    | s==B.empty = 0
    | otherwise = case B.head s of
        '-' -> -1 * atodBS' (safeTail s)
        '+' -> atodBS' (safeTail s)
        _   -> atodBS' s
    where
        atodBS' :: ByteString -> Double
        atodBS' s = let r = readDoubleBS s in
            case r of
                [] -> 0
                _  -> a * 10 ** (atodBS . safeTail $ b)
                    where (a,b) = head r

-- | Exception on error
atoiBS :: ByteString -> Int
atoiBS = fst . fromJust . B.readInt

-----------------------------------------------------------------------------
}