-- UUIDs are terrible, and I couldn't get the `uuid` package to work on Haste
-- So here's something similar that I like more
-- CUAD: Cute, Unique And iDentifying
-- (new backronym thanks to those lovely three Irenes)
-- A quad (see what I did there?) of four 32-bit words
-- Canon text representation is 4 hex words separated by dashes
-- e.g. 01234567-89abcdef-deadbeef-abad1dea
-- Like UUIDv4, these should be random (probabilistically unique)
-- Unlike UUIDv4, these have 2^6x as much randomness (128 bits, not 122)
module CUAD
(   CUAD,
    toString,
    fromString
)   where

import Data.Char (isHexDigit, digitToInt, intToDigit, isSpace)
import Data.List (unfoldr)
import Data.Word (Word32)

data CUAD = CUAD Word32 Word32 Word32 Word32
    deriving (Ord, Eq)

chunksOf :: Int -> [a] -> [[a]]
chunksOf _ [] = []
chunksOf n xs = fxs : chunksOf n sxs
    where (fxs, sxs) = splitAt n xs

-- The string length of a 32-bit hex word
wordLength :: Int
wordLength = 8

-- The string length of a full CUAD
cuadLength :: Int
cuadLength = wordLength * 4 + 3

fromString :: String -> Maybe CUAD
fromString str
    | all isValidWord wordStrings = Just cuad
    | otherwise                   = Nothing
    where
        wordStrings     = chunksOf (wordLength + 1) ('-' : str)
        w1:w2:w3:w4:[]  = map (\('-':word) -> readWord word) wordStrings
        cuad            = CUAD w1 w2 w3 w4

readWord :: String -> Word32
readWord = foldl (\acc digit -> acc * 16 + (fromIntegral $ digitToInt digit)) 0

showWord :: Word32 -> String
showWord num = reverse $ unfoldr f (num, 0)
    where
        f (num, digitCount)
            | num > 0 || digitCount < wordLength  =
                let digit       = intToDigit $ fromIntegral $ num `mod` 16
                    num'        = num `div` 16
                    digitCount' = digitCount + 1
                in  Just (digit, (num', digitCount'))
            | otherwise = Nothing

isValidWord :: String -> Bool
isValidWord ('-':hex)   = all isHexDigit hex && length hex == wordLength
isValidWord _           = False

toString :: CUAD -> String
toString (CUAD w1 w2 w3 w4) = showWord w1 ++ '-' : showWord w2 ++ '-' : showWord w3 ++ '-' : showWord w4

instance Read CUAD where
    readsPrec _ str = case maybeCuad of
            Just cuad   -> [(cuad, rem)]
            Nothing     -> []
        where
            unpaddedStr     = dropWhile isSpace str
            (cuadStr, rem)  = splitAt cuadLength unpaddedStr
            maybeCuad       = fromString cuadStr

instance Show CUAD where
    show = toString