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

-- |
-- Module      :  Swarm.Util
-- Copyright   :  Brent Yorgey
-- Maintainer  :  byorgey@gmail.com
--
-- 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
  (?),
  maxOn,
  maximum0,
  cycleEnum,
  uniq,
  getElemsInArea,
  manhattan,

  -- * Directory utilities
  readFileMay,
  readFileMayT,
  getSwarmDataPath,
  getSwarmSavePath,
  getSwarmHistoryPath,
  readAppData,

  -- * Text utilities
  isIdentChar,
  replaceLast,

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

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

  -- * Template Haskell utilities
  liftText,

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

  -- * Utilities for NP-hard approximation
  smallHittingSet,
  getDataDirSafe,
  getDataFileNameSafe,
  dataNotFound,
) where

import Control.Algebra (Has)
import Control.Effect.State (State, modify, state)
import Control.Effect.Throw (Throw, throwError)
import Control.Exception (catch)
import Control.Exception.Base (IOException)
import Control.Lens (ASetter', Lens', LensLike, LensLike', Over, lens, (<>~))
import Control.Lens.Lens ((&))
import Control.Monad (forM, unless, when)
import Data.Aeson (FromJSONKey, ToJSONKey)
import Data.Bifunctor (first)
import Data.Char (isAlphaNum)
import Data.Either.Validation
import Data.Int (Int64)
import Data.List (maximumBy, partition)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe (fromMaybe, mapMaybe)
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 Linear (V2 (V2))
import NLP.Minimorph.English qualified as MM
import NLP.Minimorph.Util ((<+>))
import Paths_swarm (getDataDir)
import System.Clock (TimeSpec)
import System.Directory (
  XdgDirectory (XdgData),
  createDirectoryIfMissing,
  doesDirectoryExist,
  doesFileExist,
  getXdgDirectory,
  listDirectory,
 )
import System.FilePath
import System.IO
import System.IO.Error (catchIOError)
import Witch

-- $setup
-- >>> import qualified Data.Map as M
-- >>> import Linear.V2

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

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

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

-- | Manhattan distance between world locations.
manhattan :: V2 Int64 -> V2 Int64 -> Int64
manhattan :: V2 Int64 -> V2 Int64 -> Int64
manhattan (V2 Int64
x1 Int64
y1) (V2 Int64
x2 Int64
y2) = forall a. Num a => a -> a
abs (Int64
x1 forall a. Num a => a -> a -> a
- Int64
x2) forall a. Num a => a -> a -> a
+ forall a. Num a => a -> a
abs (Int64
y1 forall a. Num a => a -> a -> a
- Int64
y2)

-- | Get elements that are in manhattan distance from location.
--
-- >>> v2s i = [(v, manhattan (V2 0 0) v) | x <- [-i..i], y <- [-i..i], let v = V2 x y]
-- >>> v2s 0
-- [(V2 0 0,0)]
-- >>> map (\i -> length (getElemsInArea (V2 0 0) i (M.fromList $ v2s i))) [0..8]
-- [1,5,13,25,41,61,85,113,145]
--
-- The last test is the sequence "Centered square numbers":
-- https://oeis.org/A001844
getElemsInArea :: V2 Int64 -> Int64 -> Map (V2 Int64) e -> [e]
getElemsInArea :: forall e. V2 Int64 -> Int64 -> Map (V2 Int64) e -> [e]
getElemsInArea o :: V2 Int64
o@(V2 Int64
x Int64
y) Int64
d Map (V2 Int64) e
m = forall k a. Map k a -> [a]
M.elems Map (V2 Int64) e
sm'
 where
  -- to be more efficient we basically split on first coordinate
  -- (which is logarithmic) and then we have to linearly filter
  -- the second coordinate to get a square - this is how it looks:
  --         ▲▲▲▲
  --         ││││    the arrows mark points that are greater then A
  --         ││s│                                 and lesser then B
  --         │sssB (2,1)
  --         ssoss   <-- o=(x=0,y=0) with d=2
  -- (-2,-1) Asss│
  --          │s││   the point o and all s are in manhattan
  --          ││││                  distance 2 from point o
  --          ▼▼▼▼
  sm :: Map (V2 Int64) e
sm =
    Map (V2 Int64) e
m
      forall a b. a -> (a -> b) -> b
& forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
M.split (forall a. a -> a -> V2 a
V2 (Int64
x forall a. Num a => a -> a -> a
- Int64
d) (Int64
y forall a. Num a => a -> a -> a
- Int64
1)) -- A
      forall a b. a -> (a -> b) -> b
& forall a b. (a, b) -> b
snd -- A<
      forall a b. a -> (a -> b) -> b
& forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
M.split (forall a. a -> a -> V2 a
V2 (Int64
x forall a. Num a => a -> a -> a
+ Int64
d) (Int64
y forall a. Num a => a -> a -> a
+ Int64
1)) -- B
      forall a b. a -> (a -> b) -> b
& forall a b. (a, b) -> a
fst -- B>
  sm' :: Map (V2 Int64) e
sm' = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Ord a => a -> a -> Bool
<= Int64
d) forall b c a. (b -> c) -> (a -> b) -> a -> c
. V2 Int64 -> V2 Int64 -> Int64
manhattan V2 Int64
o) Map (V2 Int64) e
sm

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

-- | 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 -> (IOException -> IO a) -> IO a
`catchIOError` (\IOException
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)

getDataDirSafe :: FilePath -> IO (Maybe FilePath)
getDataDirSafe :: String -> IO (Maybe String)
getDataDirSafe String
p = do
  String
d <- String -> String
mySubdir forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getDataDir
  Bool
de <- String -> IO Bool
doesDirectoryExist String
d
  if Bool
de
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just String
d
    else do
      String
xd <- String -> String
mySubdir forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
</> String
"data") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO String
getSwarmDataPath Bool
False
      Bool
xde <- String -> IO Bool
doesDirectoryExist String
xd
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
xde then forall a. a -> Maybe a
Just String
xd else forall a. Maybe a
Nothing
 where
  mySubdir :: String -> String
mySubdir String
d = String
d String -> String -> String
`appDir` String
p
  appDir :: String -> String -> String
appDir String
r = \case
    String
"" -> String
r
    String
"." -> String
r
    String
d -> String
r String -> String -> String
</> String
d

getDataFileNameSafe :: FilePath -> IO (Maybe FilePath)
getDataFileNameSafe :: String -> IO (Maybe String)
getDataFileNameSafe String
name = do
  Maybe String
dir <- String -> IO (Maybe String)
getDataDirSafe String
"."
  case Maybe String
dir of
    Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    Just String
d -> do
      let fp :: String
fp = String
d String -> String -> String
</> String
name
      Bool
fe <- String -> IO Bool
doesFileExist String
fp
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
fe then forall a. a -> Maybe a
Just String
fp else forall a. Maybe a
Nothing

dataNotFound :: FilePath -> IO Text
dataNotFound :: String -> IO Text
dataNotFound String
f = do
  String
d <- Bool -> IO String
getSwarmDataPath Bool
False
  let squotes :: String -> Text
squotes = Text -> Text
squote forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    [Text] -> Text
T.unlines
      [ Text
"Could not find the data: " forall a. Semigroup a => a -> a -> a
<> String -> Text
squotes String
f
      , Text
"Try downloading the Swarm 'data' directory to: " forall a. Semigroup a => a -> a -> a
<> String -> Text
squotes String
d
      ]

-- | Get path to swarm data, optionally creating necessary
--   directories.
getSwarmDataPath :: Bool -> IO FilePath
getSwarmDataPath :: Bool -> IO String
getSwarmDataPath Bool
createDirs = do
  String
swarmData <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData String
"swarm"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
createDirs (Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
swarmData)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure String
swarmData

-- | Get path to swarm saves, optionally creating necessary
--   directories.
getSwarmSavePath :: Bool -> IO FilePath
getSwarmSavePath :: Bool -> IO String
getSwarmSavePath Bool
createDirs = do
  String
swarmSave <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData (String
"swarm" String -> String -> String
</> String
"saves")
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
createDirs (Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
swarmSave)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure String
swarmSave

-- | Get path to swarm history, optionally creating necessary
--   directories. This could fail if user has bad permissions
--   on his own $HOME or $XDG_DATA_HOME which is unlikely.
getSwarmHistoryPath :: Bool -> IO FilePath
getSwarmHistoryPath :: Bool -> IO String
getSwarmHistoryPath Bool
createDirs =
  (String -> String -> String
</> String
"history") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO String
getSwarmDataPath Bool
createDirs

-- | Read all the .txt files in the data/ directory.
readAppData :: IO (Map Text Text)
readAppData :: IO (Map Text Text)
readAppData = do
  Maybe String
md <- String -> IO (Maybe String)
getDataDirSafe String
"."
  case Maybe String
md of
    Maybe String
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO Text
dataNotFound String
"<the data directory itself>"
    Just String
d -> do
      [String]
fs <-
        forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== String
".txt") forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( String -> IO [String]
listDirectory String
d forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOException
e ->
                  Handle -> String -> IO ()
hPutStr Handle
stderr (forall a. Show a => a -> String
show (IOException
e :: IOException)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
              )
      forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
fs (\String
f -> (forall target source. From source target => source -> target
into @Text (String -> String
dropExtension String
f),) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe Text)
readFileMayT (String
d String -> String -> String
</> String
f))

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

------------------------------------------------------------
-- 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
"\""]

-- | 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 ToJSON (V2 Int64)
deriving instance FromJSON (V2 Int64)

deriving instance FromJSONKey (V2 Int64)
deriving instance ToJSONKey (V2 Int64)

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 utilities for NP-hard approximation

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