{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
module Data.String.Cases where
import Cases.Megaparsec
import Data.Char.Cases
import qualified Data.String as String
import Data.Text.Prettyprint.Doc (Pretty(..))
import Language.Haskell.TH
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import qualified Text.Megaparsec as P
data Pascal = Pascal UpperChar [AlphaNumChar]
deriving (Show, Eq)
instance Pretty Pascal where
pretty = String.fromString . unPascal
unPascal :: Pascal -> String
unPascal (Pascal x xs) =
upperToChar x : map alphaNumToChar xs
parsePascal :: CodeParsing m => m Pascal
parsePascal =
Pascal <$> upperChar <*> P.many alphaNumChar
pascalQ :: QuasiQuoter
pascalQ = QuasiQuoter
{ quoteExp = expQ
, quotePat = error "not supported"
, quoteType = error "not supported"
, quoteDec = error "not supported"
}
where
expQ :: String -> Q Exp
expQ [] = fail "pascalQ required a non empty string, but the empty string is specified."
expQ (x : xs) = do
z <- (quoteExp upperCharQ) [x]
zs <- mapM (quoteExp alphaNumCharQ) $ map (: []) xs
pure $ ConE (mkName "Pascal") `AppE` z `AppE` ListE zs
data NonEmpty = NonEmpty Char String
deriving (Show, Eq)
instance Pretty NonEmpty where
pretty = String.fromString . unNonEmpty
unNonEmpty :: NonEmpty -> String
unNonEmpty (NonEmpty x xs) = x : xs
parseNonEmpty :: CodeParsing m => m NonEmpty
parseNonEmpty =
NonEmpty <$> P.anySingle <*> P.many P.anySingle
fromString :: String -> Maybe NonEmpty
fromString "" = Nothing
fromString (x : xs) = Just $ NonEmpty x xs
nonEmptyQ :: QuasiQuoter
nonEmptyQ = QuasiQuoter
{ quoteExp = expQ
, quotePat = error "not supported"
, quoteType = error "not supported"
, quoteDec = error "not supported"
}
where
expQ :: String -> Q Exp
expQ [] = fail "nonEmptyQ required a non empty string, but the empty string is specified."
expQ (x : xs) =
pure $ ConE (mkName "NonEmpty")
`AppE` LitE (CharL x)
`AppE` ListE (map (LitE . CharL) xs)
data Camel = Camel AlphaChar [AlphaNumChar]
deriving (Eq)
instance Show Camel where
show (Camel x xs) = '"' : alphaToChar x : map alphaNumToChar xs <> "\""
instance Pretty Camel where
pretty = String.fromString . unCamel
unCamel :: Camel -> String
unCamel (Camel x xs) = alphaToChar x : map alphaNumToChar xs
parseCamel :: CodeParsing m => m Camel
parseCamel =
Camel <$> alphaChar <*> P.many alphaNumChar
camelQ :: QuasiQuoter
camelQ = QuasiQuoter
{ quoteExp = expQ
, quotePat = error "not supported"
, quoteType = error "not supported"
, quoteDec = error "not supported"
}
where
expQ :: String -> Q Exp
expQ [] = fail "camelQ required a non empty string, but the empty string is specified."
expQ (x : xs) = do
z <- (quoteExp alphaCharQ) [x]
zs <- mapM (quoteExp alphaNumCharQ) $ map (: []) xs
pure $ ConE (mkName "Camel") `AppE` z `AppE` ListE zs
data Sneak = Sneak SneakHeadChar [SneakChar]
deriving (Show, Eq)
instance Pretty Sneak where
pretty = String.fromString . unSneakCase
unSneakCase :: Sneak -> String
unSneakCase (Sneak x xs) =
unSneakHeadChar x : map unSneakChar xs
parseSneakCase :: CodeParsing m => m Sneak
parseSneakCase =
Sneak <$>
sneakHeadChar <*>
P.many sneakChar
sneakQ :: QuasiQuoter
sneakQ = QuasiQuoter
{ quoteExp = expQ
, quotePat = error "not supported"
, quoteType = error "not supported"
, quoteDec = error "not supported"
}
where
expQ :: String -> Q Exp
expQ [] = fail "sneakQ required a non empty string, but the empty string is specified."
expQ (x : xs) = do
z <- (quoteExp sneakHeadCharQ) [x]
zs <- mapM (quoteExp sneakCharQ) $ map (: []) xs
pure $ ConE (mkName "Sneak") `AppE` z `AppE` ListE zs
data LowerString = LowerString LowerChar [LowerChar]
deriving (Show, Eq)
instance Pretty LowerString where
pretty (LowerString x xs) = String.fromString $ map lowerToChar (x : xs)
unLowerString :: LowerString -> String
unLowerString (LowerString x xs) = lowerToChar x : map lowerToChar xs
parseLowerString :: CodeParsing m => m LowerString
parseLowerString = LowerString <$> lowerChar <*> P.many lowerChar
lowerStringQ :: QuasiQuoter
lowerStringQ = QuasiQuoter
{ quoteExp = expQ
, quotePat = error "not supported"
, quoteType = error "not supported"
, quoteDec = error "not supported"
}
where
expQ :: String -> Q Exp
expQ [] = fail "lowerStringQ required a non empty string, but the empty string is specified."
expQ (x : xs) = do
z <- (quoteExp lowerCharQ) [x]
zs <- mapM (quoteExp lowerCharQ) $ map (: []) xs
pure $ ConE (mkName "LowerString") `AppE` z `AppE` ListE zs