{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- A random collection of small, useful functions that are (or could
-- be) used throughout the code base.
module Swarm.Util (
  -- * Miscellaneous utilities
  (?),
  sortPair,
  maxOn,
  maximum0,
  cycleEnum,
  listEnums,
  listEnumsNonempty,
  showEnum,
  indexWrapNonEmpty,
  uniq,
  binTuples,
  histogram,
  findDup,
  both,
  allEqual,
  surfaceEmpty,
  applyWhen,
  hoistMaybe,
  unsnocNE,

  -- * Directory utilities
  readFileMay,
  readFileMayT,
  acquireAllWithExt,

  -- * Text utilities
  isIdentChar,
  replaceLast,
  failT,
  showT,
  showLowT,

  -- * English language utilities
  reflow,
  quote,
  squote,
  bquote,
  parens,
  brackets,
  commaList,
  indefinite,
  indefiniteQ,
  singularSubjectVerb,
  plural,
  number,

  -- * Validation utilities
  holdsOr,
  isJustOr,
  isRightOr,
  isSuccessOr,

  -- * Template Haskell utilities
  liftText,

  -- * Lens utilities
  (%%=),
  (<%=),
  (<+=),
  (<<.=),
  (<>=),
  _NonEmpty,

  -- * Set utilities
  removeSupersets,
  smallHittingSet,
) where

import Control.Applicative (Alternative)
import Control.Carrier.Throw.Either
import Control.Effect.State (State, modify, state)
import Control.Lens (ASetter', Lens', LensLike, LensLike', Over, lens, (<&>), (<>~))
import Control.Monad (filterM, guard, unless)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.Bifunctor (Bifunctor (bimap), first)
import Data.Char (isAlphaNum, toLower)
import Data.Either.Validation
import Data.List (foldl', maximumBy, partition)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NE
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
import Data.Set (Set)
import Data.Set qualified as S
import Data.Text (Text, toUpper)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Tuple (swap)
import Data.Yaml
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (lift)
import NLP.Minimorph.English qualified as MM
import NLP.Minimorph.Util ((<+>))
import System.Clock (TimeSpec)
import System.Directory (doesDirectoryExist, doesFileExist, listDirectory)
import System.FilePath (takeExtension, (</>))
import System.IO.Error (catchIOError)
import Witch (from)

infixr 1 ?
infix 4 %%=, <+=, <%=, <<.=, <>=

-- | A convenient infix flipped version of 'fromMaybe': @Just a ? b =
--   a@, and @Nothing ? b = b@. It can also be chained, as in @x ? y ?
--   z ? def@, which takes the value inside the first @Just@,
--   defaulting to @def@ as a last resort.
(?) :: Maybe a -> a -> a
? :: forall a. Maybe a -> a -> a
(?) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. a -> Maybe a -> a
fromMaybe

-- | Ensure the smaller value in a pair is the first element.
sortPair :: Ord b => (b, b) -> (b, b)
sortPair :: forall b. Ord b => (b, b) -> (b, b)
sortPair (b
x, b
y) = if b
x forall a. Ord a => a -> a -> Bool
<= b
y then (b
x, b
y) else (b
y, b
x)

-- | Find the maximum of two values, comparing them according to a
--   custom projection function.
maxOn :: Ord b => (a -> b) -> a -> a -> a
maxOn :: forall b a. Ord b => (a -> b) -> a -> a -> a
maxOn a -> b
f a
x a
y
  | a -> b
f a
x forall a. Ord a => a -> a -> Bool
> a -> b
f a
y = a
x
  | Bool
otherwise = a
y

-- | Find the maximum of a list of numbers, defaulting to 0 if the
--   list is empty.
maximum0 :: (Num a, Ord a) => [a] -> a
maximum0 :: forall a. (Num a, Ord a) => [a] -> a
maximum0 [] = a
0
maximum0 [a]
xs = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [a]
xs

-- | Take the successor of an 'Enum' type, wrapping around when it
--   reaches the end.
cycleEnum :: (Eq e, Enum e, Bounded e) => e -> e
cycleEnum :: forall e. (Eq e, Enum e, Bounded e) => e -> e
cycleEnum e
e
  | e
e forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
maxBound = forall a. Bounded a => a
minBound
  | Bool
otherwise = forall a. Enum a => a -> a
succ e
e

listEnums :: (Enum e, Bounded e) => [e]
listEnums :: forall e. (Enum e, Bounded e) => [e]
listEnums = [forall a. Bounded a => a
minBound .. forall a. Bounded a => a
maxBound]

-- | Members of the Bounded class are guaranteed to
-- have at least one element.
listEnumsNonempty :: (Enum e, Bounded e) => NonEmpty e
listEnumsNonempty :: forall e. (Enum e, Bounded e) => NonEmpty e
listEnumsNonempty = forall a. [a] -> NonEmpty a
NE.fromList forall e. (Enum e, Bounded e) => [e]
listEnums

-- | We know by the syntax rules of Haskell that constructor
--  names must consist of one or more symbols!
showEnum :: (Show e, Enum e) => e -> NonEmpty Char
showEnum :: forall e. (Show e, Enum e) => e -> NonEmpty Char
showEnum = forall a. [a] -> NonEmpty a
NE.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- | Guaranteed to yield an element of the list.
--
-- This is true even if the supplied @index@ is negative,
-- since 'mod' always satisfies @0 <= a `mod` b < b@
-- when @b@ is positive
-- (see <comment https://github.com/swarm-game/swarm/pull/1181#discussion_r1151177735>).
indexWrapNonEmpty ::
  Integral b =>
  NonEmpty a ->
  -- | index
  b ->
  a
indexWrapNonEmpty :: forall b a. Integral b => NonEmpty a -> b -> a
indexWrapNonEmpty NonEmpty a
list b
idx =
  forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
list forall a. [a] -> Int -> a
!! forall a b. (Integral a, Num b) => a -> b
fromIntegral b
wrappedIdx
 where
  wrappedIdx :: b
wrappedIdx = b
idx forall a. Integral a => a -> a -> a
`mod` forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. NonEmpty a -> Int
NE.length NonEmpty a
list)

-- | Drop repeated elements that are adjacent to each other.
--
-- >>> uniq []
-- []
-- >>> uniq [1..5]
-- [1,2,3,4,5]
-- >>> uniq (replicate 10 'a')
-- "a"
-- >>> uniq "abbbccd"
-- "abcd"
uniq :: Eq a => [a] -> [a]
uniq :: forall a. Eq a => [a] -> [a]
uniq = \case
  [] -> []
  (a
x : [a]
xs) -> a
x forall a. a -> [a] -> [a]
: forall a. Eq a => [a] -> [a]
uniq (forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== a
x) [a]
xs)

-- | Place the second element of the tuples into bins by
-- the value of the first element.
binTuples ::
  (Foldable t, Ord a) =>
  t (a, b) ->
  Map a (NE.NonEmpty b)
binTuples :: forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (a, b) -> Map a (NonEmpty b) -> Map a (NonEmpty b)
f forall a. Monoid a => a
mempty
 where
  f :: (a, b) -> Map a (NonEmpty b) -> Map a (NonEmpty b)
f = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Semigroup a => a -> a -> a
(<>)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Count occurrences of a value
histogram ::
  (Foldable t, Ord a) =>
  t a ->
  Map a Int
histogram :: forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> Map a Int
histogram = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map a Int
m a
k -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Num a => a -> a -> a
(+) a
k Int
1 Map a Int
m) forall k a. Map k a
M.empty

-- | Find a duplicate element within the list, if any exists.
findDup :: Ord a => [a] -> Maybe a
findDup :: forall a. Ord a => [a] -> Maybe a
findDup = forall {a}. Ord a => Set a -> [a] -> Maybe a
go forall a. Set a
S.empty
 where
  go :: Set a -> [a] -> Maybe a
go Set a
_ [] = forall a. Maybe a
Nothing
  go Set a
seen (a
a : [a]
as)
    | a
a forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
seen = forall a. a -> Maybe a
Just a
a
    | Bool
otherwise = Set a -> [a] -> Maybe a
go (forall a. Ord a => a -> Set a -> Set a
S.insert a
a Set a
seen) [a]
as

both :: Bifunctor p => (a -> d) -> p a a -> p d d
both :: forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both a -> d
f = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> d
f a -> d
f

allEqual :: (Ord a) => [a] -> Bool
allEqual :: forall a. Ord a => [a] -> Bool
allEqual [] = Bool
True
allEqual (a
x : [a]
xs) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== a
x) [a]
xs

surfaceEmpty :: Alternative f => (a -> Bool) -> a -> f a
surfaceEmpty :: forall (f :: * -> *) a. Alternative f => (a -> Bool) -> a -> f a
surfaceEmpty a -> Bool
isEmpty a
t = a
t forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (a -> Bool
isEmpty a
t))

------------------------------------------------------------
-- Forward-compatibility functions

-- Note, once we upgrade to an LTS version that includes
-- base-compat-0.13, we should switch to using 'applyWhen' from there.
applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen :: forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
True a -> a
f a
x = a -> a
f a
x
applyWhen Bool
False a -> a
_ a
x = a
x

-- | Convert a 'Maybe' computation to 'MaybeT'.
--
-- TODO (#1151): Use implementation from "transformers" package v0.6.0.0
hoistMaybe :: (Applicative m) => Maybe b -> MaybeT m b
hoistMaybe :: forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe = forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe'
--
-- Taken from Cabal-syntax Distribution.Utils.Generic.
--
-- Example:
-- >>> import Data.List.NonEmpty (NonEmpty ((:|)))
-- >>> unsnocNE (1 :| [2, 3])
-- ([1,2],3)
--
-- >>> unsnocNE (1 :| [])
-- ([],1)
unsnocNE :: NonEmpty a -> ([a], a)
unsnocNE :: forall a. NonEmpty a -> ([a], a)
unsnocNE (a
x :| [a]
xs) = forall {a}. a -> [a] -> ([a], a)
go a
x [a]
xs
 where
  go :: a -> [a] -> ([a], a)
go a
y [] = ([], a
y)
  go a
y (a
z : [a]
zs) = let ~([a]
ws, a
w) = a -> [a] -> ([a], a)
go a
z [a]
zs in (a
y forall a. a -> [a] -> [a]
: [a]
ws, a
w)

------------------------------------------------------------
-- Directory stuff

-- | Safely attempt to read a file.
readFileMay :: FilePath -> IO (Maybe String)
readFileMay :: String -> IO (Maybe String)
readFileMay = forall a. IO a -> IO (Maybe a)
catchIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readFile

-- | Safely attempt to (efficiently) read a file.
readFileMayT :: FilePath -> IO (Maybe Text)
readFileMayT :: String -> IO (Maybe Text)
readFileMayT = forall a. IO a -> IO (Maybe a)
catchIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO Text
T.readFile

-- | Recursively acquire all files in the given directory with the
--   given extension, and their contents.
acquireAllWithExt :: FilePath -> String -> IO [(FilePath, String)]
acquireAllWithExt :: String -> String -> IO [(String, String)]
acquireAllWithExt String
dir String
ext = do
  [String]
paths <- String -> IO [String]
listDirectory String
dir forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall a b. (a -> b) -> [a] -> [b]
map (String
dir String -> String -> String
</>)
  [String]
filePaths <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\String
path -> String -> IO Bool
doesFileExist String
path forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Bool -> Bool
(&&) (String -> Bool
hasExt String
path)) [String]
paths
  [(String, String)]
children <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
path -> (,) String
path forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
path) [String]
filePaths
  -- recurse
  [String]
sub <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist [String]
paths
  [(String, String)]
transChildren <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> String -> IO [(String, String)]
`acquireAllWithExt` String
ext) [String]
sub
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(String, String)]
children forall a. Semigroup a => a -> a -> a
<> [(String, String)]
transChildren
 where
  hasExt :: String -> Bool
hasExt String
path = String -> String
takeExtension String
path forall a. Eq a => a -> a -> Bool
== (String
"." forall a. [a] -> [a] -> [a]
++ String
ext)

-- | Turns any IO error into Nothing.
catchIO :: IO a -> IO (Maybe a)
catchIO :: forall a. IO a -> IO (Maybe a)
catchIO IO a
act = (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
act) forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)

------------------------------------------------------------
-- Some Text-y stuff

-- | Predicate to test for characters which can be part of a valid
--   identifier: alphanumeric, underscore, or single quote.
--
-- >>> isIdentChar 'A' && isIdentChar 'b' && isIdentChar '9'
-- True
-- >>> isIdentChar '_' && isIdentChar '\''
-- True
-- >>> isIdentChar '$' || isIdentChar '.' || isIdentChar ' '
-- False
isIdentChar :: Char -> Bool
isIdentChar :: Char -> Bool
isIdentChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\''

-- | @replaceLast r t@ replaces the last word of @t@ with @r@.
--
-- >>> :set -XOverloadedStrings
-- >>> replaceLast "foo" "bar baz quux"
-- "bar baz foo"
-- >>> replaceLast "move" "(make"
-- "(move"
replaceLast :: Text -> Text -> Text
replaceLast :: Text -> Text -> Text
replaceLast Text
r Text
t = Text -> Text -> Text
T.append ((Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isIdentChar Text
t) Text
r

-- | Fail with a Text-based message, made out of phrases to be joined
--   by spaces.
failT :: MonadFail m => [Text] -> m a
failT :: forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source target. From source target => source -> target
from @Text forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unwords

-- | Show a value, but as Text.
showT :: Show a => a -> Text
showT :: forall a. Show a => a -> Text
showT = forall source target. From source target => source -> target
from @String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- | Show a value in all lowercase, but as Text.
showLowT :: Show a => a -> Text
showLowT :: forall a. Show a => a -> Text
showLowT = forall source target. From source target => source -> target
from @String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

------------------------------------------------------------
-- Some language-y stuff

-- | Reflow text by removing newlines and condensing whitespace.
reflow :: Text -> Text
reflow :: Text -> Text
reflow = [Text] -> Text
T.unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words

-- | Prepend a noun with the proper indefinite article (\"a\" or \"an\").
indefinite :: Text -> Text
indefinite :: Text -> Text
indefinite Text
w = Text -> Text
MM.indefiniteDet Text
w Text -> Text -> Text
<+> Text
w

-- | Prepend a noun with the proper indefinite article, and surround
--   the noun in single quotes.
indefiniteQ :: Text -> Text
indefiniteQ :: Text -> Text
indefiniteQ Text
w = Text -> Text
MM.indefiniteDet Text
w Text -> Text -> Text
<+> Text -> Text
squote Text
w

-- | Combine the subject word with the simple present tense of the verb.
--
-- Only some irregular verbs are handled, but it should be enough
-- to scrap some error message boilerplate and have fun!
--
-- >>> :set -XOverloadedStrings
-- >>> singularSubjectVerb "I" "be"
-- "I am"
-- >>> singularSubjectVerb "he" "can"
-- "he can"
-- >>> singularSubjectVerb "The target robot" "do"
-- "The target robot does"
singularSubjectVerb :: Text -> Text -> Text
singularSubjectVerb :: Text -> Text -> Text
singularSubjectVerb Text
sub Text
verb
  | Text
verb forall a. Eq a => a -> a -> Bool
== Text
"be" = case Text -> Text
toUpper Text
sub of
      Text
"I" -> Text
"I am"
      Text
"YOU" -> Text
sub Text -> Text -> Text
<+> Text
"are"
      Text
_ -> Text
sub Text -> Text -> Text
<+> Text
"is"
  | Bool
otherwise = Text
sub Text -> Text -> Text
<+> (if Bool
is3rdPerson then Text
verb3rd else Text
verb)
 where
  is3rdPerson :: Bool
is3rdPerson = Text -> Text
toUpper Text
sub forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"I", Text
"YOU"]
  verb3rd :: Text
verb3rd
    | Text
verb forall a. Eq a => a -> a -> Bool
== Text
"have" = Text
"has"
    | Text
verb forall a. Eq a => a -> a -> Bool
== Text
"can" = Text
"can"
    | Bool
otherwise = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Text -> (Text, Text)
MM.defaultVerbStuff Text
verb

-- | Pluralize a noun.
plural :: Text -> Text
plural :: Text -> Text
plural = Text -> Text
MM.defaultNounPlural

-- For now, it is just MM.defaultNounPlural, which only uses heuristics;
-- in the future, if we discover specific nouns that it gets wrong,
-- we can add a lookup table.

-- | Either pluralize a noun or not, depending on the value of the
--   number.
number :: Int -> Text -> Text
number :: Int -> Text -> Text
number Int
1 = forall a. a -> a
id
number Int
_ = Text -> Text
plural

-- | Surround some text in single quotes.
squote :: Text -> Text
squote :: Text -> Text
squote Text
t = [Text] -> Text
T.concat [Text
"'", Text
t, Text
"'"]

-- | Surround some text in double quotes.
quote :: Text -> Text
quote :: Text -> Text
quote Text
t = [Text] -> Text
T.concat [Text
"\"", Text
t, Text
"\""]

-- | Surround some text in backticks.
bquote :: Text -> Text
bquote :: Text -> Text
bquote Text
t = [Text] -> Text
T.concat [Text
"`", Text
t, Text
"`"]

-- | Surround some text in parentheses.
parens :: Text -> Text
parens :: Text -> Text
parens Text
t = [Text] -> Text
T.concat [Text
"(", Text
t, Text
")"]

-- | Surround some text in square brackets.
brackets :: Text -> Text
brackets :: Text -> Text
brackets Text
t = [Text] -> Text
T.concat [Text
"[", Text
t, Text
"]"]

-- | Make a list of things with commas and the word "and".
commaList :: [Text] -> Text
commaList :: [Text] -> Text
commaList [] = Text
""
commaList [Text
t] = Text
t
commaList [Text
s, Text
t] = [Text] -> Text
T.unwords [Text
s, Text
"and", Text
t]
commaList [Text]
ts = [Text] -> Text
T.unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
`T.append` Text
",") (forall a. [a] -> [a]
init [Text]
ts) forall a. [a] -> [a] -> [a]
++ [Text
"and", forall a. [a] -> a
last [Text]
ts]

------------------------------------------------------------
-- Some orphan instances

deriving instance FromJSON TimeSpec
deriving instance ToJSON TimeSpec

------------------------------------------------------------
-- Validation utilities

-- | Require that a Boolean value is @True@, or throw an exception.
holdsOr :: Has (Throw e) sig m => Bool -> e -> m ()
holdsOr :: forall e (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw e) sig m =>
Bool -> e -> m ()
holdsOr Bool
b e
e = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b forall a b. (a -> b) -> a -> b
$ forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError e
e

-- | Require that a 'Maybe' value is 'Just', or throw an exception.
isJustOr :: Has (Throw e) sig m => Maybe a -> e -> m a
Just a
a isJustOr :: forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
Maybe a -> e -> m a
`isJustOr` e
_ = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Maybe a
Nothing `isJustOr` e
e = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError e
e

-- | Require that an 'Either' value is 'Right', or throw an exception
--   based on the value in the 'Left'.
isRightOr :: Has (Throw e) sig m => Either b a -> (b -> e) -> m a
Right a
a isRightOr :: forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) b a.
Has (Throw e) sig m =>
Either b a -> (b -> e) -> m a
`isRightOr` b -> e
_ = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Left b
b `isRightOr` b -> e
f = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (b -> e
f b
b)

-- | Require that a 'Validation' value is 'Success', or throw an exception
--   based on the value in the 'Failure'.
isSuccessOr :: Has (Throw e) sig m => Validation b a -> (b -> e) -> m a
Success a
a isSuccessOr :: forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) b a.
Has (Throw e) sig m =>
Validation b a -> (b -> e) -> m a
`isSuccessOr` b -> e
_ = forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Failure b
b `isSuccessOr` b -> e
f = forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError (b -> e
f b
b)

------------------------------------------------------------
-- Template Haskell utilities

-- See https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
liftText :: T.Text -> Q Exp
liftText :: Text -> Q Exp
liftText Text
txt = Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'T.pack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift (Text -> String
T.unpack Text
txt)

------------------------------------------------------------
-- Fused-Effects Lens utilities

(<+=) :: (Has (State s) sig m, Num a) => LensLike' ((,) a) s a -> a -> m a
LensLike' ((,) a) s a
l <+= :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State s) sig m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= a
a = LensLike' ((,) a) s a
l forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
LensLike' ((,) a) s a -> (a -> a) -> m a
<%= (forall a. Num a => a -> a -> a
+ a
a)
{-# INLINE (<+=) #-}

(<%=) :: (Has (State s) sig m) => LensLike' ((,) a) s a -> (a -> a) -> m a
LensLike' ((,) a) s a
l <%= :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
LensLike' ((,) a) s a -> (a -> a) -> m a
<%= a -> a
f = LensLike' ((,) a) s a
l forall s (sig :: (* -> *) -> * -> *) (m :: * -> *)
       (p :: * -> * -> *) r a b.
Has (State s) sig m =>
Over p ((,) r) s s a b -> p a (r, b) -> m r
%%= (\a
b -> (a
b, a
b)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f
{-# INLINE (<%=) #-}

(%%=) :: (Has (State s) sig m) => Over p ((,) r) s s a b -> p a (r, b) -> m r
Over p ((,) r) s s a b
l %%= :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *)
       (p :: * -> * -> *) r a b.
Has (State s) sig m =>
Over p ((,) r) s s a b -> p a (r, b) -> m r
%%= p a (r, b)
f = forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
(s -> (s, a)) -> m a
state (forall a b. (a, b) -> (b, a)
swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Over p ((,) r) s s a b
l p a (r, b)
f)
{-# INLINE (%%=) #-}

(<<.=) :: (Has (State s) sig m) => LensLike ((,) a) s s a b -> b -> m a
LensLike ((,) a) s s a b
l <<.= :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a b.
Has (State s) sig m =>
LensLike ((,) a) s s a b -> b -> m a
<<.= b
b = LensLike ((,) a) s s a b
l forall s (sig :: (* -> *) -> * -> *) (m :: * -> *)
       (p :: * -> * -> *) r a b.
Has (State s) sig m =>
Over p ((,) r) s s a b -> p a (r, b) -> m r
%%= (,b
b)
{-# INLINE (<<.=) #-}

(<>=) :: (Has (State s) sig m, Semigroup a) => ASetter' s a -> a -> m ()
ASetter' s a
l <>= :: forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (State s) sig m, Semigroup a) =>
ASetter' s a -> a -> m ()
<>= a
a = forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
(s -> s) -> m ()
modify (ASetter' s a
l forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ a
a)
{-# INLINE (<>=) #-}

------------------------------------------------------------
-- Other lens utilities

_NonEmpty :: Lens' (NonEmpty a) (a, [a])
_NonEmpty :: forall a. Lens' (NonEmpty a) (a, [a])
_NonEmpty = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(a
x :| [a]
xs) -> (a
x, [a]
xs)) (forall a b. a -> b -> a
const (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. a -> [a] -> NonEmpty a
(:|)))

------------------------------------------------------------
-- Some set utilities

-- | Remove any sets which are supersets of other sets.  In other words,
--   (1) no two sets in the output are in a subset relationship
--   (2) every element in the input is a superset of some element in the output.
--
-- >>> import qualified Data.Set as S
-- >>> rss = map S.toList . S.toList . removeSupersets . S.fromList . map S.fromList
--
-- >>> rss [[1,2,3], [1]]
-- [[1]]
--
-- >>> rss [[1,2,3], [2,4], [2,3]]
-- [[2,3],[2,4]]
--
-- >>> rss [[], [1], [2,3]]
-- [[]]
--
-- >>> rss [[1,2], [1,3], [2,3]]
-- [[1,2],[1,3],[2,3]]
removeSupersets :: Ord a => Set (Set a) -> Set (Set a)
removeSupersets :: forall a. Ord a => Set (Set a) -> Set (Set a)
removeSupersets Set (Set a)
ss = forall a. (a -> Bool) -> Set a -> Set a
S.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> Bool
isSuperset) Set (Set a)
ss
 where
  isSuperset :: Set a -> Bool
isSuperset Set a
s = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Ord a => Set a -> Set a -> Bool
`S.isSubsetOf` Set a
s) (forall a. Ord a => a -> Set a -> Set a
S.delete Set a
s Set (Set a)
ss)

-- | Given a list of /nonempty/ sets, find a hitting set, that is, a
--   set which has at least one element in common with each set in the
--   list.  It is not guaranteed to be the /smallest possible/ such
--   set, because that is NP-hard.  Instead, we use a greedy algorithm
--   that will give us a reasonably small hitting set: first, choose
--   all elements in singleton sets, since those must necessarily be
--   chosen.  Now take any sets which are still not hit, and find an
--   element which occurs in the largest possible number of remaining
--   sets. Add this element to the set of chosen elements, and filter
--   out all the sets it hits.  Repeat, choosing a new element to hit
--   the largest number of unhit sets at each step, until all sets are
--   hit.  This algorithm produces a hitting set which might be larger
--   than optimal by a factor of lg(m), where m is the number of sets
--   in the input.
--
-- >>> import qualified Data.Set as S
-- >>> shs = smallHittingSet . map S.fromList
--
-- >>> shs ["a"]
-- fromList "a"
--
-- >>> shs ["ab", "b"]
-- fromList "b"
--
-- >>> shs ["ab", "bc"]
-- fromList "b"
--
-- >>> shs ["acd", "c", "aef", "a"]
-- fromList "ac"
--
-- >>> shs ["abc", "abd", "acd", "bcd"]
-- fromList "cd"
--
-- Here is an example of an input for which @smallHittingSet@ does
-- /not/ produce a minimal hitting set. "bc" is also a hitting set and
-- is smaller.  b, c, and d all occur in exactly two sets, but d is
-- unluckily chosen first, leaving "be" and "ac" unhit and
-- necessitating choosing one more element from each.
--
-- >>> shs ["bd", "be", "ac", "cd"]
-- fromList "cde"
smallHittingSet :: Ord a => [Set a] -> Set a
smallHittingSet :: forall a. Ord a => [Set a] -> Set a
smallHittingSet [Set a]
ss = forall {a}. Ord a => Set a -> [Set a] -> Set a
go Set a
fixed (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Set a -> Bool
S.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set a
fixed) [Set a]
choices)
 where
  (Set a
fixed, [Set a]
choices) = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((forall a. Eq a => a -> a -> Bool
== Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Int
S.size) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
S.null) forall a b. (a -> b) -> a -> b
$ [Set a]
ss

  go :: Set a -> [Set a] -> Set a
go !Set a
soFar [] = Set a
soFar
  go !Set a
soFar [Set a]
cs = Set a -> [Set a] -> Set a
go (forall a. Ord a => a -> Set a -> Set a
S.insert a
best Set a
soFar) (forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
best forall a. Ord a => a -> Set a -> Bool
`S.member`)) [Set a]
cs)
   where
    best :: a
best = forall a. Ord a => [Set a] -> a
mostCommon [Set a]
cs

  -- Given a nonempty collection of sets, find an element which is shared among
  -- as many of them as possible.
  mostCommon :: Ord a => [Set a] -> a
  mostCommon :: forall a. Ord a => [Set a] -> a
mostCommon = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
M.assocs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Num a => a -> a -> a
(+) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (,Int
1 :: Int) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Set a -> [a]
S.toList