/src/Util.hs

  1{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, PatternGuards, DeriveDataTypeable, OverlappingInstances, FlexibleContexts, FunctionalDependencies #-}
  2
  3module Util (module Data.SetOps, module Prelude.Unicode, module Util) where
  4
  5import qualified System.Posix.IO
  6import qualified Data.Monoid
  7import qualified Prelude
  8import qualified Data.List as List
  9import qualified Data.List.NonEmpty as NeList
 10import Data.Maybe (listToMaybe, mapMaybe, fromMaybe)
 11import Data.Monoid (Monoid(..))
 12import Data.Semigroup (Semigroup(..))
 13import Data.List (sortBy, minimumBy, isPrefixOf, tails, stripPrefix)
 14import Data.List.NonEmpty (NonEmpty(..))
 15import Data.Char (isSpace, isAlphaNum, toLower, toUpper)
 16import Data.Function (on)
 17import Data.Foldable (Foldable, toList, any)
 18import Data.Generics (Data, Typeable)
 19import Data.Traversable (mapM)
 20import Control.Exception (bracket, evaluate)
 21import Control.Arrow (Arrow, (>>>), arr, first, second, (&&&))
 22import Control.Monad (liftM2, when)
 23import Control.Monad.State (MonadState, modify, StateT(..))
 24import Control.Monad.Reader (ReaderT(..))
 25import Control.Monad.Trans.Class (lift)
 26import Control.Monad.Trans.Reader as Reader
 27import Control.DeepSeq (NFData, rnf)
 28import System.Posix.Types (Fd(..))
 29import System.IO (Handle, hClose)
 30import Control.Applicative (Applicative(..))
 31import Prelude hiding ((.), mapM, any)
 32import Prelude.Unicode hiding ((∈), (∉))
 33import Data.SetOps
 34
 35-- IO resources
 36
 37class IOResource a where dealloc :: a → IO ()
 38
 39withResource :: IOResource a ⇒ IO a → (a → IO b) → IO b
 40withResource x = bracket x dealloc
 41
 42instance IOResource Handle where dealloc = hClose
 43instance IOResource Fd where dealloc = System.Posix.IO.closeFd
 44
 45instance (IOResource x, IOResource y) ⇒ IOResource (x, y) where
 46  dealloc (x, y) = dealloc x >> dealloc y
 47
 48-- Conversions
 49
 50class Convert a b where convert :: a → b
 51
 52instance Convert a a where convert = id
 53
 54instance (Functor f, Convert a b) ⇒ Convert (f a) (f b) where convert = fmap convert
 55
 56instance (Convert x x', Convert y y') ⇒ Convert (Either x y) (Either x' y') where
 57  convert = either (Left . convert) (Right . convert)
 58
 59-- List utilities
 60
 61splitBy :: (a -> Bool) -> [a] -> [[a]]
 62splitBy _ [] = [[]]
 63splitBy f (x:xs)
 64  | f x = [] : splitBy f xs
 65  | y:ys <- splitBy f xs = (x:y):ys
 66  | otherwise = undefined
 67
 68total_tail :: [a] → [a]
 69total_tail [] = []
 70total_tail (_ : t) = t
 71
 72stripSuffix :: String → String → Maybe String
 73stripSuffix x y = reverse . stripPrefix (reverse x) (reverse y)
 74
 75takeBack :: Int → [a] → [a]
 76takeBack n = reverse . take n . reverse
 77
 78sortByProperty :: Ord b ⇒ (a → b) → [a] → [a]
 79sortByProperty f = sortBy $ \x y → compare (f x) (f y)
 80
 81findMaybe :: (a → Maybe b) → [a] → Maybe b
 82findMaybe f = listToMaybe . mapMaybe f
 83
 84elemBy :: (a → a → Bool) → a → [a] → Bool
 85elemBy f x = or . (f x .)
 86
 87none :: Foldable t ⇒ (a → Bool) → t a → Bool
 88none p = not . any p
 89
 90maybeLast :: [a] → Maybe a
 91maybeLast [] = Nothing
 92maybeLast [x] = Just x
 93maybeLast (_:t) = maybeLast t
 94
 95maybeLastAndRest :: [a] → Maybe ([a], a)
 96maybeLastAndRest [] = Nothing
 97maybeLastAndRest (h:t) = maybe (Just ([], h)) (Just . first (h:)) (maybeLastAndRest t)
 98
 99recognize :: Eq a ⇒ a → b → (a → b) → (a → b)
100recognize a b f = \x → if a == x then b else f x
101
102replace :: Eq a ⇒ a → a → [a] → [a]
103replace x y = map $ recognize x y id
104
105replaceWithMany :: Eq a ⇒ a → [a] → [a] → [a]
106replaceWithMany x y = concatMap $ recognize x y (:[])
107
108erase_indexed :: [Int] → [a] → [a]
109erase_indexed i l = f 0 l
110 where
111  f _ [] = []
112  f n (_:t) | n ∈ i ∨ n - length l ∈ i = f (n + 1) t
113  f n (h:t) = h : f (n + 1) t
114
115count :: (a → Bool) → [a] → Int
116count p = length . filter p
117
118length_ge :: Int → [a] → Bool
119length_ge 0 _ = True
120length_ge n (_:t) = length_ge (n-1) t
121length_ge _ _ = False
122  -- length_ge is lazy in its list argument, which   length l ≥ n   is not.
123
124take_atleast :: Int → (a → Int) → [a] → [a]
125take_atleast _ _ [] = []
126take_atleast n _ _ | n ≤ 0 = []
127take_atleast n m (h:t) = h : take_atleast (n - m h) m t
128
129replaceInfixM :: Eq a ⇒ [a] → [a] → [a] → Maybe [a]
130replaceInfixM what with l = (\(pre, post) → pre ++ with ++ post) . stripInfix what l
131
132replaceInfix :: Eq a ⇒ [a] → [a] → [a] → [a]
133replaceInfix what with l = fromMaybe l (replaceInfixM what with l)
134
135replaceAllInfix :: Eq a ⇒ [a] → [a] → [a] → [a]
136replaceAllInfix what with l | Just r ← stripPrefix what l = with ++ replaceAllInfix what with r
137replaceAllInfix what with (h:t) = h : replaceAllInfix what with t
138replaceAllInfix _ _ [] = []
139
140stripInfix :: Eq a ⇒ [a] → [a] → Maybe ([a], [a])
141stripInfix p s | Just r ← stripPrefix p s = Just ([], r)
142stripInfix p (h:t) = first (h:) . stripInfix p t
143stripInfix _ _  = Nothing
144
145partitionMaybe :: (a → Maybe b) → [a] → ([a], [b])
146partitionMaybe p = foldr (\x → maybe (first (x:)) (second . (:)) (p x)) ([], [])
147
148pairs :: [a] → [(a, a)]
149pairs (x:y:z) = (x,y) : pairs z
150pairs _ = []
151
152mapHead :: (a -> a) -> [a] -> [a]
153mapHead _ [] = []
154mapHead f (x:xs) = f x : xs
155
156findM :: Monad m ⇒ (a → m Bool) → [a] → m (Maybe a)
157findM _ [] = return Nothing
158findM p (x:xs) = do
159  b ← p x
160  if b then return (Just x) else findM p xs
161
162safeNth :: Int → [a] → Maybe a
163safeNth n = listToMaybe . if 0 ≤ n then drop n else drop (-n - 1) . reverse
164
165-- Non-empty lists
166
167type NeList = NeList.NonEmpty
168
169neElim :: NeList a → (a, [a])
170neElim = NeList.head &&& NeList.tail
171
172neFilter :: (a → Bool) → NeList a → [a]
173neFilter p = filter p . toList
174
175prefixNeList :: [a] → NeList a → NeList a
176prefixNeList [] = id
177prefixNeList (h:t) = (h :|) . (t ++) . toList
178
179neInitLast :: NeList a → ([a], a)
180neInitLast = ((reverse . snd) &&& fst) . neElim . NeList.reverse
181
182neHomogenize :: (Functor m, Monad m) ⇒ (a → m b) → NeList (Either a b) → m (Either (NeList a) (NeList b))
183neHomogenize f l = case NeList.tail l of
184  [] → return $ either (Left . return) (Right . return) (NeList.head l)
185  h:t → do
186    ht ← neHomogenize f $ h :| t
187    case (NeList.head l, ht) of
188      (Left x, Left y) → return $ Left $ NeList.cons x y
189      (Right x, Right y) → return $ Right $ NeList.cons x y
190      (Left x, Right y) → Right `fmap` (`NeList.cons` y) `fmap` f x
191      (Right x, Left y) → Right `fmap` NeList.cons x `fmap` mapM f y
192
193-- Test utilities
194
195fail_test :: (Show a, Show b) ⇒ String → a → b → IO ()
196fail_test n x y = do
197  putStr "Test failed: "; putStrLn n
198  putStr "Expected: "; print x
199  putStr "Actual:   "; print y
200  putNewLn
201  fail "test failure"
202
203test_cmp :: (Eq a, Show a) ⇒ String → a → a → IO ()
204test_cmp n x y = when (x ≠ y) $ fail_test n x y
205
206-- Finite
207
208class Finite a where all_values :: [a]
209
210instance (Finite a, Finite b) ⇒ Finite (Either a b) where
211  all_values = Left . all_values ++ Right . all_values
212
213instance (Enum a, Bounded a) ⇒ Finite a where all_values = enumFrom minBound
214
215-- Ordinals
216
217newtype Ordinal = Ordinal { ordinal_carrier :: Int }
218
219instance Show Ordinal where
220  show (Ordinal n) = case n of
221    0 → "first"; 1 → "second"; 2 → "third"; 3 → "fourth"; 4 → "fifth"
222    5 → "sixth"; 6 → "seventh"; 7 → "eighth"; 8 → "ninth"; 9 → "tenth"
223    _ → "<other ordinal>"
224
225instance Invertible Ordinal where
226  invert (Ordinal r) | r ≥ 0 = Ordinal (-r - 1)
227  invert o = o
228
229-- Cardinals
230
231cardinals :: [String]
232cardinals = words "zero one two three four five six seven eight nine ten"
233
234-- Misc English/textual
235
236indefinite :: String → String
237indefinite x = (if isVowel (head x) then "an " else "a ") ++ x
238
239multiplicative_numeral :: Int → String
240multiplicative_numeral i = case i of
241  1 → "once"; 2 → "twice"; 3 → "thrice"
242  n → show n ++ " times"
243
244isVowel :: Char → Bool
245isVowel = (∈ "aeoiu")
246
247comma_enum :: String → [String] → String
248comma_enum _ [] = ""
249comma_enum _ [x] = x
250comma_enum a [x, y] = x ++ (if length x > 25 then ", " else " ") ++ a ++ " " ++ y
251comma_enum a [x, y, z] = x ++ ", " ++ y ++ ", " ++ a ++ " " ++ z
252comma_enum z (x : y) = x ++ ", " ++ comma_enum z y
253
254commas_and, commas_or :: [String] → String
255commas_and = comma_enum "and"
256commas_or = comma_enum "or"
257
258capitalize :: String → String
259capitalize (h:t) = toUpper h : t
260capitalize [] = []
261
262strip :: String → String
263strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
264
265caselessStringEq :: String → String → Bool
266caselessStringEq a b = (toLower . a) == (toLower . b)
267
268plural :: String → String
269plural "body" = "bodies"
270plural "slash" = "slashes"
271plural "backslash" = "backslashes"
272plural "ellipsis" = "ellipses"
273plural s = s ++ "s"
274
275-- Inversion
276
277class Invertible a where invert :: a → a
278
279instance (Functor f, Invertible a) ⇒ Invertible (f a) where invert = fmap invert
280
281-- Arrow utilities
282
283snd_unit :: Arrow x ⇒ x () b → x c (c, b)
284snd_unit f = arr (\c → (c, ())) >>> second f
285
286liftA2 :: Arrow a ⇒ (c → c' → d) → a b c → a b c' → a b d
287liftA2 f a b = (a &&& b) >>> arr (uncurry f)
288
289-- Options
290
291class Option a where
292  short :: a → Maybe Char
293  long :: a → String
294
295show_long_opt :: Option o ⇒ o → String
296show_long_opt = ("--" ++) . long
297
298show_long_opts :: Option o ⇒ [o] → String
299show_long_opts = concat . List.intersperse " " . map show_long_opt
300
301instance (Option a, Option b) ⇒ Option (Either a b) where
302  short = either short short; long = either long long
303
304-- EitherOrBoth
305
306data EitherOrBoth a b = LeftOnly a | RightOnly b | Both a b
307
308instance (Show a, Show b) ⇒ Show (EitherOrBoth a b) where
309  show (LeftOnly a) = "(LeftOnly " ++ show a ++ ")"
310  show (RightOnly a) = "(RightOnly " ++ show a ++ ")"
311  show (Both a b) = "(Both " ++ show a ++ " " ++ show b ++ ")"
312
313-- Phantom
314
315data Phantom a = Phantom
316
317-- Approximate matching
318
319type Cost = Float
320data Op a = SkipOp a | InsertOp a | EraseOp a | ReplaceOp a a
321data OpsWithCost a = OpsWithCost [Op a] Cost
322
323instance Semigroup (OpsWithCost a) where
324  OpsWithCost l c <> OpsWithCost l' c' = OpsWithCost (l ++ l') (c + c')
325
326instance Monoid (OpsWithCost a) where
327  mempty = OpsWithCost [] 0
328
329ops_cost :: OpsWithCost a → Cost
330ops_cost (OpsWithCost _ c) = c
331
332opsWithCost :: (Op a → Cost) → [Op a] → OpsWithCost a
333opsWithCost co ops = OpsWithCost ops (sum $ map co ops)
334
335addOp :: (Op a → Cost) → Op a → OpsWithCost a → OpsWithCost a
336addOp co op (OpsWithCost ops c) = OpsWithCost (op : ops) (c + co op)
337
338is_insertOp :: Op a → Bool
339is_insertOp (InsertOp _) = True
340is_insertOp _ = False
341
342approx_match :: Eq a ⇒ (Op a → Cost) → [a] → [a] → [(OpsWithCost a, Int, Int)]
343approx_match co pattern text =
344  sortBy (\(x,_,_) (y,_,_) → compare (ops_cost x) (ops_cost y)) $
345    zipWith (\owc@(OpsWithCost o _) z → (owc, z, count (not . is_insertOp) o)) r [0..]
346 where
347  r = foldl f (replicate (length text + 1) mempty) (tail $ reverse $ tails pattern)
348    -- r!!n contains the cheapest cost and corresponding replace-length of replacing the pattern at position n in the text.
349    -- the nth intermediate list in r's fold stores at position p the cheapest cost and corresponding replace-length of matching the the last n elements of the pattern at position p in the text.
350  f v pattern_tail = foldl g [opsWithCost co (map InsertOp pattern_tail)] [length text, length text - 1 .. 1]
351   where
352    c = head pattern_tail
353    g w m = minimumBy (compare `on` ops_cost) candidates : w
354     where
355      d = text !! (m - 1)
356      candidates =
357        [ addOp co (if c == d then SkipOp c else ReplaceOp c d) (v!!m)
358        , addOp co (InsertOp c) (v!!(m - 1))
359        , addOp co (EraseOp d) (head w)
360        ]
361
362levenshtein :: String → String → Float
363levenshtein s t = d !! length s !! length t
364  where
365    d = [[ distance m n | n ← [0 .. length t]] | m ← [0 .. length s]]
366    distance :: Int → Int → Float
367    distance i 0 = fromIntegral i
368    distance 0 j = fromIntegral j
369    distance i j = minimum [d!!(i-1)!!j+1, d!!i!!(j-1)+1, d!!(i-1)!!(j-1) + (if s!!(i-1)==t!!(j-1) then -0.4 else 1)]
370
371-- Misc misc
372
373prefixError :: String → Either String a → Either String a
374prefixError _ (Right x) = Right x
375prefixError s (Left s') = Left (s ++ s')
376
377isIdChar :: Char → Bool
378isIdChar = isAlphaNum .∨. (== '_')
379
380instance (Functor m, Monad m) ⇒ Applicative m where pure = return; (<*>) = liftM2 ($)
381
382full_evaluate :: NFData a ⇒ a → IO a
383full_evaluate x = do () ← evaluate (rnf x); return x
384  -- evaluate only evaluates up to WHNF.
385
386readFileNow :: FilePath → IO String
387readFileNow f = readFile f >>= full_evaluate
388  -- Useful when, for example, one needs to read from a file before performing a chroot after which the file is no longer accessible.
389
390(.) :: Functor f ⇒ (a → b) → f a → f b
391(.) = fmap
392
393infixr 9 .
394
395(‥) :: (Functor f, Functor g) ⇒ (a → b) → (f (g a) → f (g b))
396x ‥ y = (x .) . y
397
398infixr 9 ‥
399
400kibi, mebi :: Integral a ⇒ a
401kibi = 1024
402mebi = kibi * kibi
403
404readEither :: Read a ⇒ String → Either String a
405readEither s
406  | [(x, r)] ← reads s, all isSpace r = return x
407  | otherwise = throwError "parse failure"
408
409readTypedFile :: Read a ⇒ FilePath → IO a
410readTypedFile f = either (const $ fail $ "parsing \"" ++ f ++ "\"") return =<< readEither . readFile f
411
412maybeM :: Monad m ⇒ Maybe a → (a → m ()) → m ()
413maybeM m a = maybe (return ()) a m
414
415msapp :: (Data.Monoid.Monoid a, MonadState a m) ⇒ a → m ()
416msapp = modify . flip Data.Monoid.mappend
417
418(.∨.), (.∧.) :: (a → Bool) → (a → Bool) → (a → Bool)
419(f .∨. g) x = f x ∨ g x
420(f .∧. g) x = f x ∧ g x
421  -- In applicative notation, these could be written: f .∨. g = [[ f ∨ g ]].
422
423orElse :: Maybe a → a → a
424orElse (Just x) _ = x
425orElse Nothing x = x
426
427apply_if :: Bool → (a → a) → (a → a)
428apply_if b f = if b then f else id
429
430putNewLn :: IO ()
431putNewLn = putStrLn ""
432
433(<<) :: Monad m ⇒ m a → m b → m a
434x << y = x >>= \z → y >> return z
435
436(>+>) :: (Monad m, Monoid n) ⇒ m n → m n → m n
437(>+>) = liftM2 mappend
438
439parsep :: Char
440parsep = '\x2029' -- U+2029 PARAGRAPH SEPARATOR
441
442classify_diagnostic :: String -> Maybe String
443classify_diagnostic s
444  | "warning:" `isPrefixOf` s = Just "warning"
445  | "error:" `isPrefixOf` s = Just "error"
446  | "Error:" `isPrefixOf` s = Just "error"
447  | "fatal error:" `isPrefixOf` s = Just "error"
448  | "internal compiler error:" `isPrefixOf` s = Just "error"
449  | otherwise = Nothing
450
451describe_new_output :: [String] → String → String
452describe_new_output prev new
453  | length new ≤ 20 = new
454  | otherwise = (!! length (takeWhile (== new) prev)) $ cycle
455      [ new
456      , "Same " ++ thing ++ "."
457      , "Still same " ++ thing ++ "."
458      , "Again, same " ++ thing ++ "."
459      , "Same " ++ thing ++ "."
460      , "Give up already."
461      ]
462  where thing = classify_diagnostic new `orElse` "output"
463
464mapState' :: Monad y ⇒ (x → x) → StateT x y ()
465mapState' f = StateT $ \s → return ((), f s)
466
467data TriBool = Definitely | Indeterminate | DefinitelyNot deriving (Data, Typeable, Eq)
468
469newtype MaybeEitherString a = MaybeEitherString (Maybe (Either String a)) deriving (Show, Typeable)
470
471instance Monad MaybeEitherString where
472  return = MaybeEitherString . return . return
473  MaybeEitherString Nothing >>= _ = MaybeEitherString Nothing
474  MaybeEitherString (Just (Left e)) >>= _ = MaybeEitherString $ Just $ Left e
475  MaybeEitherString (Just (Right x)) >>= f = f x
476  fail = MaybeEitherString . return . Left
477
478instance Functor MaybeEitherString where
479  fmap f (MaybeEitherString (Just (Right x))) = MaybeEitherString $ Just $ Right $ f x
480  fmap _ (MaybeEitherString (Just (Left e))) = MaybeEitherString $ Just $ Left e
481  fmap _ (MaybeEitherString Nothing) = MaybeEitherString Nothing
482
483instance MyMonadError [Char] MaybeEitherString where
484  throwError = MaybeEitherString . Just . Left
485  catchError = error "sorry, not implemented"
486
487type E = Either String
488
489nothingAsError :: String → Maybe a → E a
490nothingAsError s = maybe (Left s) return
491
492or_fail :: MyMonadError String m ⇒ E a → m a
493or_fail = either throwError return
494
495strip_utf8_bom :: String → String
496strip_utf8_bom ('\239':'\187':'\191':s) = s
497strip_utf8_bom s = s
498
499instance MyMonadError [Char] Maybe where
500  throwError = const Nothing
501  catchError Nothing f = f "error"
502  catchError m _ = m
503
504propagateE :: Monad m ⇒ E a → (a → m (E b)) → m (E b)
505propagateE (Left e) _ = return $ Left e
506propagateE (Right x) f = f x
507
508class Monad m => MyMonadError e m | m -> e where
509  throwError :: e -> m a
510  catchError :: m a -> (e -> m a) -> m a
511
512instance MyMonadError e (Either e) where
513  throwError = Left
514  Left  l `catchError` h = h l
515  Right r `catchError` _ = Right r
516
517instance MyMonadError e m => MyMonadError e (ReaderT r m) where
518  throwError = lift . throwError
519  catchError = liftCatch catchError
520
521-- Natural applications
522
523class Apply a b c | a b → c where apply :: a → b → c
524class MaybeApply a b where mapply :: (Functor m, MyMonadError String m) ⇒ a → b → m b
525
526instance Apply a b b ⇒ Apply (Maybe a) b b where apply m x = maybe x (flip apply x) m