Cases.hs

{-# LANGUAGE QuasiQuotes #-}

-- |
-- Exposes subspecies types of Char.
-- e.g. `[a-z]`, `[A-Z]`, and `[0-9]`.
module Data.Char.Cases
  ( AlphaNumChar (..)
  , alphaNumToChar
  , alphaNumChar
  , charToAlphaNum
  , alphaNumCharQ
  , AlphaChar (..)
  , alphaToChar
  , charToAlpha
  , alphaChar
  , alphaCharQ
  , UpperChar (..)
  , upperToChar
  , upperChar
  , charToUpper
  , upperCharQ
  , LowerChar (..)
  , lowerToChar
  , lowerChar
  , charToLower
  , lowerCharQ
  , DigitChar (..)
  , digitToChar
  , digitChar
  , charToDigit
  , digitCharQ
  , SnakeChar (..)
  , snakeToChar
  , snakeChar
  , charToSnake
  , snakeCharQ
  , SnakeHeadChar (..)
  , snakeHeadToChar
  , snakeHeadChar
  , charToSnakeHead
  , snakeHeadCharQ
  , UpperSnakeHeadChar (..)
  , upperSnakeHeadToChar
  , upperSnakeHeadChar
  , charToUpperSnakeHead
  , upperSnakeHeadCharQ
  , UpperSnakeChar (..)
  , upperSnakeToChar
  , upperSnakeChar
  , charToUpperSnake
  , upperSnakeCharQ
  ) where

import Cases.Megaparsec
import Control.Applicative
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromJust)
import Data.String.Here (i)
import Data.Tuple (swap)
import Language.Haskell.TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P

-- $setup
-- >>> :set -XQuasiQuotes

dual :: Ord a => Map k a -> Map a k
dual (Map.toList -> x) =
  Map.fromList $ map swap x


-- | '[A-Za-z0-9]'
data AlphaNumChar = AlphaNumAlpha AlphaChar
                  | AlphaNumDigit DigitChar
  deriving (Show, Eq, Ord)

alphaNumToChar :: AlphaNumChar -> Char
alphaNumToChar (AlphaNumAlpha x) = alphaToChar x
alphaNumToChar (AlphaNumDigit x) = digitToChar x

alphaNumChar :: CodeParsing m => m AlphaNumChar
alphaNumChar =
  AlphaNumAlpha <$> alphaChar <|>
  AlphaNumDigit <$> digitChar

charToAlphaNum :: Char -> Maybe AlphaNumChar
charToAlphaNum x = P.parseMaybe alphaNumChar [x]

-- |
-- Simular to 'alphaCharQ' and 'digitCharQ'.
--
-- >>> [alphaNumCharQ|x|]
-- AlphaNumAlpha (AlphaLower X_)
--
-- >>> [alphaNumCharQ|X|]
-- AlphaNumAlpha (AlphaUpper X)
--
-- >>> [alphaNumCharQ|1|]
-- AlphaNumDigit D1
alphaNumCharQ :: QuasiQuoter
alphaNumCharQ = QuasiQuoter
  { quoteExp  = expQ
  , quotePat  = error "not supported"
  , quoteType = error "not supported"
  , quoteDec  = error "not supported"
  }
  where
    expQ :: String -> Q Exp
    expQ [] = fail "alphaNumCharQ required a Char, but nothign is specified."

    expQ (x : []) = case charToAlphaNum x of
      Nothing -> fail [i|'${x}' is not an AlphaNumChar.|]
      Just (AlphaNumAlpha _) ->
        (ConE (mkName "AlphaNumAlpha") `AppE`) <$> (quoteExp alphaCharQ) [x]
      Just (AlphaNumDigit _) ->
        (ConE (mkName "AlphaNumDigit") `AppE`) <$> (quoteExp digitCharQ) [x]

    expQ xs@(_ : _) = fail [i|alphaNumCharQ required a Char, but a String is specified: ${xs}|]


-- | '[A-Za-z]'
data AlphaChar = AlphaLower LowerChar
               | AlphaUpper UpperChar
  deriving (Show, Eq, Ord)

alphaToChar :: AlphaChar -> Char
alphaToChar (AlphaLower x) = lowerToChar x
alphaToChar (AlphaUpper x) = upperToChar x

charToAlpha :: Char -> Maybe AlphaChar
charToAlpha x = P.parseMaybe alphaChar [x]

alphaChar :: CodeParsing m => m AlphaChar
alphaChar =
  AlphaLower <$> lowerChar <|>
  AlphaUpper <$> upperChar

-- | Simular to 'lowerCharQ' and 'upperCharQ'.
alphaCharQ :: QuasiQuoter
alphaCharQ = QuasiQuoter
  { quoteExp  = expQ
  , quotePat  = error "not supported"
  , quoteType = error "not supported"
  , quoteDec  = error "not supported"
  }
  where
    expQ :: String -> Q Exp
    expQ [] = fail "alphaCharQ required a Char, but nothign is specified."

    expQ (x : []) = case charToAlpha x of
      Nothing -> fail [i|'${x}' is not an AlphaChar.|]
      Just (AlphaLower _) ->
        (ConE (mkName "AlphaLower") `AppE`) <$> (quoteExp lowerCharQ) [x]
      Just (AlphaUpper _) ->
        (ConE (mkName "AlphaUpper") `AppE`) <$> (quoteExp upperCharQ) [x]

    expQ xs@(_ : _) = fail [i|alphaCharQ required a Char, but a String is specified: ${xs}|]


-- | '[A-Z]'
data UpperChar = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O | P | Q | R | S | T | U | V | W | X | Y | Z
  deriving (Show, Eq, Ord)

upperToChar :: UpperChar -> Char
upperToChar = fromJust . flip Map.lookup uppers

uppers :: Map UpperChar Char
uppers = Map.fromList
  [ (A, 'A'), (B, 'B'), (C, 'C')
  , (D, 'D'), (E, 'E'), (F, 'F')
  , (G, 'G'), (H, 'H'), (I, 'I')
  , (J, 'J'), (K, 'K'), (L, 'L')
  , (M, 'M'), (N, 'N'), (O, 'O')
  , (P, 'P'), (Q, 'Q'), (R, 'R')
  , (S, 'S'), (T, 'T'), (U, 'U')
  , (V, 'V'), (W, 'W'), (X, 'X')
  , (Y, 'Y'), (Z, 'Z')
  ]

upperChar :: CodeParsing m => m UpperChar
upperChar = do
  char <- P.upperChar
  let maybeUpper = Map.lookup char $ dual uppers
  case maybeUpper of
    Nothing -> fail "non upper char"
    Just x -> pure x

charToUpper :: Char -> Maybe UpperChar
charToUpper x = P.parseMaybe upperChar [x]

-- |
-- Extracts a Char of [A-Z].
-- Also throws compile error if non [A-Z] is passed.
--
-- >>> [upperCharQ|X|]
-- X
--
-- >>> [upperCharQ|Y|]
-- Y
upperCharQ :: QuasiQuoter
upperCharQ = QuasiQuoter
  { quoteExp  = expQ
  , quotePat  = error "not supported"
  , quoteType = error "not supported"
  , quoteDec  = error "not supported"
  }
  where
    expQ :: String -> Q Exp
    expQ [] = fail "upperCharQ required a Char, but nothign is specified."

    expQ (x : []) = case charToUpper x of
      Nothing -> fail [i|'${x}' is not an UpperChar.|]
      Just z -> conE . mkName $ show z

    expQ xs@(_ : _) = fail [i|upperCharQ required a Char, but a String is specified: ${xs}|]


-- | '[a-z]'
data LowerChar = A_ | B_ | C_ | D_ | E_ | F_ | G_ | H_ | I_ | J_ | K_ | L_ | M_ | N_ | O_ | P_ | Q_ | R_ | S_ | T_ | U_ | V_ | W_ | X_ | Y_ | Z_
  deriving (Show, Eq, Ord)

lowerToChar :: LowerChar -> Char
lowerToChar = fromJust . flip Map.lookup lowers

lowers :: Map LowerChar Char
lowers = Map.fromList
  [ (A_, 'a'), (B_, 'b'), (C_, 'c')
  , (D_, 'd'), (E_, 'e'), (F_, 'f')
  , (G_, 'g'), (H_, 'h'), (I_, 'i')
  , (J_, 'j'), (K_, 'k'), (L_, 'l')
  , (M_, 'm'), (N_, 'n'), (O_, 'o')
  , (P_, 'p'), (Q_, 'q'), (R_, 'r')
  , (S_, 's'), (T_, 't'), (U_, 'u')
  , (V_, 'v'), (W_, 'w'), (X_, 'x')
  , (Y_, 'y'), (Z_, 'z')
  ]

lowerChar :: CodeParsing m => m LowerChar
lowerChar = do
  char <- P.lowerChar
  let maybeLower = Map.lookup char $ dual lowers
  case maybeLower of
    Nothing -> fail "non lower char"
    Just x -> pure x

charToLower :: Char -> Maybe LowerChar
charToLower x = P.parseMaybe lowerChar [x]

-- |
-- Extracts a Char of [a-z].
-- Also throws compile error if non [a-z] is passed.
--
-- >>> [lowerCharQ|x|]
-- X_
--
-- >>> [lowerCharQ|y|]
-- Y_
lowerCharQ :: QuasiQuoter
lowerCharQ = QuasiQuoter
  { quoteExp  = expQ
  , quotePat  = error "not supported"
  , quoteType = error "not supported"
  , quoteDec  = error "not supported"
  }
  where
    expQ :: String -> Q Exp
    expQ [] = fail "lowerCharQ required a Char, but nothign is specified."

    expQ (x : []) = case charToLower x of
      Nothing -> fail [i|'${x}' is not a LowerChar.|]
      Just z -> conE . mkName $ show z

    expQ xs@(_ : _) = fail [i|lowerCharQ required a Char, but a String is specified: ${xs}|]


-- | '[0-9]'
data DigitChar = D0
               | D1
               | D2
               | D3
               | D4
               | D5
               | D6
               | D7
               | D8
               | D9
  deriving (Show, Eq, Ord)

digitToChar :: DigitChar -> Char
digitToChar = fromJust . flip Map.lookup digits

digits :: Map DigitChar Char
digits = Map.fromList
  [ (D0, '0')
  , (D1, '1'), (D2, '2'), (D3, '3')
  , (D4, '4'), (D5, '5'), (D6, '6')
  , (D4, '7'), (D8, '8'), (D9, '9')
  ]

digitChar :: CodeParsing m => m DigitChar
digitChar = do
  char <- P.digitChar
  let maybeNum = Map.lookup char $ dual digits
  case maybeNum of
    Nothing -> fail "non numeric char"
    Just x -> pure x

charToDigit :: Char -> Maybe DigitChar
charToDigit x = P.parseMaybe digitChar [x]

-- |
-- Extracts a Char of [0-9].
-- Also throws compile error if non [a-z] is passed.
--
-- >>> [digitCharQ|0|]
-- D0
--
-- >>> [digitCharQ|9|]
-- D9
digitCharQ :: QuasiQuoter
digitCharQ = QuasiQuoter
  { quoteExp  = expQ
  , quotePat  = error "not supported"
  , quoteType = error "not supported"
  , quoteDec  = error "not supported"
  }
  where
    expQ :: String -> Q Exp
    expQ [] = fail "digitCharQ required a Char, but nothign is specified."

    expQ (x : []) = case charToDigit x of
      Nothing -> fail [i|'${x}' is not a DigitChar.|]
      Just z -> conE . mkName $ show z

    expQ xs@(_ : _) = fail [i|digitCharQ required a Char, but a String is specified: ${xs}|]


-- |
-- '[a-zA-Z0-9_]'
--
-- Please see 'Snake'.
data SnakeChar = SnakeUnderscore -- ^ _
               | SnakeAlphaNum AlphaNumChar -- ^ [a-zA-Z0-9]
  deriving (Show, Eq)

snakeToChar :: SnakeChar -> Char
snakeToChar SnakeUnderscore = '_'
snakeToChar (SnakeAlphaNum x) = alphaNumToChar x

snakeChar :: CodeParsing m => m SnakeChar
snakeChar =
  SnakeUnderscore <$ P.char '_' <|>
  SnakeAlphaNum <$> alphaNumChar

charToSnake :: Char -> Maybe SnakeChar
charToSnake x = P.parseMaybe snakeChar [x]

-- |
-- Extracts a Char of [a-zA-Z0-9_].
-- Also throws compile error if non [a-zA-Z0-9_] is passed.
--
-- >>> [snakeCharQ|x|]
-- SnakeAlphaNum (AlphaNumAlpha (AlphaLower X_))
--
-- >>> [snakeCharQ|X|]
-- SnakeAlphaNum (AlphaNumAlpha (AlphaUpper X))
--
-- >>> [snakeCharQ|_|]
-- SnakeUnderscore
--
-- >>> [snakeCharQ|9|]
-- SnakeAlphaNum (AlphaNumDigit D9)
snakeCharQ :: QuasiQuoter
snakeCharQ = QuasiQuoter
  { quoteExp  = expQ
  , quotePat  = error "not supported"
  , quoteType = error "not supported"
  , quoteDec  = error "not supported"
  }
  where
    expQ :: String -> Q Exp
    expQ [] = fail "snakeCharQ required a Char, but nothign is specified."

    expQ (x : []) = case charToSnake x of
      Nothing -> fail [i|'${x}' is not a SnakeChar.|]
      Just SnakeUnderscore ->
        conE $ mkName "SnakeUnderscore"
      Just (SnakeAlphaNum _) ->
        (ConE (mkName "SnakeAlphaNum") `AppE`) <$> (quoteExp alphaNumCharQ) [x]

    expQ xs@(_ : _) = fail [i|snakeCharQ required a Char, but a String is specified: ${xs}|]


-- |
-- '[a-zA-Z_]'
--
-- Please see 'Snake'.
data SnakeHeadChar = SnakeHeadUnderscore
                   | SnakeHeadAlpha AlphaChar
  deriving (Show, Eq)

snakeHeadToChar :: SnakeHeadChar -> Char
snakeHeadToChar SnakeHeadUnderscore = '_'
snakeHeadToChar (SnakeHeadAlpha x) = alphaToChar x

snakeHeadChar :: CodeParsing m => m SnakeHeadChar
snakeHeadChar =
  SnakeHeadUnderscore <$ P.char '_' <|>
  SnakeHeadAlpha <$> alphaChar

charToSnakeHead :: Char -> Maybe SnakeHeadChar
charToSnakeHead x = P.parseMaybe snakeHeadChar [x]

-- |
-- Extracts a Char of [a-zA-Z_].
-- Also throws compile error if non [a-zA-Z_] is passed.
--
-- >>> [snakeHeadCharQ|x|]
-- SnakeHeadAlpha (AlphaLower X_)
--
-- >>> [snakeHeadCharQ|X|]
-- SnakeHeadAlpha (AlphaUpper X)
--
-- >>> [snakeHeadCharQ|_|]
-- SnakeHeadUnderscore
snakeHeadCharQ :: QuasiQuoter
snakeHeadCharQ = QuasiQuoter
  { quoteExp  = expQ
  , quotePat  = error "not supported"
  , quoteType = error "not supported"
  , quoteDec  = error "not supported"
  }
  where
    expQ :: String -> Q Exp
    expQ [] = fail "snakeHeadCharQ required a Char, but nothign is specified."

    expQ (x : []) = case charToSnakeHead x of
      Nothing -> fail [i|'${x}' is not a SnakeHeadChar.|]
      Just SnakeHeadUnderscore ->
        conE $ mkName "SnakeHeadUnderscore"
      Just (SnakeHeadAlpha _) ->
        (ConE (mkName "SnakeHeadAlpha") `AppE`) <$> (quoteExp alphaCharQ) [x]

    expQ xs@(_ : _) = fail [i|snakeHeadCharQ required a Char, but a String is specified: ${xs}|]


-- |
-- '[A-Z_]'
--
-- Please sese 'UpperSnake'.
data UpperSnakeHeadChar = UpperSnakeHeadUnderscore -- ^ _
                        | UpperSnakeHeadUpper UpperChar -- ^ [A-Z]
  deriving (Show, Eq)

upperSnakeHeadToChar :: UpperSnakeHeadChar -> Char
upperSnakeHeadToChar UpperSnakeHeadUnderscore = '_'
upperSnakeHeadToChar (UpperSnakeHeadUpper x) = upperToChar x

upperSnakeHeadChar :: CodeParsing m => m UpperSnakeHeadChar
upperSnakeHeadChar =
  UpperSnakeHeadUnderscore <$ P.char '_' <|>
  UpperSnakeHeadUpper <$> upperChar

charToUpperSnakeHead :: Char -> Maybe UpperSnakeHeadChar
charToUpperSnakeHead x = P.parseMaybe upperSnakeHeadChar [x]

-- |
-- >>> [upperSnakeHeadCharQ|_|]
-- UpperSnakeHeadUnderscore
--
-- >>> [upperSnakeHeadCharQ|A|]
-- UpperSnakeHeadUpper A
upperSnakeHeadCharQ :: QuasiQuoter
upperSnakeHeadCharQ = QuasiQuoter
  { quoteExp  = expQ
  , quotePat  = error "not supported"
  , quoteType = error "not supported"
  , quoteDec  = error "not supported"
  }
  where
    expQ :: String -> Q Exp
    expQ [] = fail "upperSnakeHeadCharQ required a Char, but nothign is specified."

    expQ (x : []) = case charToUpperSnakeHead x of
      Nothing ->
        fail [i|'${x}' is not a UpperSnakeHeadChar.|]
      Just UpperSnakeHeadUnderscore ->
        conE $ mkName "UpperSnakeHeadUnderscore"
      Just (UpperSnakeHeadUpper _) ->
        (ConE (mkName "UpperSnakeHeadUpper") `AppE`) <$> (quoteExp upperCharQ) [x]

    expQ xs@(_ : _) = fail [i|upperSnakeHeadCharQ required a Char, but a String is specified: ${xs}|]


-- |
-- '[A-Z0-9_]'
--
-- Please see 'Snake'.
data UpperSnakeChar = UpperSnakeUnderscore -- ^ _
                    | UpperSnakeUpper UpperChar -- ^ [A-Z]
                    | UpperSnakeDigit DigitChar  -- ^ [0-9]
  deriving (Show, Eq)

upperSnakeToChar :: UpperSnakeChar -> Char
upperSnakeToChar UpperSnakeUnderscore = '_'
upperSnakeToChar (UpperSnakeUpper x) = upperToChar x
upperSnakeToChar (UpperSnakeDigit x) = digitToChar x

upperSnakeChar :: CodeParsing m => m UpperSnakeChar
upperSnakeChar =
  UpperSnakeUnderscore <$ P.char '_' <|>
  UpperSnakeUpper <$> upperChar <|>
  UpperSnakeDigit <$> digitChar

charToUpperSnake :: Char -> Maybe UpperSnakeChar
charToUpperSnake x = P.parseMaybe upperSnakeChar [x]

-- |
-- >>> [upperSnakeCharQ|_|]
-- UpperSnakeUnderscore
--
-- >>> [upperSnakeCharQ|A|]
-- UpperSnakeUpper A
--
-- >>> [upperSnakeCharQ|0|]
-- UpperSnakeDigit D0
upperSnakeCharQ :: QuasiQuoter
upperSnakeCharQ = QuasiQuoter
  { quoteExp  = expQ
  , quotePat  = error "not supported"
  , quoteType = error "not supported"
  , quoteDec  = error "not supported"
  }
  where
    expQ :: String -> Q Exp
    expQ [] = fail "upperSnakeCharQ required a Char, but nothign is specified."

    expQ (x : []) = case charToUpperSnake x of
      Nothing ->
        fail [i|'${x}' is not a UpperSnakeChar.|]
      Just UpperSnakeUnderscore ->
        conE $ mkName "UpperSnakeUnderscore"
      Just (UpperSnakeUpper _) ->
        (ConE (mkName "UpperSnakeUpper") `AppE`) <$> (quoteExp upperCharQ) [x]
      Just (UpperSnakeDigit _) ->
        (ConE (mkName "UpperSnakeDigit") `AppE`) <$> (quoteExp digitCharQ) [x]

    expQ xs@(_ : _) = fail [i|upperSnakeCharQ required a Char, but a String is specified: ${xs}|]