{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE BangPatterns, EmptyDataDecls, FlexibleInstances, MagicHash, UnboxedTuples #-}
module Data.Name
  ( Name
  --
  , toChars
  , toElmString
  , toBuilder
  --
  , fromPtr
  , fromChars
  --
  , getKernel
  , hasDot
  , splitDots
  , isKernel
  , isNumberType
  , isComparableType
  , isAppendableType
  , isCompappendType
  , fromVarIndex
  , fromWords
  , fromManyNames
  , fromTypeVariable
  , fromTypeVariableScheme
  , sepBy
  --
  , int, float, bool, char, string
  , maybe, result, list, array, dict, tuple, jsArray
  , task, router, cmd, sub, platform, virtualDom
  , shader, debug, debugger, bitwise, basics
  , utils, negate, true, false, value
  , node, program, _main, _Main, dollar, identity
  , replModule, replValueToPrint
  )
  where


import Prelude hiding (length, maybe, negate)
import Control.Exception (assert)
import qualified Data.Binary as Binary
import qualified Data.ByteString.Builder.Internal as B
import qualified Data.Coerce as Coerce
import qualified Data.List as List
import qualified Data.String as Chars
import qualified Data.Utf8 as Utf8
import GHC.Exts
  ( Int(I#), Ptr
  , MutableByteArray#
  , isTrue#
  , newByteArray#
  , sizeofByteArray#
  , unsafeFreezeByteArray#
  )
import GHC.ST (ST(ST), runST)
import GHC.Prim
import GHC.Word (Word8(W8#))

import qualified Elm.String as ES



-- NAME


type Name =
  Utf8.Utf8 ELM_NAME


data ELM_NAME



-- INSTANCES


instance Chars.IsString (Utf8.Utf8 ELM_NAME) where
  fromString = Utf8.fromChars

instance Binary.Binary (Utf8.Utf8 ELM_NAME) where
  get = Utf8.getUnder256
  put = Utf8.putUnder256



-- TO


toChars :: Name -> [Char]
toChars =
  Utf8.toChars


toElmString :: Name -> ES.String
toElmString =
  Coerce.coerce


{-# INLINE toBuilder #-}
toBuilder :: Name -> B.Builder
toBuilder =
  Utf8.toBuilder



-- FROM


fromPtr :: Ptr Word8 -> Ptr Word8 -> Name
fromPtr =
  Utf8.fromPtr


fromChars :: [Char] -> Name
fromChars =
  Utf8.fromChars



-- HAS DOT


hasDot :: Name -> Bool
hasDot name =
  Utf8.contains 0x2E {- . -} name


splitDots :: Name -> [Name]
splitDots name =
  Utf8.split 0x2E {- . -} name



-- GET KERNEL


getKernel :: Name -> Name
getKernel name@(Utf8.Utf8 ba#) =
  assert (isKernel name)
  (
    runST
    (
      let
        !size# = sizeofByteArray# ba# -# 11#
      in
      ST $ \s ->
        case newByteArray# size# s of
          (# s, mba# #) ->
            case copyByteArray# ba# 11# mba# 0# size# s of
              s ->
                case unsafeFreezeByteArray# mba# s of
                  (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
    )
  )



-- STARTS WITH


isKernel :: Name -> Bool
isKernel = Utf8.startsWith prefix_kernel

isNumberType :: Name -> Bool
isNumberType = Utf8.startsWith prefix_number

isComparableType :: Name -> Bool
isComparableType = Utf8.startsWith prefix_comparable

isAppendableType :: Name -> Bool
isAppendableType = Utf8.startsWith prefix_appendable

isCompappendType :: Name -> Bool
isCompappendType = Utf8.startsWith prefix_compappend

{-# NOINLINE prefix_kernel #-}
prefix_kernel :: Name
prefix_kernel = fromChars "Elm.Kernel."

{-# NOINLINE prefix_number #-}
prefix_number :: Name
prefix_number = fromChars "number"

{-# NOINLINE prefix_comparable #-}
prefix_comparable :: Name
prefix_comparable = fromChars "comparable"

{-# NOINLINE prefix_appendable #-}
prefix_appendable :: Name
prefix_appendable = fromChars "appendable"

{-# NOINLINE prefix_compappend #-}
prefix_compappend :: Name
prefix_compappend = fromChars "compappend"



-- FROM VAR INDEX


fromVarIndex :: Int -> Name
fromVarIndex n =
  runST
  (
    do  let !size = getIndexSize n
        mba <- newByteArray size
        writeWord8 mba 0 0x5F {- _ -}
        writeWord8 mba 1 0x76 {- v -}
        writeDigits mba (size - 1) n
        freeze mba
  )


{-# INLINE getIndexSize #-}
getIndexSize :: Int -> Int
getIndexSize n
  | n < 10  = 3
  | n < 100 = 4
  | True    = 2 + ceiling (logBase 10 (fromIntegral n + 1) :: Float)



writeDigits :: MBA s -> Int -> Int -> ST s ()
writeDigits !mba !offset !n =
  do  let (q,r) = quotRem n 10
      writeWord8 mba offset (0x30 + fromIntegral r)
      if q <= 0
        then return ()
        else writeDigits mba (offset-1) q



-- FROM TYPE VARIABLE


fromTypeVariable :: Name -> Int -> Name
fromTypeVariable name@(Utf8.Utf8 ba#) index =
  if index <= 0 then
    name
  else
    let
      len# = sizeofByteArray# ba#
      end# = indexWord8Array# ba# (len# -# 1#)
    in
    if isTrue# (leWord# 0x30## end#) && isTrue# (leWord# end# 0x39##) then
      runST
      (
        do  let !size = I# len# + 1 + getIndexSize index
            mba <- newByteArray size
            copyToMBA name mba
            writeWord8 mba (I# len#) 0x5F {- _ -}
            writeDigits mba (size - 1) index
            freeze mba
      )
    else
      runST
      (
        do  let !size = I# len# + getIndexSize index
            mba <- newByteArray size
            copyToMBA name mba
            writeDigits mba (size - 1) index
            freeze mba
      )



-- FROM TYPE VARIABLE SCHEME


fromTypeVariableScheme :: Int -> Name
fromTypeVariableScheme scheme =
  runST
  (
    if scheme < 26 then
      do  mba <- newByteArray 1
          writeWord8 mba 0 (0x61 + fromIntegral scheme)
          freeze mba
    else
      do  let (extra, letter) = quotRem scheme 26
          let !size = getIndexSize extra
          mba <- newByteArray size
          writeWord8 mba 0 (0x61 + fromIntegral letter)
          writeDigits mba (size - 1) extra
          freeze mba
  )



-- FROM MANY NAMES


fromManyNames :: [Name] -> Name
fromManyNames names =
  let
    !(I# size#) = sum (map (\(Utf8.Utf8 ba#) -> I# (sizeofByteArray# ba# +# 1#)) names)
  in
  runST
  (
    ST $ \s ->
      case newByteArray# size# s of
        (# s, mba# #) ->
          case writeNames mba# 0# names s of
            s ->
              case unsafeFreezeByteArray# mba# s of
                (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
  )


writeNames :: MutableByteArray# s -> Int# -> [Name] -> State# s -> State# s
writeNames mba# !offset# names s =
  case names of
    [] ->
      s

    (Utf8.Utf8 ba#) : names ->
      case writeWord8Array# mba# offset# 0x24## {- $ -} s of
        s ->
          let
            !offset1# = offset# +# 1#
            !len# = sizeofByteArray# ba#
            !newOffset# = offset1# +# len#
          in
          case copyByteArray# ba# 0# mba# offset1# len# s of
            s ->
              writeNames mba# newOffset# names s



-- FROM WORDS


fromWords :: [Word8] -> Name
fromWords words =
  runST
  (
    do  mba <- newByteArray (List.length words)
        writeWords mba 0 words
        freeze mba
  )


writeWords :: MBA s -> Int -> [Word8] -> ST s ()
writeWords !mba !i words =
  case words of
    [] ->
      return ()

    w:ws ->
      do  writeWord8 mba i w
          writeWords mba (i+1) ws



-- SEP BY


sepBy :: Word8 -> Name -> Name -> Name
sepBy (W8# sep#) (Utf8.Utf8 ba1#) (Utf8.Utf8 ba2#) =
  let
    !len1# = sizeofByteArray# ba1#
    !len2# = sizeofByteArray# ba2#
  in
  runST
  (
    ST $ \s ->
      case newByteArray# (len1# +# len2# +# 1#) s of
        (# s, mba# #) ->
          case copyByteArray# ba1# 0# mba# 0# len1# s of
            s ->
              case writeWord8Array# mba# len1# sep# s of
                s ->
                  case copyByteArray# ba2# 0# mba# (len1# +# 1#) len2# s of
                    s ->
                      case unsafeFreezeByteArray# mba# s of
                        (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)
  )



-- PRIMITIVES


data MBA s =
  MBA# (MutableByteArray# s)


{-# INLINE newByteArray #-}
newByteArray :: Int -> ST s (MBA s)
newByteArray (I# len#) =
  ST $ \s ->
    case newByteArray# len# s of
      (# s, mba# #) -> (# s, MBA# mba# #)


{-# INLINE freeze #-}
freeze :: MBA s -> ST s Name
freeze (MBA# mba#) =
  ST $ \s ->
    case unsafeFreezeByteArray# mba# s of
      (# s, ba# #) -> (# s, Utf8.Utf8 ba# #)


{-# INLINE writeWord8 #-}
writeWord8 :: MBA s -> Int -> Word8 -> ST s ()
writeWord8 (MBA# mba#) (I# offset#) (W8# w#) =
  ST $ \s ->
    case writeWord8Array# mba# offset# w# s of
      s -> (# s, () #)


{-# INLINE copyToMBA #-}
copyToMBA :: Name -> MBA s -> ST s ()
copyToMBA (Utf8.Utf8 ba#) (MBA# mba#) =
    ST $ \s ->
      case copyByteArray# ba# 0# mba# 0# (sizeofByteArray# ba#) s of
        s -> (# s, () #)



-- COMMON NAMES


{-# NOINLINE int #-}
int :: Name
int = fromChars "Int"


{-# NOINLINE float #-}
float :: Name
float = fromChars "Float"


{-# NOINLINE bool #-}
bool :: Name
bool = fromChars "Bool"


{-# NOINLINE char #-}
char :: Name
char = fromChars "Char"


{-# NOINLINE string #-}
string :: Name
string = fromChars "String"


{-# NOINLINE maybe #-}
maybe :: Name
maybe = fromChars "Maybe"


{-# NOINLINE result #-}
result :: Name
result = fromChars "Result"


{-# NOINLINE list #-}
list :: Name
list = fromChars "List"


{-# NOINLINE array #-}
array :: Name
array = fromChars "Array"


{-# NOINLINE dict #-}
dict :: Name
dict = fromChars "Dict"


{-# NOINLINE tuple #-}
tuple :: Name
tuple = fromChars "Tuple"


{-# NOINLINE jsArray #-}
jsArray :: Name
jsArray = fromChars "JsArray"


{-# NOINLINE task #-}
task :: Name
task = fromChars "Task"


{-# NOINLINE router #-}
router :: Name
router = fromChars "Router"


{-# NOINLINE cmd #-}
cmd :: Name
cmd = fromChars "Cmd"


{-# NOINLINE sub #-}
sub :: Name
sub = fromChars "Sub"


{-# NOINLINE platform #-}
platform :: Name
platform = fromChars "Platform"


{-# NOINLINE virtualDom #-}
virtualDom :: Name
virtualDom = fromChars "VirtualDom"


{-# NOINLINE shader #-}
shader :: Name
shader = fromChars "Shader"


{-# NOINLINE debug #-}
debug :: Name
debug = fromChars "Debug"


{-# NOINLINE debugger #-}
debugger :: Name
debugger = fromChars "Debugger"


{-# NOINLINE bitwise #-}
bitwise :: Name
bitwise = fromChars "Bitwise"


{-# NOINLINE basics #-}
basics :: Name
basics = fromChars "Basics"


{-# NOINLINE utils #-}
utils :: Name
utils = fromChars "Utils"


{-# NOINLINE negate #-}
negate :: Name
negate = fromChars "negate"


{-# NOINLINE true #-}
true :: Name
true = fromChars "True"


{-# NOINLINE false #-}
false :: Name
false = fromChars "False"


{-# NOINLINE value #-}
value :: Name
value = fromChars "Value"


{-# NOINLINE node #-}
node :: Name
node = fromChars "Node"


{-# NOINLINE program #-}
program :: Name
program = fromChars "Program"


{-# NOINLINE _main #-}
_main :: Name
_main = fromChars "main"


{-# NOINLINE _Main #-}
_Main :: Name
_Main = fromChars "Main"


{-# NOINLINE dollar #-}
dollar :: Name
dollar = fromChars "$"


{-# NOINLINE identity #-}
identity :: Name
identity = fromChars "identity"


{-# NOINLINE replModule #-}
replModule :: Name
replModule = fromChars "Elm_Repl"


{-# NOINLINE replValueToPrint #-}
replValueToPrint :: Name
replValueToPrint = fromChars "repl_input_value_"