{-# 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,
  enumeratedMap,
  cycleEnum,
  enumerateNonEmpty,
  showEnum,
  indexWrapNonEmpty,
  uniq,
  binTuples,
  histogram,
  findDup,
  both,
  allEqual,
  tails1,
  prependList,
  deleteKeys,
  lookupEither,
  applyWhen,
  applyJust,
  hoistMaybe,
  unsnocNE,

  -- * Directory utilities
  readFileMay,
  readFileMayT,
  findAllWithExt,
  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.Carrier.Throw.Either
import Control.Effect.State (State, modify, state)
import Control.Lens (ASetter', Lens', LensLike, LensLike', Over, lens, (<&>), (<>~))
import Control.Monad (filterM, unless)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.Bifunctor (Bifunctor (bimap), first)
import Data.Char (isAlphaNum, toLower)
import Data.Either.Extra (maybeToEither)
import Data.Either.Validation
import Data.Foldable (Foldable (..))
import Data.Foldable qualified as Foldable
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IM
import Data.List (maximumBy, partition)
import Data.List qualified as List
import Data.List.Extra (enumerate)
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)
import Prelude hiding (Foldable (..))

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
(?) = (a -> Maybe a -> a) -> Maybe a -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Maybe a -> a
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 b -> b -> Bool
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 b -> b -> Bool
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 = [a] -> a
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [a]
xs

enumeratedMap :: Int -> [a] -> IntMap a
enumeratedMap :: forall a. Int -> [a] -> IntMap a
enumeratedMap Int
startIdx = [(Int, a)] -> IntMap a
forall a. [(Int, a)] -> IntMap a
IM.fromList ([(Int, a)] -> IntMap a) -> ([a] -> [(Int, a)]) -> [a] -> IntMap a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
startIdx ..]

-- | 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 e -> e -> Bool
forall a. Eq a => a -> a -> Bool
== e
forall a. Bounded a => a
maxBound = e
forall a. Bounded a => a
minBound
  | Bool
otherwise = e -> e
forall a. Enum a => a -> a
succ e
e

-- | See
-- https://hackage.haskell.org/package/relude-1.2.1.0/docs/Relude-Enum.html#v:universeNonEmpty
enumerateNonEmpty :: (Enum e, Bounded e) => NonEmpty e
enumerateNonEmpty :: forall e. (Enum e, Bounded e) => NonEmpty e
enumerateNonEmpty = e
forall a. Bounded a => a
minBound e -> [e] -> NonEmpty e
forall a. a -> [a] -> NonEmpty a
:| Int -> [e] -> [e]
forall a. Int -> [a] -> [a]
drop Int
1 [e]
forall a. (Enum a, Bounded a) => [a]
enumerate

-- | 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 = String -> NonEmpty Char
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList (String -> NonEmpty Char) -> (e -> String) -> e -> NonEmpty Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> String
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 =
  NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
list [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
!! b -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
wrappedIdx
 where
  wrappedIdx :: b
wrappedIdx = b
idx b -> b -> b
forall a. Integral a => a -> a -> a
`mod` Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (NonEmpty a -> Int
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 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
forall a. Eq a => [a] -> [a]
uniq ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (a -> a -> Bool
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 = ((a, b) -> Map a (NonEmpty b) -> Map a (NonEmpty b))
-> Map a (NonEmpty b) -> t (a, b) -> Map a (NonEmpty b)
forall a b. (a -> b -> b) -> b -> t a -> b
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 Map a (NonEmpty b)
forall a. Monoid a => a
mempty
 where
  f :: (a, b) -> Map a (NonEmpty b) -> Map a (NonEmpty b)
f = (a -> NonEmpty b -> Map a (NonEmpty b) -> Map a (NonEmpty b))
-> (a, NonEmpty b) -> Map a (NonEmpty b) -> Map a (NonEmpty b)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((NonEmpty b -> NonEmpty b -> NonEmpty b)
-> a -> NonEmpty b -> Map a (NonEmpty b) -> Map a (NonEmpty b)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith NonEmpty b -> NonEmpty b -> NonEmpty b
forall a. Semigroup a => a -> a -> a
(<>)) ((a, NonEmpty b) -> Map a (NonEmpty b) -> Map a (NonEmpty b))
-> ((a, b) -> (a, NonEmpty b))
-> (a, b)
-> Map a (NonEmpty b)
-> Map a (NonEmpty b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> NonEmpty b) -> (a, b) -> (a, NonEmpty b)
forall a b. (a -> b) -> (a, a) -> (a, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> NonEmpty b
forall a. a -> NonEmpty a
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 = (Map a Int -> a -> Map a Int) -> Map a Int -> t a -> Map a Int
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map a Int
m a
k -> (Int -> Int -> Int) -> a -> Int -> Map a Int -> Map a Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) a
k Int
1 Map a Int
m) Map a Int
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 = Set a -> [a] -> Maybe a
forall {a}. Ord a => Set a -> [a] -> Maybe a
go Set a
forall a. Set a
S.empty
 where
  go :: Set a -> [a] -> Maybe a
go Set a
_ [] = Maybe a
forall a. Maybe a
Nothing
  go Set a
seen (a
a : [a]
as)
    | a
a a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set a
seen = a -> Maybe a
forall a. a -> Maybe a
Just a
a
    | Bool
otherwise = Set a -> [a] -> Maybe a
go (a -> Set a -> Set a
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 = (a -> d) -> (a -> d) -> p a a -> p d d
forall a b c d. (a -> b) -> (c -> d) -> p a c -> p b d
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) = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x) [a]
xs

-- | Taken from here:
-- https://hackage.haskell.org/package/ghc-9.8.1/docs/GHC-Data-FiniteMap.html#v:deleteList
deleteKeys :: Ord key => [key] -> Map key elt -> Map key elt
deleteKeys :: forall key elt. Ord key => [key] -> Map key elt -> Map key elt
deleteKeys [key]
ks Map key elt
m = (Map key elt -> key -> Map key elt)
-> Map key elt -> [key] -> Map key elt
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((key -> Map key elt -> Map key elt)
-> Map key elt -> key -> Map key elt
forall a b c. (a -> b -> c) -> b -> a -> c
flip key -> Map key elt -> Map key elt
forall k a. Ord k => k -> Map k a -> Map k a
M.delete) Map key elt
m [key]
ks

-- | Convenience function to indicate which key
-- was not found in the map.
lookupEither :: Ord k => k -> Map k v -> Either k v
lookupEither :: forall k v. Ord k => k -> Map k v -> Either k v
lookupEither k
k = k -> Maybe v -> Either k v
forall a b. a -> Maybe b -> Either a b
maybeToEither k
k (Maybe v -> Either k v)
-> (Map k v -> Maybe v) -> Map k v -> Either k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
k

------------------------------------------------------------
-- Backported functions

-- | The 'tails1' function takes a 'NonEmpty' stream @xs@ and returns all the
-- non-empty suffixes of @xs@, starting with the longest.
--
-- > tails1 (1 :| [2,3]) == (1 :| [2,3]) :| [2 :| [3], 3 :| []]
-- > tails1 (1 :| []) == (1 :| []) :| []
--
-- @since 4.18
tails1 :: NonEmpty a -> NonEmpty (NonEmpty a)
tails1 :: forall a. NonEmpty a -> NonEmpty (NonEmpty a)
tails1 =
  -- fromList is an unsafe function, but this usage should be safe, since:
  -- \* `tails xs = [xs, tail xs, tail (tail xs), ..., []]`
  -- \* If `xs` is nonempty, it follows that `tails xs` contains at least one nonempty
  --   list, since `head (tails xs) = xs`.
  -- \* The only empty element of `tails xs` is the last one (by the definition of `tails`)
  -- \* Therefore, if we take all but the last element of `tails xs` i.e.
  --   `init (tails xs)`, we have a nonempty list of nonempty lists
  [NonEmpty a] -> NonEmpty (NonEmpty a)
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([NonEmpty a] -> NonEmpty (NonEmpty a))
-> (NonEmpty a -> [NonEmpty a])
-> NonEmpty a
-> NonEmpty (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> NonEmpty a) -> [[a]] -> [NonEmpty a]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map [a] -> NonEmpty a
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList ([[a]] -> [NonEmpty a])
-> (NonEmpty a -> [[a]]) -> NonEmpty a -> [NonEmpty a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> [[a]]
forall a. HasCallStack => [a] -> [a]
List.init ([[a]] -> [[a]]) -> (NonEmpty a -> [[a]]) -> NonEmpty a -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [[a]]
forall a. [a] -> [[a]]
List.tails ([a] -> [[a]]) -> (NonEmpty a -> [a]) -> NonEmpty a -> [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList

-- | Attach a list at the beginning of a 'NonEmpty'.
-- @since 4.16
prependList :: [a] -> NonEmpty a -> NonEmpty a
prependList :: forall a. [a] -> NonEmpty a -> NonEmpty a
prependList [a]
ls NonEmpty a
ne = case [a]
ls of
  [] -> NonEmpty a
ne
  (a
x : [a]
xs) -> a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty a
ne

-- 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

-- |
-- Equivalent to `fromMaybe id`.
applyJust :: Maybe (a -> a) -> a -> a
applyJust :: forall a. Maybe (a -> a) -> a -> a
applyJust Maybe (a -> a)
Nothing a
x = a
x
applyJust (Just a -> a
f) a
x = a -> a
f 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 = m (Maybe b) -> MaybeT m b
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe b) -> MaybeT m b)
-> (Maybe b -> m (Maybe b)) -> Maybe b -> MaybeT m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe b -> m (Maybe b)
forall a. a -> m a
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) = a -> [a] -> ([a], a)
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 a -> [a] -> [a]
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 = IO String -> IO (Maybe String)
forall a. IO a -> IO (Maybe a)
catchIO (IO String -> IO (Maybe String))
-> (String -> IO String) -> String -> IO (Maybe String)
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 = IO Text -> IO (Maybe Text)
forall a. IO a -> IO (Maybe a)
catchIO (IO Text -> IO (Maybe Text))
-> (String -> IO Text) -> String -> IO (Maybe Text)
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, but does not read or open the file like 'acquireAllWithExt'.
findAllWithExt :: FilePath -> String -> IO [FilePath]
findAllWithExt :: String -> String -> IO [String]
findAllWithExt String
dir String
ext = do
  [String]
paths <- String -> IO [String]
listDirectory String
dir IO [String] -> ([String] -> [String]) -> IO [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
dir String -> String -> String
</>)
  [String]
filePaths <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\String
path -> String -> IO Bool
doesFileExist String
path IO Bool -> (Bool -> Bool) -> IO Bool
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Bool -> Bool -> Bool
(&&) (String -> Bool
hasExt String
path)) [String]
paths
  -- recurse
  [String]
sub <- (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist [String]
paths
  [String]
transChildren <- [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> String -> IO [String]
`findAllWithExt` String
ext) [String]
sub
  [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String]
filePaths [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [String]
transChildren
 where
  hasExt :: String -> Bool
hasExt String
path = String -> String
takeExtension String
path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ext)

-- | 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 = String -> String -> IO [String]
findAllWithExt String
dir String
ext IO [String]
-> ([String] -> IO [(String, String)]) -> IO [(String, String)]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> IO (String, String))
-> [String] -> IO [(String, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO (String, String)
addContent
 where
  addContent :: FilePath -> IO (FilePath, String)
  addContent :: String -> IO (String, String)
addContent String
path = (,) String
path (String -> (String, String)) -> IO String -> IO (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
path

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

-- | @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 = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> ([Text] -> String) -> [Text] -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source target. From source target => source -> target
from @Text (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unwords

-- | Show a value, but as Text.
--
--   Note: Data.Text.show was added in text-2.1.2.  Eventually we can
--   require that version of text and get rid of showT.
showT :: Show a => a -> Text
showT :: forall a. Show a => a -> Text
showT = forall source target. From source target => source -> target
from @String (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
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 (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> (a -> String) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
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 ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
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 Text -> Text -> Bool
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 Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text
"I", Text
"YOU"]
  verb3rd :: Text
verb3rd
    | Text
verb Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"have" = Text
"has"
    | Text
verb Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"can" = Text
"can"
    | Bool
otherwise = (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text) -> (Text, Text) -> Text
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 = Text -> Text
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 ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
`T.append` Text
",") ([Text] -> [Text]
forall a. HasCallStack => [a] -> [a]
init [Text]
ts) [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
"and", [Text] -> Text
forall a. HasCallStack => [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 = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ e -> m ()
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
_ = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Maybe a
Nothing `isJustOr` e
e = e -> m a
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
_ = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Left b
b `isRightOr` b -> e
f = e -> m a
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
_ = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
Failure b
b `isSuccessOr` b -> e
f = e -> m a
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) (Exp -> Exp) -> Q Exp -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> 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 LensLike' ((,) a) s a -> (a -> a) -> m a
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
LensLike' ((,) a) s a -> (a -> a) -> m a
<%= (a -> a -> 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 LensLike' ((,) a) s a -> (a -> (a, a)) -> m a
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)) (a -> (a, a)) -> (a -> a) -> a -> (a, a)
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 = (s -> (s, r)) -> m r
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (State s) sig m =>
(s -> (s, a)) -> m a
state ((r, s) -> (s, r)
forall a b. (a, b) -> (b, a)
swap ((r, s) -> (s, r)) -> (s -> (r, s)) -> s -> (s, r)
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 LensLike ((,) a) s s a b -> (a -> (a, b)) -> m a
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 = (s -> s) -> m ()
forall s (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (State s) sig m =>
(s -> s) -> m ()
modify (ASetter' s a
l ASetter' s a -> a -> s -> s
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 (f :: * -> *).
Functor f =>
((a, [a]) -> f (a, [a])) -> NonEmpty a -> f (NonEmpty a)
_NonEmpty = (NonEmpty a -> (a, [a]))
-> (NonEmpty a -> (a, [a]) -> NonEmpty a)
-> Lens (NonEmpty a) (NonEmpty a) (a, [a]) (a, [a])
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(a
x :| [a]
xs) -> (a
x, [a]
xs)) (((a, [a]) -> NonEmpty a) -> NonEmpty a -> (a, [a]) -> NonEmpty a
forall a b. a -> b -> a
const ((a -> [a] -> NonEmpty a) -> (a, [a]) -> NonEmpty a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> [a] -> NonEmpty a
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.
--
--   Note this can also be seen as minimizing a boolean expression in positive
--   conjunctive normal form.
--
-- >>> 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 = (Set a -> Bool) -> Set (Set a) -> Set (Set a)
forall a. (a -> Bool) -> Set a -> Set a
S.filter (Bool -> Bool
not (Bool -> Bool) -> (Set a -> Bool) -> Set a -> Bool
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 = (Set a -> Bool) -> Set (Set a) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Set a -> Set a -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`S.isSubsetOf` Set a
s) (Set a -> Set (Set a) -> Set (Set a)
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 = Set a -> [Set a] -> Set a
forall {a}. Ord a => Set a -> [Set a] -> Set a
go Set a
fixed ((Set a -> Bool) -> [Set a] -> [Set a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Set a -> Bool
forall a. Set a -> Bool
S.null (Set a -> Bool) -> (Set a -> Set a) -> Set a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> Set a -> Set a
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) = ([Set a] -> Set a) -> ([Set a], [Set a]) -> (Set a, [Set a])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [Set a] -> Set a
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
S.unions (([Set a], [Set a]) -> (Set a, [Set a]))
-> ([Set a] -> ([Set a], [Set a])) -> [Set a] -> (Set a, [Set a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set a -> Bool) -> [Set a] -> ([Set a], [Set a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> (Set a -> Int) -> Set a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> Int
forall a. Set a -> Int
S.size) ([Set a] -> ([Set a], [Set a]))
-> ([Set a] -> [Set a]) -> [Set a] -> ([Set a], [Set a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set a -> Bool) -> [Set a] -> [Set a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Set a -> Bool) -> Set a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set a -> Bool
forall a. Set a -> Bool
S.null) ([Set a] -> (Set a, [Set a])) -> [Set a] -> (Set a, [Set a])
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 (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
S.insert a
best Set a
soFar) ((Set a -> Bool) -> [Set a] -> [Set a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Set a -> Bool) -> Set a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
best a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member`)) [Set a]
cs)
   where
    best :: a
best = [Set a] -> a
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 = (a, Int) -> a
forall a b. (a, b) -> a
fst ((a, Int) -> a) -> ([Set a] -> (a, Int)) -> [Set a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, Int) -> (a, Int) -> Ordering) -> [(a, Int)] -> (a, Int)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((a, Int) -> Int) -> (a, Int) -> (a, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (a, Int) -> Int
forall a b. (a, b) -> b
snd) ([(a, Int)] -> (a, Int))
-> ([Set a] -> [(a, Int)]) -> [Set a] -> (a, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a Int -> [(a, Int)]
forall k a. Map k a -> [(k, a)]
M.assocs (Map a Int -> [(a, Int)])
-> ([Set a] -> Map a Int) -> [Set a] -> [(a, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Map a Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> Map a Int
histogram ([a] -> Map a Int) -> ([Set a] -> [a]) -> [Set a] -> Map a Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set a -> [a]) -> [Set a] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Set a -> [a]
forall a. Set a -> [a]
S.toList