module Frontend.Lexer.Wrapper where

import Control.Applicative as App (Applicative (..))

import Data.Word (Word8)

import Data.Int (Int64)
import qualified Data.Char
import qualified Data.ByteString.Lazy     as ByteString
import qualified Data.ByteString.Internal as ByteString (w2c)
import Frontend.Lexer.Tokens (Token)
import qualified Data.Text as T
import Frontend.Parser.Posn

type Byte = Word8
type AlexInput = ( Posn,     -- current position,
                   Char,         -- previous char
                   ByteString.ByteString,        -- current input string
                   Int64)           -- bytes consumed so far

ignorePendingBytes :: AlexInput -> AlexInput
ignorePendingBytes i = i   -- no pending bytes when lexing bytestrings

alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (_,c,_,_) = c

alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)
alexGetByte (p,_,cs,n) =
    case ByteString.uncons cs of
        Nothing -> Nothing
        Just (b, cs') ->
            let c   = ByteString.w2c b
                p'  = alexMove p c
                n'  = n+1
            in p' `seq` cs' `seq` n' `seq` Just (b, (p', c, cs',n'))

-- -----------------------------------------------------------------------------
-- Token positions

-- `Posn' records the location of a token in the input text.  It has three
-- fields: the address (number of chacaters preceding the token), line number
-- and column of a token within the file. `start_pos' gives the position of the
-- start of the file and `eof_pos' a standard encoding for the end of file.
-- `move_pos' calculates the new position after traversing a given character,
-- assuming the usual eight character tab stops.


alexStartPos :: Posn
alexStartPos = Posn 1 1

alexMove :: Posn -> Char -> Posn
alexMove (Posn l c) '\t' = Posn l     (c+8-((c-1) `mod` 8))
alexMove (Posn l _) '\n' = Posn (l+1) 1
alexMove (Posn l c) _    = Posn l     (c+1)

data AlexState = AlexState {
        alex_pos :: !Posn,  -- position at current input location

        alex_bpos:: !Int64,     -- bytes consumed so far
        alex_inp :: ByteString.ByteString,      -- the current input
        alex_chr :: !Char,      -- the character before the input

        alex_scd :: !Int        -- the current startcode

      , alex_ust :: AlexUserState -- AlexUserState will be defined in the user program
      , alex_fname :: String
    }

runAlex :: String -> ByteString.ByteString -> Alex a -> Either ParseError a
runAlex fname input__ (Alex f) =
  case f initState of
    Left msg -> Left msg
    Right ( _, a ) -> Right a
  where
    initState = AlexState
      { alex_bpos = 0
      , alex_pos = alexStartPos
      , alex_inp = input__
      , alex_chr = '\n'

      , alex_ust = alexInitUserState

      , alex_scd = 0
      , alex_fname = fname
      }

newtype Alex a = Alex { unAlex :: AlexState -> Either ParseError (AlexState, a) }

instance Functor Alex where
  fmap f a = Alex $ \s -> case unAlex a s of
                            Left msg -> Left msg
                            Right (s', a') -> Right (s', f a')

instance Applicative Alex where
  pure a   = Alex $ \s -> Right (s, a)
  fa <*> a = Alex $ \s -> case unAlex fa s of
                            Left msg -> Left msg
                            Right (s', f) -> case unAlex a s' of
                                               Left msg -> Left msg
                                               Right (s'', b) -> Right (s'', f b)

instance Monad Alex where
  m >>= k  = Alex $ \s -> case unAlex m s of
                                Left msg -> Left msg
                                Right (s',a) -> unAlex (k a) s'
  return = App.pure

alexGetInput :: Alex AlexInput
alexGetInput =
  Alex $ \s@AlexState{alex_pos=pos,alex_bpos=bpos,alex_chr=c,alex_inp=inp__} ->
    Right (s, (pos,c,inp__,bpos))


alexSetInput :: AlexInput -> Alex ()
alexSetInput (pos,c,inp__,bpos)
 = Alex $ \s -> Right ( s { alex_pos  = pos
                          , alex_bpos = bpos
                          , alex_chr  = c
                          , alex_inp  = inp__
                          }
                      , ())

alexError :: String -> Alex a
alexError message = Alex $ \s -> Left (ParseError message (alex_fname s) Nothing (alex_pos s) (alex_pos s))

alexErrorPosn :: Posn -> Posn -> String -> Alex a
alexErrorPosn start end message = Alex $ \s -> Left (ParseError message (alex_fname s) Nothing start end)

alexThrow :: (String -> ParseError) -> Alex a
alexThrow err = Alex $ \s -> Left (err (alex_fname s))

alexGetStartCode :: Alex Int
alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc)

alexSetStartCode :: Int -> Alex ()
alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ())

-- -----------------------------------------------------------------------------
-- Useful token actions

type AlexAction result = AlexInput -> Int64 -> Alex result

-- perform an action for this token, and set the start code to a new value
andBegin :: AlexAction result -> Int -> AlexAction result
(action `andBegin` code) input__ len = do
  alexSetStartCode code
  action input__ len

token :: (AlexInput -> Int64 -> token) -> AlexAction token
token t input__ len = return (t input__ len)

data LayoutState
  = LetLayout      { layoutCol :: Int }
  | Layout         { layoutCol :: Int }
  | ExplicitLayout
  deriving (Show)

data AlexUserState =
  AlexUserState { layoutColumns     :: ![LayoutState]
                , startCodes        :: ![Int]
                , leastColumn       :: !Int

                , pendingLayoutKw   :: Maybe (Int -> LayoutState)
                , pendingTokens     :: ![Token]
                , pendingLambdaCase :: !Bool

                , stringBuffer      :: !T.Text
                , stringStartPosn   :: Maybe Posn
                }

alexInitUserState :: AlexUserState
alexInitUserState = AlexUserState [] [] 0 Nothing [] False T.empty Nothing

data ParseError
  = ParseError { parseErrorMessage    :: String
               , parseErrorFilename   :: String
               , parseErrorInlineDesc :: Maybe String
               , parseErrorBegin      :: Posn
               , parseErrorEnd        :: Posn
               }
  deriving (Eq, Show)