2019-08-24 23:04:37 +02:00
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
2019-11-20 18:22:27 +01:00
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2019-08-24 23:04:37 +02:00
|
|
|
module Hanafuda.ID (
|
2019-11-20 18:22:27 +01:00
|
|
|
ID(..)
|
|
|
|
, IDType(..)
|
|
|
|
, Prefix(..)
|
2019-08-24 23:04:37 +02:00
|
|
|
) where
|
|
|
|
|
2019-11-20 18:22:27 +01:00
|
|
|
import Data.Char (isDigit)
|
2019-11-12 22:15:39 +01:00
|
|
|
import System.Random (Random(..))
|
2019-11-20 18:22:27 +01:00
|
|
|
import Text.ParserCombinators.ReadP (char, munch, string)
|
|
|
|
import Text.ParserCombinators.ReadPrec (lift)
|
|
|
|
import Text.Read (readPrec)
|
2019-08-24 23:04:37 +02:00
|
|
|
|
2019-11-12 22:15:39 +01:00
|
|
|
newtype ID a = ID {
|
|
|
|
getID :: Int
|
2019-11-20 18:22:27 +01:00
|
|
|
} deriving (Eq, Ord)
|
|
|
|
|
|
|
|
newtype Prefix a = Prefix String
|
|
|
|
|
|
|
|
class IDType a where
|
|
|
|
prefix :: Prefix a
|
|
|
|
|
|
|
|
instance IDType a => Show (ID a) where
|
|
|
|
show (ID someID) = p ++ ('#' : show someID)
|
|
|
|
where Prefix p = (prefix :: Prefix a)
|
|
|
|
|
|
|
|
instance IDType a => Read (ID a) where
|
|
|
|
readPrec = fmap (ID . read) . lift $
|
|
|
|
string p >> char '#' >> munch (isDigit)
|
|
|
|
where Prefix p = (prefix :: Prefix a)
|
2019-11-12 22:15:39 +01:00
|
|
|
|
|
|
|
rIntToRID :: (Int, g) -> (ID a, g)
|
|
|
|
rIntToRID (someID, g) = (ID someID, g)
|
|
|
|
|
|
|
|
instance Random (ID a) where
|
|
|
|
random = rIntToRID . randomR (0, maxBound)
|
|
|
|
randomR (ID idA, ID idB) = rIntToRID . randomR (idA, idB)
|