-- | Provides types for the legend functionality.
module Shrun.Configuration.Legend
  ( -- * Parsing
    linesToMap,
    LegendMap,
    DuplicateKeyError (..),

    -- * Translation
    translateCommands,
    CyclicKeyError (..),
  )
where

import Data.HashMap.Strict qualified as Map
import Data.HashSet (HashSet)
import Data.HashSet qualified as Set
import Data.Sequence.NonEmpty qualified as NESeq
import Data.Text.Lazy qualified as LazyT
import Data.Text.Lazy.Builder (Builder)
import Data.Text.Lazy.Builder qualified as LTBuilder
import Shrun.Configuration.Toml.Legend (KeyVal (MkKeyVal), LegendMap)
import Shrun.Data.Command (CommandP (MkCommandP), CommandP1)
import Shrun.Prelude

-- $setup
-- >>> import Shrun.Prelude
-- >>> import Data.HashMap.Strict qualified as Map

-- | Errors when parsing the legend.
newtype DuplicateKeyError = MkDuplicateKeyError Text
  deriving stock (DuplicateKeyError -> DuplicateKeyError -> Bool
(DuplicateKeyError -> DuplicateKeyError -> Bool)
-> (DuplicateKeyError -> DuplicateKeyError -> Bool)
-> Eq DuplicateKeyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DuplicateKeyError -> DuplicateKeyError -> Bool
== :: DuplicateKeyError -> DuplicateKeyError -> Bool
$c/= :: DuplicateKeyError -> DuplicateKeyError -> Bool
/= :: DuplicateKeyError -> DuplicateKeyError -> Bool
Eq, Int -> DuplicateKeyError -> ShowS
[DuplicateKeyError] -> ShowS
DuplicateKeyError -> String
(Int -> DuplicateKeyError -> ShowS)
-> (DuplicateKeyError -> String)
-> ([DuplicateKeyError] -> ShowS)
-> Show DuplicateKeyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DuplicateKeyError -> ShowS
showsPrec :: Int -> DuplicateKeyError -> ShowS
$cshow :: DuplicateKeyError -> String
show :: DuplicateKeyError -> String
$cshowList :: [DuplicateKeyError] -> ShowS
showList :: [DuplicateKeyError] -> ShowS
Show)

instance Exception DuplicateKeyError where
  displayException :: DuplicateKeyError -> String
displayException (MkDuplicateKeyError Text
k) = String
"Legend error: found duplicate key: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
k

-- | Attempts to parse the given ['KeyVal'] into 'LegendMap'.
-- Duplicate keys are not allowed.
linesToMap :: List KeyVal -> Either DuplicateKeyError LegendMap
linesToMap :: List KeyVal -> Either DuplicateKeyError LegendMap
linesToMap = (KeyVal
 -> Either DuplicateKeyError LegendMap
 -> Either DuplicateKeyError LegendMap)
-> Either DuplicateKeyError LegendMap
-> List KeyVal
-> Either DuplicateKeyError LegendMap
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr KeyVal
-> Either DuplicateKeyError LegendMap
-> Either DuplicateKeyError LegendMap
f (LegendMap -> Either DuplicateKeyError LegendMap
forall a b. b -> Either a b
Right LegendMap
forall k v. HashMap k v
Map.empty)
  where
    f :: KeyVal
-> Either DuplicateKeyError LegendMap
-> Either DuplicateKeyError LegendMap
f (MkKeyVal Text
k NESeq Text
v) Either DuplicateKeyError LegendMap
mp = Either DuplicateKeyError (Either DuplicateKeyError LegendMap)
-> Either DuplicateKeyError LegendMap
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (Either DuplicateKeyError (Either DuplicateKeyError LegendMap)
 -> Either DuplicateKeyError LegendMap)
-> Either DuplicateKeyError (Either DuplicateKeyError LegendMap)
-> Either DuplicateKeyError LegendMap
forall a b. (a -> b) -> a -> b
$ ((Text, NESeq Text)
 -> LegendMap -> Either DuplicateKeyError LegendMap)
-> Either DuplicateKeyError (Text, NESeq Text)
-> Either DuplicateKeyError LegendMap
-> Either DuplicateKeyError (Either DuplicateKeyError LegendMap)
forall a b c.
(a -> b -> c)
-> Either DuplicateKeyError a
-> Either DuplicateKeyError b
-> Either DuplicateKeyError c
forall (f :: Type -> Type) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (Text, NESeq Text)
-> LegendMap -> Either DuplicateKeyError LegendMap
forall {v}.
(Text, v)
-> HashMap Text v -> Either DuplicateKeyError (HashMap Text v)
insertPair ((Text, NESeq Text) -> Either DuplicateKeyError (Text, NESeq Text)
forall a b. b -> Either a b
Right (Text
k, NESeq Text
v)) Either DuplicateKeyError LegendMap
mp
    insertPair :: (Text, v)
-> HashMap Text v -> Either DuplicateKeyError (HashMap Text v)
insertPair (Text
key, v
cmd) HashMap Text v
mp =
      case Text -> HashMap Text v -> Maybe v
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
key HashMap Text v
mp of
        Just v
_ -> DuplicateKeyError -> Either DuplicateKeyError (HashMap Text v)
forall a b. a -> Either a b
Left (DuplicateKeyError -> Either DuplicateKeyError (HashMap Text v))
-> DuplicateKeyError -> Either DuplicateKeyError (HashMap Text v)
forall a b. (a -> b) -> a -> b
$ Text -> DuplicateKeyError
MkDuplicateKeyError Text
key
        Maybe v
Nothing -> HashMap Text v -> Either DuplicateKeyError (HashMap Text v)
forall a b. b -> Either a b
Right (HashMap Text v -> Either DuplicateKeyError (HashMap Text v))
-> HashMap Text v -> Either DuplicateKeyError (HashMap Text v)
forall a b. (a -> b) -> a -> b
$ Text -> v -> HashMap Text v -> HashMap Text v
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Text
key v
cmd HashMap Text v
mp

newtype CyclicKeyError = MkCyclicKeyError Text
  deriving stock (CyclicKeyError -> CyclicKeyError -> Bool
(CyclicKeyError -> CyclicKeyError -> Bool)
-> (CyclicKeyError -> CyclicKeyError -> Bool) -> Eq CyclicKeyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CyclicKeyError -> CyclicKeyError -> Bool
== :: CyclicKeyError -> CyclicKeyError -> Bool
$c/= :: CyclicKeyError -> CyclicKeyError -> Bool
/= :: CyclicKeyError -> CyclicKeyError -> Bool
Eq, Int -> CyclicKeyError -> ShowS
[CyclicKeyError] -> ShowS
CyclicKeyError -> String
(Int -> CyclicKeyError -> ShowS)
-> (CyclicKeyError -> String)
-> ([CyclicKeyError] -> ShowS)
-> Show CyclicKeyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CyclicKeyError -> ShowS
showsPrec :: Int -> CyclicKeyError -> ShowS
$cshow :: CyclicKeyError -> String
show :: CyclicKeyError -> String
$cshowList :: [CyclicKeyError] -> ShowS
showList :: [CyclicKeyError] -> ShowS
Show)

instance Exception CyclicKeyError where
  displayException :: CyclicKeyError -> String
displayException (MkCyclicKeyError Text
path) =
    String
"Encountered cyclic definitions when translating commands: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
path

-- | Returns a list of 'Text' commands, potentially transforming a
-- given string via the `LegendMap` @legend@.
--
-- Given a command string /s/, we first check if /s/ exists as a key in
-- @legend@. If it does not, we return /s/. If there is a key matching
-- /s/, i.e.,
--
-- @
-- legend = fromList [...,(s, v),...]
-- @
--
-- where \(v = v_1,,\ldots,,v_n\), then we recursively search on each
-- \(v_i\). We stop and return \(v_i\) when it does not exist as a key in the
-- map.
--
-- ==== __Examples__
-- >>> :set -XOverloadedLists
-- >>> :{
--   let m = Map.fromList
--         [ ("cmd1", "one" :<|| []),
--           ("cmd2", "two" :<|| []),
--           ("all", "cmd1" :<|| ["cmd2","other"])
--         ]
--       cmds = translateCommands m ("all" :<|| ["blah"])
--   in (fmap . fmap) (view #command) cmds
-- :}
-- Right (fromList ("one" :| ["two","other","blah"]))
--
-- Note: If -- when looking up a line -- we detect a cycle, then a 'CyclicKeyError'
-- will be returned.
--
-- >>> :{
--   let m = Map.fromList
--         [ ("a", "b" :<|| []),
--           ("b", "c" :<|| []),
--           ("c", "a" :<|| [])
--         ]
--   in translateCommands m ("a" :<|| [])
-- :}
-- Left (MkCyclicKeyError "a -> b -> c -> a")
translateCommands :: LegendMap -> NESeq Text -> Either CyclicKeyError (NESeq CommandP1)
translateCommands :: LegendMap -> NESeq Text -> Either CyclicKeyError (NESeq CommandP1)
translateCommands LegendMap
mp NESeq Text
ts = NESeq (NESeq CommandP1) -> NESeq CommandP1
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (NESeq (NESeq CommandP1) -> NESeq CommandP1)
-> Either CyclicKeyError (NESeq (NESeq CommandP1))
-> Either CyclicKeyError (NESeq CommandP1)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Either CyclicKeyError (NESeq CommandP1))
-> NESeq Text -> Either CyclicKeyError (NESeq (NESeq CommandP1))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> NESeq a -> f (NESeq b)
traverse (LegendMap -> Text -> Either CyclicKeyError (NESeq CommandP1)
lineToCommands LegendMap
mp) NESeq Text
ts

lineToCommands :: LegendMap -> Text -> Either CyclicKeyError (NESeq CommandP1)
lineToCommands :: LegendMap -> Text -> Either CyclicKeyError (NESeq CommandP1)
lineToCommands LegendMap
mp = Maybe Text
-> HashSet Text
-> Builder
-> Text
-> Either CyclicKeyError (NESeq CommandP1)
go Maybe Text
forall a. Maybe a
Nothing HashSet Text
forall a. HashSet a
Set.empty (Text -> Builder
LTBuilder.fromText Text
"")
  where
    -- The stringbuilder path is a textual representation of the key path
    -- we have traversed so far, e.g., a -> b -> c
    go :: Maybe Text -> HashSet Text -> Builder -> Text -> Either CyclicKeyError (NESeq CommandP1)
    go :: Maybe Text
-> HashSet Text
-> Builder
-> Text
-> Either CyclicKeyError (NESeq CommandP1)
go Maybe Text
prevKey HashSet Text
foundKeys Builder
path Text
line = case Text -> LegendMap -> Maybe (NESeq Text)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text
line LegendMap
mp of
      -- The line isn't a key, return it.
      Maybe (NESeq Text)
Nothing -> NESeq CommandP1 -> Either CyclicKeyError (NESeq CommandP1)
forall a b. b -> Either a b
Right (NESeq CommandP1 -> Either CyclicKeyError (NESeq CommandP1))
-> NESeq CommandP1 -> Either CyclicKeyError (NESeq CommandP1)
forall a b. (a -> b) -> a -> b
$ CommandP1 -> NESeq CommandP1
forall a. a -> NESeq a
NESeq.singleton (Maybe Text -> Text -> CommandP1
forall (p :: CommandPhase). Maybe Text -> Text -> CommandP p
MkCommandP Maybe Text
prevKey Text
line)
      -- The line is a key, check for cycles and recursively
      -- call.
      Just NESeq Text
val -> case Maybe Text
maybeCyclicVal of
        Just Text
cyclicVal ->
          let pathTxt :: Text
pathTxt = Builder -> Text -> Text -> Text
builderToPath Builder
path Text
line Text
cyclicVal
           in CyclicKeyError -> Either CyclicKeyError (NESeq CommandP1)
forall a b. a -> Either a b
Left (CyclicKeyError -> Either CyclicKeyError (NESeq CommandP1))
-> CyclicKeyError -> Either CyclicKeyError (NESeq CommandP1)
forall a b. (a -> b) -> a -> b
$ Text -> CyclicKeyError
MkCyclicKeyError Text
pathTxt
        Maybe Text
Nothing -> case NESeq Text
val of
          -- NOTE: We have to split these cases up due to handling the prevKey
          -- differently. We want to pass along the key name (i.e. line)
          -- iff we have exactly one value i.e. key = val. We do _not_ want to
          -- pass this in if we have a list i.e. key = [val1, val2, ...].
          --
          -- If we did, the command output would have:
          --   [Success][all] N seconds
          --   [Success][all] N seconds
          --   ...
          --
          -- That is, we would have multiple commands sharing the same key
          -- name, hence the output would be ambiguous. To prevent this, only
          -- pass the name in when it is guaranteed we have a unique
          -- key = val mapping.
          (Text
x :<|| Seq Text
IsEmpty) -> Maybe Text
-> HashSet Text
-> Builder
-> Text
-> Either CyclicKeyError (NESeq CommandP1)
go (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
line) HashSet Text
foundKeys' Builder
path' Text
x
          NESeq Text
xs -> NESeq (NESeq CommandP1) -> NESeq CommandP1
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (NESeq (NESeq CommandP1) -> NESeq CommandP1)
-> Either CyclicKeyError (NESeq (NESeq CommandP1))
-> Either CyclicKeyError (NESeq CommandP1)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Either CyclicKeyError (NESeq CommandP1))
-> NESeq Text -> Either CyclicKeyError (NESeq (NESeq CommandP1))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> NESeq a -> f (NESeq b)
traverse (Maybe Text
-> HashSet Text
-> Builder
-> Text
-> Either CyclicKeyError (NESeq CommandP1)
go Maybe Text
forall a. Maybe a
Nothing HashSet Text
foundKeys' Builder
path') NESeq Text
xs
        where
          foundKeys' :: HashSet Text
foundKeys' = Text -> HashSet Text -> HashSet Text
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
Set.insert Text
line HashSet Text
foundKeys
          -- Detect if we have an intersection between previously found
          -- keys and the values we just found. If so we have found a
          -- cyclic error.
          intersect :: HashSet Text
intersect = HashSet Text -> HashSet Text -> HashSet Text
forall a. Eq a => HashSet a -> HashSet a -> HashSet a
Set.intersection HashSet Text
foundKeys (NESeq Text -> HashSet Text
neToSet NESeq Text
val)
          -- If there are cycles then this should be `Just cyclicVal`
          -- (this list should have at most one since we are detecting
          -- the first cycle)
          maybeCyclicVal :: Maybe Text
maybeCyclicVal = [Text] -> Maybe Text
forall (f :: Type -> Type) a. Foldable f => f a -> Maybe a
headMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ HashSet Text -> [Text]
forall a. HashSet a -> [a]
Set.toList HashSet Text
intersect
          path' :: Builder
path' = Builder
path Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
LTBuilder.fromText Text
line Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" -> "
          neToSet :: NESeq Text -> HashSet Text
neToSet = [Text] -> HashSet Text
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([Text] -> HashSet Text)
-> (NESeq Text -> [Text]) -> NESeq Text -> HashSet Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NESeq Text -> [Text]
forall a. NESeq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList

builderToPath :: Builder -> Text -> Text -> Text
builderToPath :: Builder -> Text -> Text -> Text
builderToPath Builder
path Text
l Text
v =
  LazyText -> Text
LazyT.toStrict
    (LazyText -> Text) -> LazyText -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> LazyText
LTBuilder.toLazyText
    (Builder -> LazyText) -> Builder -> LazyText
forall a b. (a -> b) -> a -> b
$ Builder
path
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
LTBuilder.fromText Text
l
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" -> "
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
LTBuilder.fromText Text
v