CodePoint.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

-- | Unicode code-point
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)

--------------------------------------------------
-- Code-point
--------------------------------------------------


-- | Code point
--
-- Number from 0 to 0x10FFFF
newtype CodePoint = CodePoint Word32 deriving (Eq,Lift)


-- | Show instance for CodePoint
--
-- >>> CodePoint 0x1234
-- U+1234
--
-- >>> CodePoint 0x12
-- U+0012
--
-- >>> CodePoint 0x1234A
-- U+1234A
--
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


--------------------------------------------------
-- Code-point range
--------------------------------------------------

-- | Code point range
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))

-- | Code-point range
{-# 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