{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Debug.TraceEmbrace.Config.Type.Level where

import Control.Monad
import Data.Aeson hiding (Error)
import Data.Char
import Data.Generics.Labels ()
import Data.List qualified as L
import Data.Maybe
import Data.Text qualified as T
import Data.Typeable
import GHC.Generics
import Language.Haskell.TH.Syntax
import Refined


data TraceLevel
  = Trace
  | Info
  | Warning
  | Error
  | TracingDisabled
  deriving (TraceLevel -> TraceLevel -> Bool
(TraceLevel -> TraceLevel -> Bool)
-> (TraceLevel -> TraceLevel -> Bool) -> Eq TraceLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TraceLevel -> TraceLevel -> Bool
== :: TraceLevel -> TraceLevel -> Bool
$c/= :: TraceLevel -> TraceLevel -> Bool
/= :: TraceLevel -> TraceLevel -> Bool
Eq, Int -> TraceLevel -> ShowS
[TraceLevel] -> ShowS
TraceLevel -> String
(Int -> TraceLevel -> ShowS)
-> (TraceLevel -> String)
-> ([TraceLevel] -> ShowS)
-> Show TraceLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TraceLevel -> ShowS
showsPrec :: Int -> TraceLevel -> ShowS
$cshow :: TraceLevel -> String
show :: TraceLevel -> String
$cshowList :: [TraceLevel] -> ShowS
showList :: [TraceLevel] -> ShowS
Show, Eq TraceLevel
Eq TraceLevel =>
(TraceLevel -> TraceLevel -> Ordering)
-> (TraceLevel -> TraceLevel -> Bool)
-> (TraceLevel -> TraceLevel -> Bool)
-> (TraceLevel -> TraceLevel -> Bool)
-> (TraceLevel -> TraceLevel -> Bool)
-> (TraceLevel -> TraceLevel -> TraceLevel)
-> (TraceLevel -> TraceLevel -> TraceLevel)
-> Ord TraceLevel
TraceLevel -> TraceLevel -> Bool
TraceLevel -> TraceLevel -> Ordering
TraceLevel -> TraceLevel -> TraceLevel
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TraceLevel -> TraceLevel -> Ordering
compare :: TraceLevel -> TraceLevel -> Ordering
$c< :: TraceLevel -> TraceLevel -> Bool
< :: TraceLevel -> TraceLevel -> Bool
$c<= :: TraceLevel -> TraceLevel -> Bool
<= :: TraceLevel -> TraceLevel -> Bool
$c> :: TraceLevel -> TraceLevel -> Bool
> :: TraceLevel -> TraceLevel -> Bool
$c>= :: TraceLevel -> TraceLevel -> Bool
>= :: TraceLevel -> TraceLevel -> Bool
$cmax :: TraceLevel -> TraceLevel -> TraceLevel
max :: TraceLevel -> TraceLevel -> TraceLevel
$cmin :: TraceLevel -> TraceLevel -> TraceLevel
min :: TraceLevel -> TraceLevel -> TraceLevel
Ord, (forall (m :: * -> *). Quote m => TraceLevel -> m Exp)
-> (forall (m :: * -> *).
    Quote m =>
    TraceLevel -> Code m TraceLevel)
-> Lift TraceLevel
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => TraceLevel -> m Exp
forall (m :: * -> *). Quote m => TraceLevel -> Code m TraceLevel
$clift :: forall (m :: * -> *). Quote m => TraceLevel -> m Exp
lift :: forall (m :: * -> *). Quote m => TraceLevel -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => TraceLevel -> Code m TraceLevel
liftTyped :: forall (m :: * -> *). Quote m => TraceLevel -> Code m TraceLevel
Lift, (forall x. TraceLevel -> Rep TraceLevel x)
-> (forall x. Rep TraceLevel x -> TraceLevel) -> Generic TraceLevel
forall x. Rep TraceLevel x -> TraceLevel
forall x. TraceLevel -> Rep TraceLevel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TraceLevel -> Rep TraceLevel x
from :: forall x. TraceLevel -> Rep TraceLevel x
$cto :: forall x. Rep TraceLevel x -> TraceLevel
to :: forall x. Rep TraceLevel x -> TraceLevel
Generic, TraceLevel
TraceLevel -> TraceLevel -> Bounded TraceLevel
forall a. a -> a -> Bounded a
$cminBound :: TraceLevel
minBound :: TraceLevel
$cmaxBound :: TraceLevel
maxBound :: TraceLevel
Bounded, Int -> TraceLevel
TraceLevel -> Int
TraceLevel -> [TraceLevel]
TraceLevel -> TraceLevel
TraceLevel -> TraceLevel -> [TraceLevel]
TraceLevel -> TraceLevel -> TraceLevel -> [TraceLevel]
(TraceLevel -> TraceLevel)
-> (TraceLevel -> TraceLevel)
-> (Int -> TraceLevel)
-> (TraceLevel -> Int)
-> (TraceLevel -> [TraceLevel])
-> (TraceLevel -> TraceLevel -> [TraceLevel])
-> (TraceLevel -> TraceLevel -> [TraceLevel])
-> (TraceLevel -> TraceLevel -> TraceLevel -> [TraceLevel])
-> Enum TraceLevel
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: TraceLevel -> TraceLevel
succ :: TraceLevel -> TraceLevel
$cpred :: TraceLevel -> TraceLevel
pred :: TraceLevel -> TraceLevel
$ctoEnum :: Int -> TraceLevel
toEnum :: Int -> TraceLevel
$cfromEnum :: TraceLevel -> Int
fromEnum :: TraceLevel -> Int
$cenumFrom :: TraceLevel -> [TraceLevel]
enumFrom :: TraceLevel -> [TraceLevel]
$cenumFromThen :: TraceLevel -> TraceLevel -> [TraceLevel]
enumFromThen :: TraceLevel -> TraceLevel -> [TraceLevel]
$cenumFromTo :: TraceLevel -> TraceLevel -> [TraceLevel]
enumFromTo :: TraceLevel -> TraceLevel -> [TraceLevel]
$cenumFromThenTo :: TraceLevel -> TraceLevel -> TraceLevel -> [TraceLevel]
enumFromThenTo :: TraceLevel -> TraceLevel -> TraceLevel -> [TraceLevel]
Enum)

traceLevelToChar :: TraceLevel -> T.Text
traceLevelToChar :: TraceLevel -> Text
traceLevelToChar = \case
  TraceLevel
Trace -> Text
"-"
  TraceLevel
Info -> Text
""
  TraceLevel
Warning -> Text
"!"
  TraceLevel
Error -> Text
"|"
  TraceLevel
TracingDisabled -> Text
"#"

charToLevel :: String -> (TraceLevel, String)
charToLevel :: String -> (TraceLevel, String)
charToLevel [] = (TraceLevel
Info, String
"")
charToLevel s :: String
s@(Char
l:String
m)=
  case Char
l of
    Char
'-' -> (TraceLevel
Trace, String
m)
    Char
'!' -> (TraceLevel
Warning, String
m)
    Char
'|' -> (TraceLevel
Error, String
m)
    Char
'#' -> (TraceLevel
TracingDisabled, String
m)
    Char
_   -> (TraceLevel
Info,  String
s)

data HaskellModulePrefixP

data LeveledModulePrefix
  = LeveledModulePrefix
    { LeveledModulePrefix -> TraceLevel
level :: TraceLevel
    , LeveledModulePrefix -> Text
modulePrefix :: T.Text
    } deriving (LeveledModulePrefix -> LeveledModulePrefix -> Bool
(LeveledModulePrefix -> LeveledModulePrefix -> Bool)
-> (LeveledModulePrefix -> LeveledModulePrefix -> Bool)
-> Eq LeveledModulePrefix
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LeveledModulePrefix -> LeveledModulePrefix -> Bool
== :: LeveledModulePrefix -> LeveledModulePrefix -> Bool
$c/= :: LeveledModulePrefix -> LeveledModulePrefix -> Bool
/= :: LeveledModulePrefix -> LeveledModulePrefix -> Bool
Eq, Int -> LeveledModulePrefix -> ShowS
[LeveledModulePrefix] -> ShowS
LeveledModulePrefix -> String
(Int -> LeveledModulePrefix -> ShowS)
-> (LeveledModulePrefix -> String)
-> ([LeveledModulePrefix] -> ShowS)
-> Show LeveledModulePrefix
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeveledModulePrefix -> ShowS
showsPrec :: Int -> LeveledModulePrefix -> ShowS
$cshow :: LeveledModulePrefix -> String
show :: LeveledModulePrefix -> String
$cshowList :: [LeveledModulePrefix] -> ShowS
showList :: [LeveledModulePrefix] -> ShowS
Show, (forall x. LeveledModulePrefix -> Rep LeveledModulePrefix x)
-> (forall x. Rep LeveledModulePrefix x -> LeveledModulePrefix)
-> Generic LeveledModulePrefix
forall x. Rep LeveledModulePrefix x -> LeveledModulePrefix
forall x. LeveledModulePrefix -> Rep LeveledModulePrefix x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LeveledModulePrefix -> Rep LeveledModulePrefix x
from :: forall x. LeveledModulePrefix -> Rep LeveledModulePrefix x
$cto :: forall x. Rep LeveledModulePrefix x -> LeveledModulePrefix
to :: forall x. Rep LeveledModulePrefix x -> LeveledModulePrefix
Generic)

instance Predicate HaskellModulePrefixP LeveledModulePrefix where
  validate :: Proxy HaskellModulePrefixP
-> LeveledModulePrefix -> Maybe RefineException
validate Proxy HaskellModulePrefixP
pr LeveledModulePrefix
p = case Text -> Maybe (Char, Text)
T.uncons LeveledModulePrefix
p.modulePrefix of
    Maybe (Char, Text)
Nothing -> Maybe RefineException
forall a. Maybe a
Nothing
    Just (Char, Text)
_
      | (Char -> Bool) -> Text -> Bool
T.any (\Char
c -> Bool -> Bool
not (Char -> Bool
isAlphaNum Char
c) Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') LeveledModulePrefix
p.modulePrefix ->
          TypeRep -> Text -> Maybe RefineException
throwRefineOtherException (Proxy HaskellModulePrefixP -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy HaskellModulePrefixP
pr)
            (Text
"Module prefix can contain letters, digits, dots and underbars only but: ["
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeveledModulePrefix
p.modulePrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")
      | (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isUpper (Char -> Bool) -> (Text -> Char) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, Text) -> Char
forall a b. (a, b) -> a
fst ((Char, Text) -> Char) -> (Text -> (Char, Text)) -> Text -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, Text) -> Maybe (Char, Text) -> (Char, Text)
forall a. a -> Maybe a -> a
fromMaybe (Char
'A', Text
"") (Maybe (Char, Text) -> (Char, Text))
-> (Text -> Maybe (Char, Text)) -> Text -> (Char, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (Char, Text)
T.uncons) ([Text] -> Bool) -> [Text] -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') LeveledModulePrefix
p.modulePrefix ->
          TypeRep -> Text -> Maybe RefineException
throwRefineOtherException (Proxy HaskellModulePrefixP -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy HaskellModulePrefixP
pr)
                 (Text
"Module prefix segment should start with a capital letter but: ["
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeveledModulePrefix
p.modulePrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")
      | Bool
otherwise -> Maybe RefineException
forall a. Maybe a
Nothing

instance Predicate HaskellModulePrefixP [LeveledModulePrefix] where
  validate :: Proxy HaskellModulePrefixP
-> [LeveledModulePrefix] -> Maybe RefineException
validate Proxy HaskellModulePrefixP
pr [LeveledModulePrefix]
pp = Maybe (Maybe RefineException) -> Maybe RefineException
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe RefineException) -> Maybe RefineException)
-> Maybe (Maybe RefineException) -> Maybe RefineException
forall a b. (a -> b) -> a -> b
$ (Maybe RefineException -> Bool)
-> [Maybe RefineException] -> Maybe (Maybe RefineException)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find Maybe RefineException -> Bool
forall a. Maybe a -> Bool
isJust (Proxy HaskellModulePrefixP
-> LeveledModulePrefix -> Maybe RefineException
forall {k} (p :: k) x.
Predicate p x =>
Proxy p -> x -> Maybe RefineException
validate Proxy HaskellModulePrefixP
pr(LeveledModulePrefix -> Maybe RefineException)
-> [LeveledModulePrefix] -> [Maybe RefineException]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LeveledModulePrefix]
pp)

instance ToJSON LeveledModulePrefix where
  toJSON :: LeveledModulePrefix -> Value
toJSON LeveledModulePrefix
o = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ TraceLevel -> Text
traceLevelToChar LeveledModulePrefix
o.level Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> LeveledModulePrefix
o.modulePrefix
instance FromJSON LeveledModulePrefix where
  parseJSON :: Value -> Parser LeveledModulePrefix
parseJSON (String Text
x) =
    LeveledModulePrefix -> Parser LeveledModulePrefix
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LeveledModulePrefix -> Parser LeveledModulePrefix)
-> (String -> LeveledModulePrefix)
-> String
-> Parser LeveledModulePrefix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TraceLevel -> Text -> LeveledModulePrefix)
-> (TraceLevel, Text) -> LeveledModulePrefix
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TraceLevel -> Text -> LeveledModulePrefix
LeveledModulePrefix ((TraceLevel, Text) -> LeveledModulePrefix)
-> (String -> (TraceLevel, Text)) -> String -> LeveledModulePrefix
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text) -> (TraceLevel, String) -> (TraceLevel, Text)
forall a b. (a -> b) -> (TraceLevel, a) -> (TraceLevel, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
T.pack ((TraceLevel, String) -> (TraceLevel, Text))
-> (String -> (TraceLevel, String)) -> String -> (TraceLevel, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> (TraceLevel, String)
charToLevel (String -> Parser LeveledModulePrefix)
-> String -> Parser LeveledModulePrefix
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
x
  parseJSON Value
o =
    String -> Parser LeveledModulePrefix
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser LeveledModulePrefix)
-> String -> Parser LeveledModulePrefix
forall a b. (a -> b) -> a -> b
$ String
"Failed to parse [" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
o
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"] as LeveledModulePrefix because String is expected"