{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

module Restyler.Config.ExpectedKeys
    ( genericParseJSONValidated
    , validateObjectKeys
    , validateExpectedKeyBy
    )
where

import Restyler.Prelude

import Data.Aeson
import Data.Aeson.Types
import qualified Data.HashMap.Strict as HM
import GHC.Generics
import GHC.Generics.Selectors
import Text.EditDistance

genericParseJSONValidated
    :: forall a
     . (Generic a, GFromJSON Zero (Rep a), Selectors (Rep a))
    => Options
    -> Value
    -> Parser a
genericParseJSONValidated :: Options -> Value -> Parser a
genericParseJSONValidated opts :: Options
opts = \case
    v :: Value
v@(Object o :: Object
o) -> do
        let keys :: [String]
keys = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Options -> String -> String
fieldLabelModifier Options
opts) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ Proxy (Rep a) -> [String]
forall k (rep :: k). Selectors rep => Proxy rep -> [String]
selectors (Proxy (Rep a)
forall k (t :: k). Proxy t
Proxy @(Rep a))
        [String] -> Object -> Parser ()
forall v. [String] -> HashMap Text v -> Parser ()
validateObjectKeys [String]
keys Object
o
        Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
opts Value
v
    v :: Value
v -> Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
opts Value
v

-- | Validate there are no unexpected keys in an Object
--
-- This is provided for convenience in the most common use-case. For a more
-- flexible interface, see @'validateExpectedKeyBy'@.
--
validateObjectKeys :: [String] -> HashMap Text v -> Parser ()
validateObjectKeys :: [String] -> HashMap Text v -> Parser ()
validateObjectKeys ks :: [String]
ks =
    [String] -> Parser ()
forall (f :: * -> *). MonadFail f => [String] -> f ()
toParser
        ([String] -> Parser ())
-> (HashMap Text v -> [String]) -> HashMap Text v -> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either String String] -> [String]
forall a b. [Either a b] -> [a]
lefts
        ([Either String String] -> [String])
-> (HashMap Text v -> [Either String String])
-> HashMap Text v
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Either String String) -> [Text] -> [Either String String]
forall a b. (a -> b) -> [a] -> [b]
map (String
-> (String -> String) -> [String] -> String -> Either String String
forall a.
String -> (a -> String) -> [a] -> String -> Either String a
validateExpectedKeyBy "key" String -> String
forall a. a -> a
id [String]
ks (String -> Either String String)
-> (Text -> String) -> Text -> Either String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack)
        ([Text] -> [Either String String])
-> (HashMap Text v -> [Text])
-> HashMap Text v
-> [Either String String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Text v -> [Text]
forall k v. HashMap k v -> [k]
HM.keys
  where
    toParser :: [String] -> f ()
toParser [] = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    toParser xs :: [String]
xs = String -> f ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> f ()) -> String -> f ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ("- " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) [String]
xs

-- | Validate that a key is present in a list of (projected) items
--
-- Returns the item found when validation passes.
--
validateExpectedKeyBy
    :: String
    -- ^ The label to show as /Unknown \<label> .../
    -> (a -> String)
    -- ^ A function to project each valid value as a comparable key
    -> [a]
    -- ^ The input list of valid items
    -> String
    -- ^ The input key
    -> Either String a
validateExpectedKeyBy :: String -> (a -> String) -> [a] -> String -> Either String a
validateExpectedKeyBy label :: String
label f :: a -> String
f as :: [a]
as k :: String
k = String -> Maybe a -> Either String a
forall a b. a -> Maybe b -> Either a b
note String
msg (Maybe a -> Either String a) -> Maybe a -> Either String a
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
k) (String -> Bool) -> (a -> String) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
f) [a]
as
  where
    ks :: [String]
ks = (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
f [a]
as
    msg :: String
msg = "Unexpected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
label String -> String -> String
forall a. Semigroup a => a -> a -> a
<> " " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
forall a. Show a => a -> String
show String
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ", " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        ("must be one of " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show [String]
ks String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ".")
        (("did you mean " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "?") (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show)
        (do
            (k' :: String
k', d :: Int
d) <- String -> [String] -> Maybe (String, Int)
nearestElem String
k [String]
ks
            Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
k Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2
            String -> Maybe String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
k'
        )

nearestElem :: String -> [String] -> Maybe (String, Int)
nearestElem :: String -> [String] -> Maybe (String, Int)
nearestElem x :: String
x = ((String, Int) -> (String, Int) -> Ordering)
-> [(String, Int)] -> Maybe (String, Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> Maybe a
minimumByMaybe (Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((String, Int) -> Int)
-> (String, Int)
-> (String, Int)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (String, Int) -> Int
forall a b. (a, b) -> b
snd) ([(String, Int)] -> Maybe (String, Int))
-> ([String] -> [(String, Int)]) -> [String] -> Maybe (String, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> (String, Int)) -> [String] -> [(String, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
forall a. a -> a
id (String -> String) -> (String -> Int) -> String -> (String, Int)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& String -> String -> Int
editDistance String
x)

editDistance :: String -> String -> Int
editDistance :: String -> String -> Int
editDistance = EditCosts -> String -> String -> Int
levenshteinDistance EditCosts
defaultEditCosts