{-# OPTIONS -Wall #-}
{-# OPTIONS -Wno-compat #-}
{-# OPTIONS -Wincomplete-record-updates #-}
{-# OPTIONS -Wincomplete-uni-patterns #-}
{-# OPTIONS -Wredundant-constraints #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NoOverloadedLists #-}
{-# LANGUAGE NoStarIsType #-}
module Predicate.Data.Char (
Char1
, IsLower
, IsUpper
, IsDigit
, IsSpace
, IsPunctuation
, IsControl
, IsHexDigit
, IsOctDigit
, IsSeparator
, IsLatin1
, IsLowerAll
, IsUpperAll
, IsDigitAll
, IsSpaceAll
, IsPunctuationAll
, IsControlAll
, IsHexDigitAll
, IsOctDigitAll
, IsSeparatorAll
, IsLatin1All
, ToTitle
, ToUpper
, ToLower
) where
import Predicate.Core
import Predicate.Util
import Control.Lens hiding (iall)
import qualified Data.Text.Lens as DTL
import GHC.TypeLits (Symbol, KnownSymbol)
import qualified GHC.TypeLits as GL
import Data.Proxy
import Data.Char
data Char1 (s :: Symbol)
instance ( KnownSymbol s
, GL.CmpSymbol s "" ~ 'GT
) => P (Char1 s) a where
type PP (Char1 s) a = Char
eval _ opts _ =
case symb @s of
[] -> errorInProgram "Char1: found empty Symbol/string"
c:_ -> pure $ mkNode opts (PresentT c) ("Char1 " <> showL opts c) []
data IsCharSet (cs :: CharSet)
instance ( x ~ Char
, GetCharSet cs
) => P (IsCharSet cs) x where
type PP (IsCharSet cs) x = Bool
eval _ opts c =
let msg0 = "Is" ++ drop 1 (show cs)
(cs,f) = getCharSet @cs
b = f c
in pure $ mkNodeB opts b (msg0 <> showVerbose opts " | " [c]) []
data IsLower
type IsLowerT = IsCharSet 'CLower
instance P IsLowerT x => P IsLower x where
type PP IsLower x = PP IsLowerT x
eval _ = evalBool (Proxy @IsLowerT)
data IsUpper
type IsUpperT = IsCharSet 'CUpper
instance P IsUpperT x => P IsUpper x where
type PP IsUpper x = PP IsUpperT x
eval _ = evalBool (Proxy @IsUpperT)
data IsDigit
type IsDigitT = IsCharSet 'CNumber
instance P IsDigitT x => P IsDigit x where
type PP IsDigit x = Bool
eval _ = evalBool (Proxy @IsDigitT)
data IsSpace
type IsSpaceT = IsCharSet 'CSpace
instance P IsSpaceT x => P IsSpace x where
type PP IsSpace x = Bool
eval _ = evalBool (Proxy @IsSpaceT)
data IsPunctuation
type IsPunctuationT = IsCharSet 'CPunctuation
instance P IsPunctuationT x => P IsPunctuation x where
type PP IsPunctuation x = Bool
eval _ = evalBool (Proxy @IsPunctuationT)
data IsControl
type IsControlT = IsCharSet 'CControl
instance P IsControlT x => P IsControl x where
type PP IsControl x = Bool
eval _ = evalBool (Proxy @IsControlT)
data IsHexDigit
type IsHexDigitT = IsCharSet 'CHexDigit
instance P IsHexDigitT x => P IsHexDigit x where
type PP IsHexDigit x = Bool
eval _ = evalBool (Proxy @IsHexDigitT)
data IsOctDigit
type IsOctDigitT = IsCharSet 'COctDigit
instance P IsOctDigitT x => P IsOctDigit x where
type PP IsOctDigit x = Bool
eval _ = evalBool (Proxy @IsOctDigitT)
data IsSeparator
type IsSeparatorT = IsCharSet 'CSeparator
instance P IsSeparatorT x => P IsSeparator x where
type PP IsSeparator x = Bool
eval _ = evalBool (Proxy @IsSeparatorT)
data IsLatin1
type IsLatin1T = IsCharSet 'CLatin1
instance P IsLatin1T x => P IsLatin1 x where
type PP IsLatin1 x = Bool
eval _ = evalBool (Proxy @IsLatin1T)
data IsCharSetAll (cs :: CharSet)
instance (GetCharSet cs
, Show a
, DTL.IsText a
) => P (IsCharSetAll cs) a where
type PP (IsCharSetAll cs) a = Bool
eval _ opts as =
let b = allOf DTL.text f as
msg0 = "Is" ++ drop 1 (show cs) ++ "All"
(cs,f) = getCharSet @cs
in pure $ mkNodeB opts b (msg0 <> showVerbose opts " | " as) []
data CharSet = CLower
| CUpper
| CNumber
| CSpace
| CPunctuation
| CControl
| CHexDigit
| COctDigit
| CSeparator
| CLatin1
deriving Show
class GetCharSet (cs :: CharSet) where
getCharSet :: (CharSet, Char -> Bool)
instance GetCharSet 'CLower where
getCharSet = (CLower, isLower)
instance GetCharSet 'CUpper where
getCharSet = (CUpper, isUpper)
instance GetCharSet 'CNumber where
getCharSet = (CNumber, isNumber)
instance GetCharSet 'CSpace where
getCharSet = (CSpace, isSpace)
instance GetCharSet 'CPunctuation where
getCharSet = (CPunctuation, isPunctuation)
instance GetCharSet 'CControl where
getCharSet = (CControl, isControl)
instance GetCharSet 'CHexDigit where
getCharSet = (CHexDigit, isHexDigit)
instance GetCharSet 'COctDigit where
getCharSet = (COctDigit, isOctDigit)
instance GetCharSet 'CSeparator where
getCharSet = (CSeparator, isSeparator)
instance GetCharSet 'CLatin1 where
getCharSet = (CLatin1, isLatin1)
data IsLowerAll
type IsLowerAllT = IsCharSetAll 'CLower
instance P IsLowerAllT x => P IsLowerAll x where
type PP IsLowerAll x = PP IsLowerAllT x
eval _ = evalBool (Proxy @IsLowerAllT)
data IsUpperAll
type IsUpperAllT = IsCharSetAll 'CUpper
instance P IsUpperAllT x => P IsUpperAll x where
type PP IsUpperAll x = PP IsUpperAllT x
eval _ = evalBool (Proxy @IsUpperAllT)
data IsDigitAll
type IsDigitAllT = IsCharSetAll 'CNumber
instance P IsDigitAllT x => P IsDigitAll x where
type PP IsDigitAll x = Bool
eval _ = evalBool (Proxy @IsDigitAllT)
data IsSpaceAll
type IsSpaceAllT = IsCharSetAll 'CSpace
instance P IsSpaceAllT x => P IsSpaceAll x where
type PP IsSpaceAll x = Bool
eval _ = evalBool (Proxy @IsSpaceAllT)
data IsPunctuationAll
type IsPunctuationAllT = IsCharSetAll 'CPunctuation
instance P IsPunctuationAllT x => P IsPunctuationAll x where
type PP IsPunctuationAll x = Bool
eval _ = evalBool (Proxy @IsPunctuationAllT)
data IsControlAll
type IsControlAllT = IsCharSetAll 'CControl
instance P IsControlAllT x => P IsControlAll x where
type PP IsControlAll x = Bool
eval _ = evalBool (Proxy @IsControlAllT)
data IsHexDigitAll
type IsHexDigitAllT = IsCharSetAll 'CHexDigit
instance P IsHexDigitAllT x => P IsHexDigitAll x where
type PP IsHexDigitAll x = Bool
eval _ = evalBool (Proxy @IsHexDigitAllT)
data IsOctDigitAll
type IsOctDigitAllT = IsCharSetAll 'COctDigit
instance P IsOctDigitAllT x => P IsOctDigitAll x where
type PP IsOctDigitAll x = Bool
eval _ = evalBool (Proxy @IsOctDigitAllT)
data IsSeparatorAll
type IsSeparatorAllT = IsCharSetAll 'CSeparator
instance P IsSeparatorAllT x => P IsSeparatorAll x where
type PP IsSeparatorAll x = Bool
eval _ = evalBool (Proxy @IsSeparatorAllT)
data IsLatin1All
type IsLatin1AllT = IsCharSetAll 'CLatin1
instance P IsLatin1AllT x => P IsLatin1All x where
type PP IsLatin1All x = Bool
eval _ = evalBool (Proxy @IsLatin1AllT)
data ToLower
instance ( Show a
, DTL.IsText a
) => P ToLower a where
type PP ToLower a = a
eval _ opts as =
let msg0 = "ToLower"
xs = as & DTL.text %~ toLower
in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) []
data ToUpper
instance ( Show a
, DTL.IsText a
) => P ToUpper a where
type PP ToUpper a = a
eval _ opts as =
let msg0 = "ToUpper"
xs = as & DTL.text %~ toUpper
in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) []
data ToTitle
instance ( Show a
, DTL.IsText a
) => P ToTitle a where
type PP ToTitle a = a
eval _ opts as =
let msg0 = "ToTitle"
xs = toTitleAll (as ^. DTL.unpacked) ^. DTL.packed
in pure $ mkNode opts (PresentT xs) (show01 opts msg0 xs as) []
toTitleAll :: String -> String
toTitleAll (x:xs) = toUpper x : map toLower xs
toTitleAll [] = []