module Frontend.Lexer.Wrapper where

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

import qualified Data.ByteString.Internal as ByteString (w2c)
import qualified Data.ByteString.Lazy     as ByteString
import qualified Data.Text as T
import qualified Data.Char
import Data.Word (Word8)
import Data.Int (Int64)

import Errors

import Frontend.Lexer.Tokens (Token)
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 AhcError 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 AhcError (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 (AhcError message (alex_fname s) Nothing (alex_pos s) (alex_pos s) [])

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

alexThrow :: (String -> AhcError) -> 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

                , lastToken         :: Maybe Token
                }

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