{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, OverloadedStrings #-}
module Parse.Variable
  ( lower
  , upper
  , moduleName
  , Upper(..)
  , foreignUpper
  , foreignAlpha
  , chompInnerChars
  , getInnerWidth
  , getInnerWidthHelp
  )
  where


import qualified Data.Char as Char
import qualified Data.Name as Name
import qualified Data.Set as Set
import Data.Word (Word8, Word16)
import Foreign.Ptr (Ptr, plusPtr)
import GHC.Exts (Char(C#), Int#, (+#), (-#), chr#, uncheckedIShiftL#, word2Int#)
import GHC.Word (Word8(W8#))

import qualified AST.Source as Src
import Parse.Utils (Parser)
import Parse.Primitives (unsafeIndex)
import qualified Parse.Primitives as P
import qualified Reporting.Error.Syntax as E



-- LOCAL UPPER


upper :: Parser Name.Name
upper =
  P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
    let (# newPos, newCol #) = chompUpper pos end col in
    if pos == newPos then
      eerr row col ctx E.Upper
    else
      let !name = Name.fromPtr pos newPos in
      cok name (P.State newPos end indent row newCol ctx)



-- LOCAL LOWER


lower :: Parser Name.Name
lower =
  P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
    let (# newPos, newCol #) = chompLower pos end col in
    if pos == newPos then
      eerr row col ctx E.Lower
    else
      let !name = Name.fromPtr pos newPos in
      if Set.member name reservedWords then
        eerr row col ctx E.Lower
      else
        let
          !newState =
            P.State newPos end indent row newCol ctx
        in
        cok name newState


{-# NOINLINE reservedWords #-}
reservedWords :: Set.Set Name.Name
reservedWords =
  Set.fromList
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    ]



-- MODULE NAME


moduleName :: Parser Name.Name
moduleName =
  P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
    let
      (# pos1, col1 #) = chompUpper pos end col
      (# status, newPos, newCol #) = moduleNameHelp pos1 end col1
    in
    case status of
      Good ->
        let
          !name = Name.fromPtr pos newPos
          !newState = P.State newPos end indent row newCol ctx
        in
        cok name newState

      Bad ->
        eerr row newCol ctx E.ModuleName


data ModuleNameStatus
  = Good
  | Bad


moduleNameHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# ModuleNameStatus, Ptr Word8, Word16 #)
moduleNameHelp pos end col =
  if isDot pos end then
    let
      !pos1 = plusPtr pos 1
      (# newPos, newCol #) = chompUpper pos1 end (col + 1)
    in
    if pos1 == newPos then
      (# Bad, newPos, newCol #)
    else
      moduleNameHelp newPos end newCol

  else
    (# Good, pos, col #)



-- FOREIGN UPPER


data Upper
  = Unqualified Name.Name
  | Qualified Name.Name Name.Name


foreignUpper :: Parser Upper
foreignUpper =
  P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
    let (# upperStart, upperEnd, newCol #) = foreignUpperHelp pos end col in
    if upperStart == upperEnd then
      eerr row newCol ctx E.Upper
    else
      let
        !newState = P.State upperEnd end indent row newCol ctx
        !name = Name.fromPtr upperStart upperEnd
        !foreign =
          if upperStart == pos then
            Unqualified name
          else
            let !home = Name.fromPtr pos (plusPtr upperStart (-1)) in
            Qualified home name
      in
      cok foreign newState


foreignUpperHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Ptr Word8, Ptr Word8, Word16 #)
foreignUpperHelp pos end col =
  let
    (# newPos, newCol #) = chompUpper pos end col
  in
  if pos == newPos then
    (# pos, pos, col #)

  else if isDot newPos end then
    foreignUpperHelp (plusPtr newPos 1) end (newCol + 1)

  else
    (# pos, newPos, newCol #)



-- FOREIGN ALPHA


foreignAlpha :: Parser Src.Expr_
foreignAlpha =
  P.Parser $ \(P.State pos end indent row col ctx) cok _ _ eerr ->
    let (# alphaStart, alphaEnd, newCol, varType #) = foreignAlphaHelp pos end col in
    if alphaStart == alphaEnd then
      eerr row newCol ctx E.Alpha
    else
      let
        !newState = P.State alphaEnd end indent row newCol ctx
        !name = Name.fromPtr alphaStart alphaEnd
      in
      if alphaStart == pos then
        if Set.member name reservedWords then
          eerr row col ctx E.Alpha
        else
          cok (Src.Var varType name) newState
      else
        let !home = Name.fromPtr pos (plusPtr alphaStart (-1)) in
        cok (Src.VarQual varType home name) newState


foreignAlphaHelp :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Ptr Word8, Ptr Word8, Word16, Src.VarType #)
foreignAlphaHelp pos end col =
  let
    (# lowerPos, lowerCol #) = chompLower pos end col
  in
  if pos < lowerPos then
    (# pos, lowerPos, lowerCol, Src.LowVar #)

  else
    let
      (# upperPos, upperCol #) = chompUpper pos end col
    in
    if pos == upperPos then
      (# pos, pos, col, Src.CapVar #)

    else if isDot upperPos end then
      foreignAlphaHelp (plusPtr upperPos 1) end (upperCol + 1)

    else
      (# pos, upperPos, upperCol, Src.CapVar #)



---- CHAR CHOMPERS ----



-- DOTS


{-# INLINE isDot #-}
isDot :: Ptr Word8 -> Ptr Word8 -> Bool
isDot pos end =
  pos < end && unsafeIndex pos == 0x2e {- . -}



-- UPPER CHARS


chompUpper :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Ptr Word8, Word16 #)
chompUpper pos end col =
  let !width = getUpperWidth pos end in
  if width == 0 then
    (# pos, col #)
  else
    chompInnerChars (plusPtr pos width) end (col + 1)


{-# INLINE getUpperWidth #-}
getUpperWidth :: Ptr Word8 -> Ptr Word8 -> Int
getUpperWidth pos end =
  if pos < end then
    getUpperWidthHelp pos end (unsafeIndex pos)
  else
    0


{-# INLINE getUpperWidthHelp #-}
getUpperWidthHelp :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
getUpperWidthHelp pos _ word
  | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1
  | word < 0xc0 = 0
  | word < 0xe0 = if Char.isUpper (chr2 pos word) then 2 else 0
  | word < 0xf0 = if Char.isUpper (chr3 pos word) then 3 else 0
  | word < 0xf8 = if Char.isUpper (chr4 pos word) then 4 else 0
  | True        = 0



-- LOWER CHARS


chompLower :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Ptr Word8, Word16 #)
chompLower pos end col =
  let !width = getLowerWidth pos end in
  if width == 0 then
    (# pos, col #)
  else
    chompInnerChars (plusPtr pos width) end (col + 1)


{-# INLINE getLowerWidth #-}
getLowerWidth :: Ptr Word8 -> Ptr Word8 -> Int
getLowerWidth pos end =
  if pos < end then
    getLowerWidthHelp pos end (unsafeIndex pos)
  else
    0


{-# INLINE getLowerWidthHelp #-}
getLowerWidthHelp :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
getLowerWidthHelp pos _ word
  | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1
  | word < 0xc0 = 0
  | word < 0xe0 = if Char.isLower (chr2 pos word) then 2 else 0
  | word < 0xf0 = if Char.isLower (chr3 pos word) then 3 else 0
  | word < 0xf8 = if Char.isLower (chr4 pos word) then 4 else 0
  | True        = 0



-- INNER CHARS


chompInnerChars :: Ptr Word8 -> Ptr Word8 -> Word16 -> (# Ptr Word8, Word16 #)
chompInnerChars !pos end !col =
  let !width = getInnerWidth pos end in
  if width == 0 then
    (# pos, col #)
  else
    chompInnerChars (plusPtr pos width) end (col + 1)


getInnerWidth :: Ptr Word8 -> Ptr Word8 -> Int
getInnerWidth pos end =
  if pos < end then
    getInnerWidthHelp pos end (unsafeIndex pos)
  else
    0


{-# INLINE getInnerWidthHelp #-}
getInnerWidthHelp :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int
getInnerWidthHelp pos _ word
  | 0x61 {- a -} <= word && word <= 0x7A {- z -} = 1
  | 0x41 {- A -} <= word && word <= 0x5A {- Z -} = 1
  | 0x30 {- 0 -} <= word && word <= 0x39 {- 9 -} = 1
  | word == 0x5F {- _ -} = 1
  | word < 0xc0 = 0
  | word < 0xe0 = if Char.isAlpha (chr2 pos word) then 2 else 0
  | word < 0xf0 = if Char.isAlpha (chr3 pos word) then 3 else 0
  | word < 0xf8 = if Char.isAlpha (chr4 pos word) then 4 else 0
  | True        = 0



-- EXTRACT CHARACTERS


{-# INLINE chr2 #-}
chr2 :: Ptr Word8 -> Word8 -> Char
chr2 pos firstWord =
  let
    !i1# = unpack firstWord
    !i2# = unpack (unsafeIndex (plusPtr pos 1))
    !c1# = uncheckedIShiftL# (i1# -# 0xC0#) 6#
    !c2# = i2# -# 0x80#
  in
  C# (chr# (c1# +# c2#))


{-# INLINE chr3 #-}
chr3 :: Ptr Word8 -> Word8 -> Char
chr3 pos firstWord =
  let
    !i1# = unpack firstWord
    !i2# = unpack (unsafeIndex (plusPtr pos 1))
    !i3# = unpack (unsafeIndex (plusPtr pos 2))
    !c1# = uncheckedIShiftL# (i1# -# 0xE0#) 12#
    !c2# = uncheckedIShiftL# (i2# -# 0x80#) 6#
    !c3# = i3# -# 0x80#
  in
  C# (chr# (c1# +# c2# +# c3#))


{-# INLINE chr4 #-}
chr4 :: Ptr Word8 -> Word8 -> Char
chr4 pos firstWord =
  let
    !i1# = unpack firstWord
    !i2# = unpack (unsafeIndex (plusPtr pos 1))
    !i3# = unpack (unsafeIndex (plusPtr pos 2))
    !i4# = unpack (unsafeIndex (plusPtr pos 3))
    !c1# = uncheckedIShiftL# (i1# -# 0xF0#) 18#
    !c2# = uncheckedIShiftL# (i2# -# 0x80#) 12#
    !c3# = uncheckedIShiftL# (i3# -# 0x80#) 6#
    !c4# = i4# -# 0x80#
  in
  C# (chr# (c1# +# c2# +# c3# +# c4#))


unpack :: Word8 -> Int#
unpack (W8# word#) =
  word2Int# word#