/src/Util.hs
Haskell | 526 lines | 365 code | 137 blank | 24 comment | 15 complexity | 3a7173533af08debcc7c9103fcac402b MD5 | raw file
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