{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StrictData #-}

-- | Widget ids and the id context they are derived from. See the
-- "Widget identity" section of "NanoUI" for how ids are assigned.
module NanoUI.Id
  ( WidgetId (..)
  , IdContext (..)
  , initialIdContext
  , idContextWidgetId
  , widgetId
  , hashWidgetId
  , fnv1a
  , mix64
  , mixFnv
  , scopeTag
  , enterScope
  , enterKeyed
  )
where

import Data.Bits (shiftR, xor)
import Data.Char (ord)
import Data.Hashable (Hashable)
import Data.Primitive.Types (Prim)
import Data.Word (Word64, Word8)
import GHC.Stack (HasCallStack, SrcLoc (..), callStack, getCallStack)

newtype WidgetId = WidgetId Word64
  deriving stock (WidgetId -> WidgetId -> Bool
(WidgetId -> WidgetId -> Bool)
-> (WidgetId -> WidgetId -> Bool) -> Eq WidgetId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WidgetId -> WidgetId -> Bool
== :: WidgetId -> WidgetId -> Bool
$c/= :: WidgetId -> WidgetId -> Bool
/= :: WidgetId -> WidgetId -> Bool
Eq, Eq WidgetId
Eq WidgetId =>
(WidgetId -> WidgetId -> Ordering)
-> (WidgetId -> WidgetId -> Bool)
-> (WidgetId -> WidgetId -> Bool)
-> (WidgetId -> WidgetId -> Bool)
-> (WidgetId -> WidgetId -> Bool)
-> (WidgetId -> WidgetId -> WidgetId)
-> (WidgetId -> WidgetId -> WidgetId)
-> Ord WidgetId
WidgetId -> WidgetId -> Bool
WidgetId -> WidgetId -> Ordering
WidgetId -> WidgetId -> WidgetId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: WidgetId -> WidgetId -> Ordering
compare :: WidgetId -> WidgetId -> Ordering
$c< :: WidgetId -> WidgetId -> Bool
< :: WidgetId -> WidgetId -> Bool
$c<= :: WidgetId -> WidgetId -> Bool
<= :: WidgetId -> WidgetId -> Bool
$c> :: WidgetId -> WidgetId -> Bool
> :: WidgetId -> WidgetId -> Bool
$c>= :: WidgetId -> WidgetId -> Bool
>= :: WidgetId -> WidgetId -> Bool
$cmax :: WidgetId -> WidgetId -> WidgetId
max :: WidgetId -> WidgetId -> WidgetId
$cmin :: WidgetId -> WidgetId -> WidgetId
min :: WidgetId -> WidgetId -> WidgetId
Ord, Int -> WidgetId -> ShowS
[WidgetId] -> ShowS
WidgetId -> String
(Int -> WidgetId -> ShowS)
-> (WidgetId -> String) -> ([WidgetId] -> ShowS) -> Show WidgetId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WidgetId -> ShowS
showsPrec :: Int -> WidgetId -> ShowS
$cshow :: WidgetId -> String
show :: WidgetId -> String
$cshowList :: [WidgetId] -> ShowS
showList :: [WidgetId] -> ShowS
Show)
  deriving newtype (Eq WidgetId
Eq WidgetId =>
(Int -> WidgetId -> Int) -> (WidgetId -> Int) -> Hashable WidgetId
Int -> WidgetId -> Int
WidgetId -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> WidgetId -> Int
hashWithSalt :: Int -> WidgetId -> Int
$chash :: WidgetId -> Int
hash :: WidgetId -> Int
Hashable, Addr# -> Int# -> WidgetId
ByteArray# -> Int# -> WidgetId
Proxy WidgetId -> Int#
WidgetId -> Int#
(Proxy WidgetId -> Int#)
-> (WidgetId -> Int#)
-> (Proxy WidgetId -> Int#)
-> (WidgetId -> Int#)
-> (ByteArray# -> Int# -> WidgetId)
-> (forall s.
    MutableByteArray# s
    -> Int# -> State# s -> (# State# s, WidgetId #))
-> (forall s.
    MutableByteArray# s -> Int# -> WidgetId -> State# s -> State# s)
-> (forall s.
    MutableByteArray# s
    -> Int# -> Int# -> WidgetId -> State# s -> State# s)
-> (Addr# -> Int# -> WidgetId)
-> (forall s.
    Addr# -> Int# -> State# s -> (# State# s, WidgetId #))
-> (forall s. Addr# -> Int# -> WidgetId -> State# s -> State# s)
-> (forall s.
    Addr# -> Int# -> Int# -> WidgetId -> State# s -> State# s)
-> Prim WidgetId
forall s. Addr# -> Int# -> Int# -> WidgetId -> State# s -> State# s
forall s. Addr# -> Int# -> State# s -> (# State# s, WidgetId #)
forall s. Addr# -> Int# -> WidgetId -> State# s -> State# s
forall s.
MutableByteArray# s
-> Int# -> Int# -> WidgetId -> State# s -> State# s
forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, WidgetId #)
forall s.
MutableByteArray# s -> Int# -> WidgetId -> State# s -> State# s
forall a.
(Proxy a -> Int#)
-> (a -> Int#)
-> (Proxy a -> Int#)
-> (a -> Int#)
-> (ByteArray# -> Int# -> a)
-> (forall s.
    MutableByteArray# s -> Int# -> State# s -> (# State# s, a #))
-> (forall s.
    MutableByteArray# s -> Int# -> a -> State# s -> State# s)
-> (forall s.
    MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s)
-> (Addr# -> Int# -> a)
-> (forall s. Addr# -> Int# -> State# s -> (# State# s, a #))
-> (forall s. Addr# -> Int# -> a -> State# s -> State# s)
-> (forall s. Addr# -> Int# -> Int# -> a -> State# s -> State# s)
-> Prim a
$csizeOfType# :: Proxy WidgetId -> Int#
sizeOfType# :: Proxy WidgetId -> Int#
$csizeOf# :: WidgetId -> Int#
sizeOf# :: WidgetId -> Int#
$calignmentOfType# :: Proxy WidgetId -> Int#
alignmentOfType# :: Proxy WidgetId -> Int#
$calignment# :: WidgetId -> Int#
alignment# :: WidgetId -> Int#
$cindexByteArray# :: ByteArray# -> Int# -> WidgetId
indexByteArray# :: ByteArray# -> Int# -> WidgetId
$creadByteArray# :: forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, WidgetId #)
readByteArray# :: forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, WidgetId #)
$cwriteByteArray# :: forall s.
MutableByteArray# s -> Int# -> WidgetId -> State# s -> State# s
writeByteArray# :: forall s.
MutableByteArray# s -> Int# -> WidgetId -> State# s -> State# s
$csetByteArray# :: forall s.
MutableByteArray# s
-> Int# -> Int# -> WidgetId -> State# s -> State# s
setByteArray# :: forall s.
MutableByteArray# s
-> Int# -> Int# -> WidgetId -> State# s -> State# s
$cindexOffAddr# :: Addr# -> Int# -> WidgetId
indexOffAddr# :: Addr# -> Int# -> WidgetId
$creadOffAddr# :: forall s. Addr# -> Int# -> State# s -> (# State# s, WidgetId #)
readOffAddr# :: forall s. Addr# -> Int# -> State# s -> (# State# s, WidgetId #)
$cwriteOffAddr# :: forall s. Addr# -> Int# -> WidgetId -> State# s -> State# s
writeOffAddr# :: forall s. Addr# -> Int# -> WidgetId -> State# s -> State# s
$csetOffAddr# :: forall s. Addr# -> Int# -> Int# -> WidgetId -> State# s -> State# s
setOffAddr# :: forall s. Addr# -> Int# -> Int# -> WidgetId -> State# s -> State# s
Prim)

data IdContext = IdContext
  { IdContext -> Word64
currentId :: {-# UNPACK #-} !Word64
  , IdContext -> Word64
siblingId :: {-# UNPACK #-} !Word64
  }
  deriving stock (IdContext -> IdContext -> Bool
(IdContext -> IdContext -> Bool)
-> (IdContext -> IdContext -> Bool) -> Eq IdContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IdContext -> IdContext -> Bool
== :: IdContext -> IdContext -> Bool
$c/= :: IdContext -> IdContext -> Bool
/= :: IdContext -> IdContext -> Bool
Eq, Int -> IdContext -> ShowS
[IdContext] -> ShowS
IdContext -> String
(Int -> IdContext -> ShowS)
-> (IdContext -> String)
-> ([IdContext] -> ShowS)
-> Show IdContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IdContext -> ShowS
showsPrec :: Int -> IdContext -> ShowS
$cshow :: IdContext -> String
show :: IdContext -> String
$cshowList :: [IdContext] -> ShowS
showList :: [IdContext] -> ShowS
Show)

initialIdContext :: IdContext
initialIdContext :: IdContext
initialIdContext = Word64 -> Word64 -> IdContext
IdContext Word64
0x243F6A8885A308D3 Word64
0

-- | Id of the next sibling in this context. A zero hash becomes 1, so
-- @WidgetId 0@ never names a real widget.
{-# INLINE idContextWidgetId #-}
idContextWidgetId :: IdContext -> WidgetId
idContextWidgetId :: IdContext -> WidgetId
idContextWidgetId (IdContext Word64
cid Word64
sid) =
  let
    raw :: Word64
raw = Word64 -> Word64 -> Word64
mix64 Word64
cid Word64
sid
   in
    if Word64
raw Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 then Word64 -> WidgetId
WidgetId Word64
1 else Word64 -> WidgetId
WidgetId Word64
raw

scopeTag :: Word64
scopeTag :: Word64
scopeTag = Word64
0x9E3779B185EBCA87

keyedTag :: Word64
keyedTag :: Word64
keyedTag = Word64
0xC2B2AE3D27D4EB4F

{-# INLINE enterScope #-}
enterScope :: Word64 -> IdContext -> (IdContext, IdContext)
enterScope :: Word64 -> IdContext -> (IdContext, IdContext)
enterScope Word64
tag IdContext
parent =
  let
    IdContext Word64
pid Word64
sib = IdContext
parent
    child :: IdContext
child = Word64 -> Word64 -> IdContext
IdContext (Word64 -> Word64 -> Word64
mix64 (Word64 -> Word64 -> Word64
mix64 Word64
pid Word64
sib) Word64
tag) Word64
0
    parent' :: IdContext
parent' = IdContext
parent {siblingId = sib + 1}
   in
    (IdContext
parent', IdContext
child)

{-# INLINE enterKeyed #-}
enterKeyed :: Word64 -> IdContext -> (IdContext, IdContext)
enterKeyed :: Word64 -> IdContext -> (IdContext, IdContext)
enterKeyed Word64
tag IdContext
parent =
  let
    IdContext Word64
pid Word64
sid = IdContext
parent
    child :: IdContext
child = Word64 -> Word64 -> IdContext
IdContext (Word64 -> Word64 -> Word64
mix64 (Word64 -> Word64 -> Word64
mix64 Word64
pid Word64
tag) Word64
keyedTag) Word64
0
    parent' :: IdContext
parent' = IdContext
parent {siblingId = sid + 1}
   in
    (IdContext
parent', IdContext
child)

{-# INLINE widgetId #-}
widgetId :: HasCallStack => WidgetId
widgetId :: HasCallStack => WidgetId
widgetId =
  let
    stack :: [(String, SrcLoc)]
stack = CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack
    loc :: SrcLoc
loc = case [(String, SrcLoc)]
stack of
      (String
_, SrcLoc
loc') : [(String, SrcLoc)]
_ -> SrcLoc
loc'
      [] -> String -> SrcLoc
forall a. HasCallStack => String -> a
error String
"widgetId: empty CallStack"
   in
    SrcLoc -> WidgetId
hashSrcLoc SrcLoc
loc

hashSrcLoc :: SrcLoc -> WidgetId
hashSrcLoc :: SrcLoc -> WidgetId
hashSrcLoc
  ( SrcLoc
      { String
srcLocPackage :: String
srcLocPackage :: SrcLoc -> String
srcLocPackage
      , String
srcLocModule :: String
srcLocModule :: SrcLoc -> String
srcLocModule
      , String
srcLocFile :: String
srcLocFile :: SrcLoc -> String
srcLocFile
      , Int
srcLocStartLine :: Int
srcLocStartLine :: SrcLoc -> Int
srcLocStartLine
      , Int
srcLocStartCol :: Int
srcLocStartCol :: SrcLoc -> Int
srcLocStartCol
      }
    ) =
    Word64 -> WidgetId
WidgetId (Word64 -> WidgetId) -> Word64 -> WidgetId
forall a b. (a -> b) -> a -> b
$
      String -> Word64
fnv1a String
srcLocPackage
        Word64 -> Word64 -> Word64
`mixFnv` String -> Word64
fnv1a String
srcLocModule
        Word64 -> Word64 -> Word64
`mixFnv` String -> Word64
fnv1a String
srcLocFile
        Word64 -> Word64 -> Word64
`mixFnv` Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
srcLocStartLine
        Word64 -> Word64 -> Word64
`mixFnv` Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
srcLocStartCol

{-# INLINE hashWidgetId #-}
hashWidgetId :: WidgetId -> Word64
hashWidgetId :: WidgetId -> Word64
hashWidgetId (WidgetId Word64
w) = Word64
w

{-# INLINE fnv1a #-}
fnv1a :: String -> Word64
fnv1a :: String -> Word64
fnv1a String
s =
  (Word64 -> Char -> Word64) -> Word64 -> String -> Word64
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
    (\Word64
acc Char
c -> (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word64 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c)) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
acc) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
0x00000100000001B3)
    Word64
0xcbf29ce484222325
    String
s

{-# INLINE mix64 #-}
mix64 :: Word64 -> Word64 -> Word64
mix64 :: Word64 -> Word64 -> Word64
mix64 Word64
x Word64
y =
  let
    z :: Word64
z = Word64
x Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ (Word64
y Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
0x9E3779B97F4A7C15)
    z1 :: Word64
z1 = Word64
z Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
z Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
30)
    z2 :: Word64
z2 = Word64
z1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
0xBF58476D1CE4E5B9
    z3 :: Word64
z3 = Word64
z2 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` (Word64
z2 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
27)
   in
    Word64
z3 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
0x94D049BB133111EB

{-# INLINE mixFnv #-}
mixFnv :: Word64 -> Word64 -> Word64
mixFnv :: Word64 -> Word64 -> Word64
mixFnv Word64
x Word64
y = (Word64
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
y) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
1099511628211