{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}

module Graphics.HaGL.ExprID (
    ExprID,
    genID,
    combineIDs,
    idLabel,
    HasExprID(..)
) where

import Prelude hiding (id)
import Data.Word (Word64)
import Data.Bits (shiftL, (.|.))
import Data.IORef
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BB
import qualified Crypto.Hash.MD5 as MD5

type ExprID = Word64

-- TODO: consider a hash consing approach which
-- would free us from shaky unsafePerformIO foundations,
-- at the expense of having ugly, long IDs in shader code

{-# NOINLINE unsafeCounter #-}
unsafeCounter :: IORef ExprID
unsafeCounter :: IORef ExprID
unsafeCounter = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef ExprID
0

-- All modules using this function should be 
-- compiled with -fno-full-laziness!!
{-# NOINLINE genID #-}
genID :: a -> ExprID
genID :: forall a. a -> ExprID
genID a
_ = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    ExprID
id <- forall a. IORef a -> IO a
readIORef IORef ExprID
unsafeCounter
    forall a. IORef a -> a -> IO ()
writeIORef IORef ExprID
unsafeCounter (ExprID
id forall a. Num a => a -> a -> a
+ ExprID
1)
    forall (m :: * -> *) a. Monad m => a -> m a
return ExprID
id

-- TODO: try to remove dependency on md5 and probabilistic assumptions
combineIDs :: [ExprID] -> ExprID
combineIDs :: [ExprID] -> ExprID
combineIDs = [ExprID] -> ExprID
fromBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. 
    ByteString -> ByteString
MD5.hashlazy forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ExprID -> Builder
BB.word64BE where
        fromBytes :: [ExprID] -> ExprID
fromBytes = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ExprID
x (ExprID
s, Int
i) -> (ExprID
s forall a. Bits a => a -> a -> a
.|. forall a. Bits a => a -> Int -> a
shiftL ExprID
x Int
i, Int
i forall a. Num a => a -> a -> a
+ Int
8)) (ExprID
0, Int
0)

idLabel :: ExprID -> String
idLabel :: ExprID -> String
idLabel ExprID
id | ExprID
id forall a. Ord a => a -> a -> Bool
>= ExprID
0 = String
"x" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ExprID
id
           | Bool
otherwise = String
"y" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Num a => a -> a
negate ExprID
id)

class HasExprID a where
    getID :: a -> ExprID