MiniAgda-0.2025.7.23: src/Util.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TupleSections, NoMonomorphismRestriction,
      FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-}

module Util (module Util, module X) where

-- reexports:
import Data.List as X (intercalate)

import Prelude hiding (showList, null, (<>))

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, (<$>))
#endif
import Control.Monad
import Control.Monad.Writer (Writer, runWriter)

import qualified Data.List.NonEmpty as List1
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid (All, getAll)
import Debug.Trace

import Text.PrettyPrint as PP

type List1 = List1.NonEmpty

(+?+) :: String -> String -> String
(+?+) _ "[]" = []
(+?+) xs ys  = xs ++ ys

implies :: Bool -> Bool -> Bool
implies a b = if a then b else True

class Pretty a where
    pretty      :: a -> Doc
    prettyPrec  :: Int -> a -> Doc

    pretty      = prettyPrec 0
    prettyPrec  = const pretty

instance Pretty Doc where
    pretty = id

angleBrackets :: Doc -> Doc
angleBrackets d = text "<" <+> d <+> text ">"

-- | Apply when condition is @True@.
fwhen :: Bool -> (a -> a) -> a -> a
fwhen True  f a = f a
fwhen False _ a = a

parensIf :: Bool -> Doc -> Doc
parensIf b = fwhen b PP.parens

hsepBy :: Doc -> [Doc] -> Doc
hsepBy _separator []     = empty
hsepBy _separator [d]    = d
hsepBy  separator (d:ds) = d <> separator <> hsepBy separator ds

pwords :: String -> [Doc]
pwords = map text . words

fwords :: String -> Doc
fwords = fsep . pwords

fromAllWriter :: Writer All a -> (Bool, a)
fromAllWriter m = let (a, w) = runWriter m
                  in  (getAll w, a)

traceM :: (Monad m) => String -> m ()
traceM msg = trace msg $ return ()

infixr 9 <.>

-- | Composition: pure function after monadic function.
(<.>) :: Functor m => (b -> c) -> (a -> m b) -> a -> m c
(f <.> g) a = f <$> g a

whenM :: Monad m => m Bool -> m () -> m ()
whenM mb k = mb >>= (`when` k)

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mb k = mb >>= (`unless` k)

whenJustM :: (Monad m) => m (Maybe a) -> (a -> m ()) -> m ()
whenJustM mm k = mm >>= (`whenJust` k)

whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m ()
whenJust (Just a) k = k a
whenJust Nothing  _ = return ()

whenNothing :: (Monad m) => Maybe a -> m () -> m ()
whenNothing Nothing m = m
whenNothing Just{}  _ = return ()

ifNothingM :: (Monad m) => m (Maybe a) -> m b -> (a -> m b) -> m b
ifNothingM mma mb f = maybe mb f =<< mma

ifJustM :: (Monad m) => m (Maybe a) -> (a -> m b) -> m b -> m b
ifJustM mma f mb = maybe mb f =<< mma

mapMapM :: (Monad m, Ord k) => (a -> m b) -> Map k a -> m (Map k b)
mapMapM f = Map.foldrWithKey step (return $ Map.empty)
  where step k a m = do a' <- f a
                        m' <- m
                        return $ Map.insert k a' m'

ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM c d e = do { b <- c ; if b then d else e }

{- Control.Monad.IfElse
whenM :: Monad m => m Bool -> m () -> m ()
whenM c d = do { b <- c; if b then d else return () }

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM c e = do { b <- c; if b then return () else e }
-}

andLazy :: Monad m => m Bool -> m Bool -> m Bool
andLazy ma mb = ifM ma mb $ return False

andM  :: Monad m => [m Bool] -> m Bool
andM []     = return True
andM (m:ms) = m `andLazy` andM ms

findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)
findM _ []       = return Nothing
findM p (x : xs) = do b <- p x
                      if b then return (Just x) else findM p xs

-- | Binary version of @=<<@.
(==<<) :: Monad m => (a -> b -> m c) -> (m a, m b) -> m c
f ==<< (ma, mb) = do { a <- ma; f a =<< mb }

parens :: String -> String
parens s = "(" ++ s ++ ")"

brackets :: String -> String
brackets s = "[" ++ s ++ "]"

bracketsIf :: Bool -> String -> String
bracketsIf False s = s
bracketsIf True  s = "[" ++ s ++ "]"

separate :: String -> String -> String -> String
separate _separator "" y = y
separate _separator x "" = x
separate  separator x y  = x ++ separator ++ y

showList :: String -> (a -> String) -> [a] -> String
showList _separator _ [] = ""
showList _separator f [e] = f e
showList  separator f (e:es) = f e ++ separator ++ showList separator f es
-- OR: showList separator f es = foldl separate "" $ map f es

hasDuplicate :: (Eq a) => [a] -> Bool
hasDuplicate [] = False
hasDuplicate (x : xs) = x `elem` xs || hasDuplicate xs

compressMaybes :: [Maybe a] -> [a]
compressMaybes = concat . map (maybe [] (\ a -> [a]))

mapFst :: (a -> c) -> (a,d) -> (c,d)
mapFst f (a,b) = (f a, b)

mapSnd :: (b -> d) -> (a,b) -> (a,d)
mapSnd f (a,b) = (a, f b)

mapPair :: (a -> c) -> (b -> d) -> (a,b) -> (c,d)
mapPair f g (a,b) = (f a, g b)

zipPair :: (a -> b -> c) -> (d -> e -> f) -> (a,d) -> (b,e) -> (c,f)
zipPair f g (a,d) (b,e) = (f a b, g d e)

headMaybe :: [a] -> Maybe a
headMaybe [] = Nothing
headMaybe (a:_) = Just a

firstJust :: [Maybe a] -> Maybe a
firstJust = headMaybe . compressMaybes

firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a)
firstJustM [] = return Nothing
firstJustM (mm : mms) = do
  m <- mm
  case m of
    Nothing -> firstJustM mms
    Just{}  -> return m

for, mapOver :: (Functor f) => f a -> (a -> b) -> f b
mapOver = flip fmap

for = mapOver

mapAssoc :: (a -> b) -> [(n,a)] -> [(n,b)]
mapAssoc f = map (\ (n, a) -> (n, f a))

mapAssocM :: (Applicative m, Monad m) => (a -> m b) -> [(n,a)] -> m [(n,b)]
mapAssocM f = mapM (\ (n, a) -> (n,) <$> f a)

compAssoc :: Eq b => [(a,b)] -> [(b,c)] -> [(a,c)]
compAssoc xs ys = [ (a,c) | (a,b) <- xs, (b',c) <- ys, b == b' ]

-- * Lists and stacks of lists

class Push a b where
  push    :: a -> b -> b

instance Push a [a] where
  push = (:)

instance Push a [[a]] where
  push a (b:bs) = (a : b) : bs
  push _ []     = undefined

-- TOO HARD for ghc:
-- instance Push a b => Push a [b] where
--   push a (b:bs) = push a b : bs

class Retrieve a b c | b -> c where
  retrieve :: Eq a => a -> b -> Maybe c

instance Retrieve a [(a,b)] b where
  retrieve = lookup

instance Retrieve a [[(a,b)]] b where
  retrieve a = retrieve a . concat

-- instance Retrieve a b c => Retrieve a [b] c where
--   retrieve a = firstJust . map (retrieve a)

{-
class ListLike a where
  length :: a -> Int
  null   :: a -> Bool
  nil    :: a
-}

class Size a where
  size :: a -> Int

instance Size [a] where
  size = length

class Null a where
  null :: a -> Bool

instance Null [a] where
  null = List.null