{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
module Haskus.Format.Text.Unicode.CodePoint
( CodePoint (..)
, CodePointRange
, pattern CodePointRange
)
where
import Haskus.Format.Binary.Word
import Haskus.Format.Binary.Bits
import Numeric
import Data.Char (toUpper)
import Language.Haskell.TH.Syntax (Lift)
newtype CodePoint = CodePoint Word32 deriving (Eq,Lift)
instance Show CodePoint where
show (CodePoint v) = "U+" ++ f (fmap toUpper (showHex v ""))
where
f xs@[_,_,_] = '0':xs
f xs@[_,_] = "00" <> xs
f xs@[_] = "000" <> xs
f xs@[] = "0000" <> xs
f xs = xs
newtype CodePointRange = Range Word64 deriving (Eq,Lift)
fromRange :: CodePointRange -> (CodePoint,CodePoint)
fromRange (Range w) = ( CodePoint $ fromIntegral (w .&. 0xFFFFFFFF)
, CodePoint $ fromIntegral (w `uncheckedShiftR` 32)
)
toRange :: (CodePoint,CodePoint) -> CodePointRange
toRange (CodePoint x, CodePoint y) =
Range (fromIntegral x .|. (fromIntegral y `uncheckedShiftL` 32))
{-# COMPLETE CodePointRange #-}
pattern CodePointRange :: CodePoint -> CodePoint -> CodePointRange
pattern CodePointRange x y <- (fromRange -> (x,y))
where
CodePointRange x y = toRange (x,y)
instance Show CodePointRange where
show (CodePointRange x y) = show x ++ ".." ++ show y