character-cases-0.1.0.6: src/Data/Char/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.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 $ show 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 $ "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 $ show 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 $ "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 $ show x <> " is not an UpperChar."
Just z -> conE . mkName $ show z
expQ xs@(_ : _) = fail $ "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 $ show x <> " is not a LowerChar."
Just z -> conE . mkName $ show z
expQ xs@(_ : _) = fail $ "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 $ show x <> " is not a DigitChar."
Just z -> conE . mkName $ show z
expQ xs@(_ : _) = fail $ "digitCharQ required a Char, but a String is specified: " <> xs
-- |
-- '[a-zA-Z0-9_]'
--
-- Please see 'Data.String.Cases.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 $ show x <> " is not a SnakeChar."
Just SnakeUnderscore ->
conE $ mkName "SnakeUnderscore"
Just (SnakeAlphaNum _) ->
(ConE (mkName "SnakeAlphaNum") `AppE`) <$> (quoteExp alphaNumCharQ) [x]
expQ xs@(_ : _) = fail $ "snakeCharQ required a Char, but a String is specified: " <> xs
-- |
-- '[a-zA-Z_]'
--
-- Please see 'Data.String.Cases.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 $ show x <> " is not a SnakeHeadChar."
Just SnakeHeadUnderscore ->
conE $ mkName "SnakeHeadUnderscore"
Just (SnakeHeadAlpha _) ->
(ConE (mkName "SnakeHeadAlpha") `AppE`) <$> (quoteExp alphaCharQ) [x]
expQ xs@(_ : _) = fail $ "snakeHeadCharQ required a Char, but a String is specified: " <> xs
-- |
-- '[A-Z_]'
--
-- Please sese 'Data.String.Cases.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 $ show x <> " is not a UpperSnakeHeadChar."
Just UpperSnakeHeadUnderscore ->
conE $ mkName "UpperSnakeHeadUnderscore"
Just (UpperSnakeHeadUpper _) ->
(ConE (mkName "UpperSnakeHeadUpper") `AppE`) <$> (quoteExp upperCharQ) [x]
expQ xs@(_ : _) = fail $ "upperSnakeHeadCharQ required a Char, but a String is specified: " <> xs
-- |
-- '[A-Z0-9_]'
--
-- Please see 'Data.String.Cases.UpperSnake'.
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 $ show 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 $ "upperSnakeCharQ required a Char, but a String is specified: " <> xs