Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

initial commit for futil

Summary: rebooting the repo to just have public things.
unfortunately we lose repo history but i think that's ok.

Reviewed By: srush

Test Plan: builds

Revert Plan: ok
  • Loading branch information...
commit 13c3ec21aaf83560a1206f6cc81c30cd84ff9a54 0 parents
Daniel Corson authored
23 FUtil.cabal
@@ -0,0 +1,23 @@
+name: FUtil
+version: 0.1
+synopsis: generic utility library and scripts useful for many projects
+license: GPL
+license-file: LICENSE
+author: dan corson <danl@alum.mit.edu>
+build-depends: HSH, MonadRandom, array, base, bytestring, containers,
+ haskell98, mtl, parsec >= 3.0.0, process, random, time
+exposed-modules: FUtil
+hs-source-dirs: src
+build-type: Simple
+
+executable: align
+main-is: align.hs
+hs-source-dirs: src
+
+executable: sorth
+main-is: sorth.hs
+hs-source-dirs: src
+
+executable: wordSwap
+main-is: wordSwap.hs
+hs-source-dirs: src
10 LICENSE
@@ -0,0 +1,10 @@
+Copyright (c) 2009, Dan Corson, Sasha Rush, Facebook, inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
+ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
+ * Neither the name of Facebook, inc. nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
6 README
@@ -0,0 +1,6 @@
+to install
+- ./install
+dependencies should all be on hackage (so grabbed for you)
+
+to get help
+- haskell@lists.facebook.com
3  Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
124 bin/hsb
@@ -0,0 +1,124 @@
+#!/usr/bin/env python
+#
+# haskell build/etc wrapper for cabal or non-cabal (ghc with obj/ dir)
+# - note this has very little (but non-zero still) use now that cabal-install
+# exists
+#
+#
+# cabal is more standard for packaging
+# non-cabal is faster for development work on an executable (non-library)
+#
+# non-cabal mode can read a 'name' file for the name of your executable which
+# is produced from src/<name>.hs. it will assume name = 'Main' otherwise
+
+from optparse import OptionParser
+import cmd_util as cu
+import os
+import sys
+
+usage = """usage: %prog [options] [-- <args for run, or configure, or build>]
+
+configure/build/install your program with cabal (by default)
+or build/run program or test suite with ghc
+(assuming src/ structure and other things)"""
+p = OptionParser(usage)
+# todo: support clean for gen?, support test for cabal
+# fixme: too many non-obviousities,
+# like that optimize with cabal only applies to configure?
+# or should you know that (we could at least warn)
+p.add_option('-b', '--build', action='store_true')
+p.add_option('-c', '--configure', action='store_true')
+p.add_option('-C', '--cabal', action='store_true')
+#p.add_option('-H', '--haddock', action='store_true')
+p.add_option('-k', '--clean', action='store_true')
+p.add_option('-i', '--install', action='store_true')
+p.add_option('-O', '--optimize', action='store_true')
+p.add_option('-2', '--optimize2', action='store_true')
+p.add_option('-r', '--run', action='store_true')
+p.add_option('-t', '--test', action='store_true')
+(opts, args) = p.parse_args()
+
+#steps_poss = ['clean', 'configure', 'build', 'install', 'run', 'haddock']
+steps_poss = ['clean', 'configure', 'build', 'install', 'run']
+steps = []
+for step in steps_poss:
+ if getattr(opts, step):
+ steps.append(step)
+if not steps:
+ if opts.test:
+ # common case for test is to build the test then run the test
+ steps = ['build', 'run']
+ else:
+ # in most common case we just want to install some normal cabal package
+ steps = ['configure', 'build', 'install']
+ opts.cabal = True
+ if not opts.optimize:
+ # this if is so that 'hsb -O' works as expected (and not as
+ # 'hsb -2' which is the default); no reason not to support that
+ opts.optimize2 = True
+
+if opts.cabal:
+ if opts.test:
+ cu.error_out('testing thru cabal not supported')
+
+ setup = 'Setup.lhs'
+ if not os.path.exists(setup):
+ setup = 'Setup.hs'
+
+ for step in steps:
+ if step == 'run':
+ continue
+ cmd = ['runhaskell', setup, step]
+ if step == 'configure':
+ if opts.optimize:
+ cmd += ['-O']
+ if opts.optimize2:
+ cmd += ['--ghc-options=-O2']
+ if 'run' not in steps:
+ # configure is most useful step to take extra args in cabal case
+ # if we aren't running
+ cmd += args
+ elif step == 'install':
+ cmd = ['sudo'] + cmd
+ cu.cmd_wait(cmd)
+else:
+ if 'configure' in steps:
+ cu.error_out('configuring thru non-cabal not supported')
+ if opts.clean:
+ cu.error_out('cleaning thru non-cabal not supported')
+
+ if os.path.exists('name'):
+ name = file('name').readlines()[0][:-1]
+ else:
+ name = 'Main'
+ if opts.test:
+ if 'install' in steps:
+ cu.error_out('installing test not supported')
+
+ name += '.Check'
+ if 'build' in steps:
+ if not os.path.exists('obj'):
+ os.mkdir('obj')
+ cmd = ['ghc', '--make', '-odir', 'obj', '-hidir', 'obj',
+ 'src/' + name + '.hs', '-o', name]
+ if opts.optimize:
+ cmd += ['-O']
+ if opts.optimize2:
+ cmd += ['-O2']
+ if 'run' not in steps:
+ # build is most useful step to take extra args in non-cabal case
+ # if we aren't running
+ cmd += args
+ cu.cmd_wait(cmd)
+
+if 'run' in steps:
+ if opts.cabal:
+ name_cmd = 'grep executable *.cabal | head -n1 | awk \'{print $2}\''
+ name = cu.cmd_output(name_cmd)[0]
+ else:
+ name = './' + name
+ print >> sys.stdout, 'running'
+ cu.cmd_wait([name] + args)
+
+#if 'haddock' in steps:
+#
3  bin/hsg
@@ -0,0 +1,3 @@
+#!/bin/sh
+# grep thru haskell code
+find . -path ./_darcs -prune -o -name '*.*hs' -print | xargs grep -nH "$@"
8 bin/hst
@@ -0,0 +1,8 @@
+#!/bin/sh
+# generate haskell ctags
+find . -path ./_darcs -prune -o -name '*.*hs' -print | xargs hasktags -c &&
+# hasktags does not sort the tags
+# also, sort (for all its options) cannot seem to be made to sort them
+# correctly! (i.e. simple ascii sort..)
+# but sorth does (simple ascii sort written in haskell)
+inPl tags sorth >/dev/null
13 bin/killQual
@@ -0,0 +1,13 @@
+#!/bin/sh
+#
+# ~ killQual MyLol someFile.hs
+# will convert from:
+# import qualified Lol as MyLol
+# MyLol.yay
+# to:
+# import Lol
+# yay
+
+Q="$1"
+F="$2"
+inPl "$F" sed 's/qualified \([^ ]*\) \bas '"$Q"'\b/\1/;s/'"$Q"'\.//g'
10 g
@@ -0,0 +1,10 @@
+#!/bin/sh
+# wrapper for iteration while developing
+
+set -e
+
+./install 2>&1 | less -E
+
+# for profiling
+#mkdir -p obj
+#ghc -O2 --make src/FUtil.hs -isrc -odir obj -hidir obj -auto-all -caf-all -fforce-recomp
4 install
@@ -0,0 +1,4 @@
+#!/bin/sh
+set -e
+cabal install --enable-optimization=2 --global --root-cmd=sudo
+sudo cp bin/* /usr/local/bin
28 src/FUtil.Check.hs
@@ -0,0 +1,28 @@
+module Main where
+
+import Data.Char
+import Data.List
+import Test.QuickCheck
+import FUtil
+
+instance Arbitrary Char where
+ arbitrary = choose ('a', 'b')
+ coarbitrary c = variant (ord c `rem` 4)
+
+chkInterBreaks :: Char -> [Char] -> Bool
+chkInterBreaks c s = intercalate [c] (breaks (== c) s) == s
+
+chkCalate :: [Char] -> [Char] -> Bool
+chkCalate glue s = s == intercalate glue (uncalate glue s)
+
+{-
+chks = [chkInterBreaks, chkDblTransp]
+-}
+
+--chkF = quickCheck
+--chkF = verboseCheck
+
+main = do
+ -- todo: TH to at least get chkF..
+ quickCheck chkInterBreaks
+ verboseCheck chkCalate
534 src/FUtil.hs
@@ -0,0 +1,534 @@
+module FUtil where
+
+import Control.Applicative hiding ((<|>))
+import Control.Arrow
+import Control.Monad
+import Control.Monad.Error
+import Control.Monad.Random
+import Data.Bits
+import Data.Char
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Time
+import Data.Word
+import Locale
+import System.Cmd
+import System.Console.GetOpt
+import System.Environment
+import System.Exit
+import System.IO
+import System.Process
+import System.Random
+import Text.Parsec hiding (satisfy, oneOf, noneOf, anyToken, uncons)
+import qualified Data.ByteString as BS
+import qualified Data.Map as M
+import qualified Data.Set as S
+import qualified HSH
+
+--
+-- random
+--
+
+gens :: (RandomGen t) => t -> [t]
+gens g = let (g1, g2) = split g in g1:gens g2
+
+shuffle :: (RandomGen g) => [b] -> Rand g [b]
+shuffle l = do
+ rndInts <- getRandoms
+ return . map snd . sortBy (compare `on` fst) $ zip (rndInts :: [Int]) l
+
+choice :: (RandomGen g) => [b] -> Rand g b
+choice l = fmap head $ shuffle l
+
+--
+-- lists
+--
+
+interlines :: [[Char]] -> [Char]
+interlines = intercalate "\n"
+interwords :: [[Char]] -> [Char]
+interwords = intercalate " "
+intertabs :: [[Char]] -> [Char]
+intertabs = intercalate "\t"
+
+padl :: a -> Int -> [a] -> [a]
+padl c l s = replicate (l - length s) c ++ s
+
+padr :: a -> Int -> [a] -> [a]
+padr c l s = s ++ replicate (l - length s) c
+
+splitN :: Int -> [a] -> [[a]]
+splitN _ [] = []
+splitN n xs = l : splitN n r where (l, r) = splitAt n xs
+
+-- stripe one list across n of them
+stripe :: Int -> [a] -> [[a]]
+stripe n = reverse . foldr (\ x (ys:yss) -> yss ++ [x:ys]) (replicate n [])
+
+-- pythonic list slicing
+slice :: Int -> Int -> [a] -> [a]
+slice x y l = take (y - x) $ drop x l
+
+-- cyclic successor on an enum
+cycSucc :: (Eq a, Bounded a, Enum a) => a -> a
+cycSucc x = if x == maxBound then minBound else succ x
+
+-- cycle a list one element forward
+cyc :: [a] -> [a]
+cyc (x:xs) = xs ++ [x]
+-- cycle a list one element back
+cycB :: [a] -> [a]
+cycB = reverse . cyc . reverse
+
+sublistIx :: Eq a => [a] -> [a] -> Maybe Int
+sublistIx subl l = findIndex id $ map (subl `isPrefixOf`) (tails l)
+
+-- substitute a sublist (e.g. string replace)
+subst :: Eq a => [a] -> [a] -> [a] -> [a]
+subst _ _ [] = []
+subst from to xs@(a:as) =
+ if from `isPrefixOf` xs
+ then to ++ subst from to (drop (length from) xs)
+ else a : subst from to as
+
+lookupWithKey :: Eq a => a -> [(a, b)] -> Maybe (a, b)
+lookupWithKey k l = case lookup k l of
+ Just v -> Just (k, v)
+ Nothing -> Nothing
+
+cap :: [a] -> [a] -> [a]
+cap c l = c ++ l ++ c
+
+-- note the return is slight different from break
+-- (is it wrong that i have always wanted break to give Maybe ([a], [a])
+-- and not include the broken-out part)
+breakMb :: (a -> Bool) -> [a] -> Maybe ([a], [a])
+breakMb f l = let (x, y) = break f l in
+ if null y then Nothing else Just (x, tail y)
+
+breaks :: (a -> Bool) -> [a] -> [[a]]
+breaks f l = if null b then [a] else (a:breaks f (drop 1 b))
+ where (a, b) = break f l
+
+breaksN :: (a -> Bool) -> Int -> [a] -> [[a]]
+breaksN _ 0 l = [l]
+breaksN f n l = if null b then [a] else (a:breaksN f (n - 1) (drop 1 b))
+ where (a, b) = break f l
+
+breakSubl :: Int -> ([a] -> Bool) -> [a] -> Maybe ([a], [a])
+breakSubl n f l = if f (take n l)
+ then Just ([], drop n l)
+ else case l of
+ [] -> Nothing
+ (x:xs) -> do
+ (a, b) <- breakSubl n f xs
+ return (x:a, b)
+
+breakOnSubl :: (Eq a) => [a] -> [a] -> Maybe ([a], [a])
+breakOnSubl subl = breakSubl (length subl) (== subl)
+
+-- perform a "break-like" function repeatedly
+breaklikes :: ([a] -> Maybe ([a], [a])) -> [a] -> [[a]]
+breaklikes f xs = case f xs of
+ Nothing -> [xs]
+ Just (l, r) -> l:breaklikes f r
+
+breaksOnSubl :: (Eq a) => [a] -> [a] -> [[a]]
+breaksOnSubl subl = breaklikes (breakOnSubl subl)
+
+max0 :: (Num a, Ord a) => [a] -> a
+max0 l = if null l then 0 else maximum l
+
+ltrim :: String -> String
+ltrim = dropWhile (== ' ')
+
+allBreak :: [a] -> [([a], [a])]
+allBreak s = zip (inits s) (tails s)
+
+uncalate :: Eq a => [a] -> [a] -> [[a]]
+uncalate [] s = map (:[]) s -- tricksy case to remember..
+uncalate glue s = case find (isPrefixOf glue . snd) $ allBreak s of
+ Nothing -> [s]
+ Just (s1, s2) -> s1:(uncalate glue $ drop (length glue) s2)
+
+groupByAdj :: (a -> a -> Bool) -> [a] -> [[a]]
+groupByAdj _ [] = [[]]
+groupByAdj f (x:xs) = groupByAdjPart f xs [x] where
+ groupByAdjPart f [] part = [part]
+ groupByAdjPart f xa@(x:xs) part = if f (last part) x
+ then groupByAdjPart f xs $ part ++ [x]
+ else part:groupByAdj f xa
+
+-- like unix comm
+comm :: (Ord a) => [a] -> [a] -> (([a], [a]), [a])
+comm xa@(x:xs) ya@(y:ys) = case compare x y of
+ EQ -> second ((x:)) $ comm xs ys
+ LT -> first (first (x:)) $ comm xs ya
+ GT -> first (second (y:)) $ comm xa ys
+
+uncons :: [a] -> (a, [a])
+uncons (x:xs) = (x, xs)
+uncons [] = error "uncons: empty list"
+
+headTails :: [[a]] -> ([a], [[a]])
+headTails = unzip . map uncons
+
+-- Reversify (work from end instead of beginning) a function.
+reversify :: ([a] -> [a]) -> [a] -> [a]
+reversify f = reverse . f . reverse
+
+-- Reversify (work from end instead of beginning) a function that makes a tuple
+-- (such as span).
+reversifyTup :: ([a] -> ([b], [b])) -> [a] -> ([b], [b])
+reversifyTup f = swap . bothond reverse . f . reverse
+
+reversifyFTup :: (Functor f) => ([a] -> f ([b], [b])) -> [a] -> f ([b], [b])
+reversifyFTup f = (swap . bothond reverse <$>) . f . reverse
+
+onHead :: (a -> a) -> [a] -> [a]
+onHead _ [] = []
+onHead f (x:xs) = f x : xs
+
+onLast :: (a -> a) -> [a] -> [a]
+onLast = reversify . onHead
+
+--
+-- functions
+--
+
+frep :: (a -> a) -> Int -> a -> a
+frep f n x = iterate f x !! n
+
+bothond :: (Arrow a) => a b c -> a (b, b) (c, c)
+bothond f = f *** f
+
+--
+-- IO, monads, time
+--
+
+io :: MonadIO m => IO a -> m a
+io = liftIO
+
+nothErr :: (MonadError e m) => e -> Maybe a -> m a
+nothErr err = maybe (throwError err) return
+
+inCd :: FilePath -> IO b -> IO b
+inCd dir f = do
+ dirOrig <- HSH.pwd
+ HSH.cd dir
+ res <- f
+ HSH.cd dirOrig
+ return res
+
+shEsc :: String -> String
+shEsc s = "'" ++ f s ++ "'" where
+ f "" = ""
+ f ('\'':s) = "'\\''" ++ f s
+ f ('\\':s) = "\\\\" ++ f s
+ f (x:s) = [x] ++ f s
+
+doArgs :: String -> c -> [OptDescr (c -> c)] -> IO (c, [String])
+doArgs header defOpts options = do
+ args <- getArgs
+ return $ case getOpt Permute options args of
+ (o, n, []) -> (foldl (flip id) defOpts o, n)
+ (_, _, errs) -> error $ concat errs ++ usageInfo header options
+
+
+globsOrNot :: [String] -> IO [String]
+globsOrNot = fmap concat . mapM (\ arg -> do
+ gs <- HSH.glob arg
+ return $ case gs of
+ [] -> [arg]
+ gs -> gs)
+
+ifM :: (Monad m) => m Bool -> m b -> m b -> m b
+ifM c t e = c >>= \ r -> if r then t else e
+
+whenM :: (Monad m) => m Bool -> m () -> m ()
+whenM t = (t >>=) . flip when
+
+unlessM :: (Monad m) => m Bool -> m () -> m ()
+unlessM t = (t >>=) . flip unless
+
+logTimeStr :: IO String
+logTimeStr = do
+ t <- getCurrentTime
+ return $ formatTime defaultTimeLocale "%Z %Y-%m-%d %H:%M:%S.%q" t
+
+-- try to get user input until input-parsing fcn succeeds
+repInp :: String -> (String -> Either String a) -> IO a
+repInp dispStr parseFcn = do
+ putStr dispStr
+ hFlush stdout
+ s <- getLine
+ case parseFcn s of
+ Left err -> do
+ putStrLn err
+ repInp dispStr parseFcn
+ Right ret -> do
+ return ret
+
+clrScr :: IO ()
+clrScr = do
+ system "clear"
+ return ()
+
+noArgs :: IO ()
+noArgs = do
+ args <- getArgs
+ unless (null args) $ do
+ progName <- getProgName
+ error $ "usage: " ++ progName ++ " takes no arguments"
+
+mapAccum :: (a -> Int -> b) -> [a] -> [b]
+mapAccum = mapAccumFromN 0 where
+ mapAccumFromN :: Int -> (a -> Int -> b) -> [a] -> [b]
+ mapAccumFromN n f l = case l of
+ [] -> []
+ (x:xs) -> [f x n] ++ (mapAccumFromN (n + 1) f xs)
+
+pSecInSec :: Integer
+pSecInSec = 1000 ^ 4
+
+readFileStrict :: String -> IO String
+readFileStrict f = do
+ c <- readFile f
+ length c `seq` return c
+
+--
+-- boilerplate
+--
+
+isLeft :: Either a b -> Bool
+isLeft (Left _) = True
+isLeft _ = False
+
+isRight :: Either a b -> Bool
+isRight (Right _) = True
+isRight _ = False
+
+fromRight :: Either a b -> b
+fromRight (Right x) = x
+fromRight _ = error "FUtil.fromRight: was Left.."
+
+fromLeft :: Either a b -> a
+fromLeft (Left x) = x
+fromLeft _ = error "FUtil.fromLeft: was Right.."
+
+--
+-- backwards variants
+--
+
+dlof :: a -> [a -> a] -> a
+dlof = foldl (flip ($))
+
+pam :: a -> [a -> b] -> [b]
+pam x = map ($ x)
+
+--
+-- interact variants
+--
+
+interactL :: ([String] -> [String]) -> IO ()
+interactL f = interact (unlines . f . lines)
+
+onRight :: (b -> c) -> Either a b -> Either a c
+onRight f (Left a) = Left a
+onRight f (Right b) = Right (f b)
+
+interactOrErr :: Show err => (String -> Either err String) -> IO ()
+interactOrErr f = do
+ s <- getContents
+ case f s of
+ Left err -> hPutStr stderr (show err)
+ Right out -> putStr out
+
+interactLOrErr :: Show err => ([String] -> Either err [String]) -> IO ()
+interactLOrErr f = interactOrErr (onRight unlines . f . lines)
+
+--
+-- parsing
+--
+
+type StreamParser tok st = Parsec [tok] st [tok]
+
+class (Eq tok, Show tok) => ParsePos tok where
+ trackTok :: tok -> SourcePos -> SourcePos
+
+ satisfy :: (tok -> Bool) -> Parsec [tok] st tok
+ satisfy f = tokenPrim show (\ pos tok _toks -> trackTok tok pos) $ \ tok ->
+ if f tok then Just tok else Nothing
+
+ anyToken :: Parsec [tok] st tok
+ anyToken = satisfy (const True)
+
+ oneOf, noneOf :: [tok] -> Parsec [tok] st tok
+ oneOf cs = satisfy (flip elem cs)
+ noneOf cs = satisfy (not . flip elem cs)
+
+ -- balance '(' ')' e.g. will parse "(()(()))" but not "())".
+ -- note it does not return outermost parens (l and r) (should it?).
+ balance, balanceEnd :: tok -> tok -> StreamParser tok st
+ balance l r = satisfy (== l) >> balanceEnd l r
+ balanceEnd l r = do
+ t <- anyToken
+ if t == r then return [] else if t == l
+ -- can we join?
+ then liftM2 (\ ts ts' -> l:ts ++ r:ts') (balanceEnd l r) (balanceEnd l r)
+ else (t:) <$> balanceEnd l r
+
+ -- apply parser "wherever it works", passing rest of stream through unchanged
+ whereItWorks :: StreamParser tok st -> StreamParser tok st
+ whereItWorks p = (eof >> return []) <|>
+ liftM2 (++) (try p) (whereItWorks p) <|>
+ liftM2 (:) anyToken (whereItWorks p)
+
+ -- apply parser "wherever it works", discarding the rest of the stream
+ onlyWhereItWorks :: Parsec [tok] st [a] -> Parsec [tok] st [a]
+ onlyWhereItWorks p = (eof >> return []) <|>
+ liftM2 (++) (try p) (onlyWhereItWorks p) <|>
+ (anyToken >> onlyWhereItWorks p)
+
+instance Error ParseError
+
+--
+-- display helpers
+--
+
+spaceTable :: [[String]] -> [String]
+spaceTable [] = []
+spaceTable ([]:_) = []
+spaceTable t@([_]:_) = map head t -- one col
+spaceTable t = zipWith (++) (spaceBlock col) $ spaceTable rest where
+ (col, rest) = unzip $ map (\ (x:xs) -> (x, xs)) t
+
+-- rename to spaceCol?
+spaceBlock :: [String] -> [String]
+spaceBlock b = let
+ lens = map length b
+ w = max0 lens in
+ zipWith (++) b $ map (\ l -> take (w - l) $ repeat ' ') lens
+
+-- if you want to equally-space several blocks but keep them separate
+spaceBlocks :: [[String]] -> [[String]]
+spaceBlocks bs = let
+ lenss = map (map length) bs
+ w = max0 $ map max0 lenss in
+ zipWith
+ (\ b lens -> zipWith (++) b $ map (\ l -> take (w - l) $ repeat ' ') lens)
+ bs lenss
+
+-- how is this not done for me by ghc
+-- Convert Unicode characters to UTF-8.
+toUtf :: String -> String
+toUtf [] = []
+toUtf (x:xs)
+ | ord x <= 0x007F = x:toUtf xs
+ | ord x <= 0x07FF =
+ chr (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)):
+ chr (0x80 .|. (ord x .&. 0x3F)):
+ toUtf xs
+ | otherwise =
+ chr (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)):
+ chr (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)):
+ chr (0x80 .|. (ord x .&. 0x3F)):
+ toUtf xs
+
+fromUtf :: String -> String
+fromUtf [] = []
+fromUtf (all@(x:xs)) | ord x<=0x7F = x:fromUtf xs
+ | ord x<=0xBF = err
+ | ord x<=0xDF = twoBytes all
+ | ord x<=0xEF = threeBytes all
+ | otherwise = err
+ where
+ twoBytes (x1:x2:xs) = chr (((ord x1 .&. 0x1F) `shift` 6) .|.
+ (ord x2 .&. 0x3F)):fromUtf xs
+ twoBytes _ = error "fromUTF: illegal two byte sequence"
+
+ threeBytes (x1:x2:x3:xs) = chr (((ord x1 .&. 0x0F) `shift` 12) .|.
+ ((ord x2 .&. 0x3F) `shift` 6) .|.
+ (ord x3 .&. 0x3F)):fromUtf xs
+ threeBytes _ = error "fromUTF: illegal three byte sequence"
+
+ err = error "fromUTF: illegal UTF-8 character"
+
+--
+-- byte shuffling
+--
+
+packBytes :: [Word8] -> Int
+packBytes = sum . zipWith (*) (iterate (256 *) 1) . map fromIntegral
+
+--
+-- power set kind of things
+--
+
+powerList :: [a] -> [[a]]
+powerList [] = [[]]
+powerList (x:xs) = l ++ map (x:) l where l = powerList xs
+
+type MetaSet a = S.Set (S.Set a)
+
+-- there isn't really anything cooler/set-specific for here, oddly
+powerSet :: Ord a => S.Set a -> MetaSet a
+powerSet = S.fromList . map S.fromList . powerList . S.toList
+
+allPoss :: (Bounded a, Enum a) => [a]
+allPoss = enumFrom minBound
+
+allListsOf :: [a] -> [[a]]
+allListsOf [] = [[]]
+allListsOf xs = as where as = []:[a ++ [x] | a <- as, x <- xs]
+
+dirProd :: [a] -> [b] -> [(a, b)]
+dirProd xs ys = [(x, y) | x <- xs, y <- ys]
+
+--
+-- maybe
+--
+
+readMb :: Read a => String -> Maybe a
+readMb s = fmap fst . listToMaybe $ reads s
+
+--
+-- errors
+--
+
+type CanErrStr a = Either String a
+type CanErrStrIO a = ErrorT String IO a
+
+--
+-- subprocesses
+--
+
+cmdOutput :: String -> [String] -> CanErrStrIO BS.ByteString
+cmdOutput cmd args = do
+ (inp,out,err,pid) <- io $ runInteractiveProcess cmd args Nothing Nothing
+ o <- io $ BS.hGetContents out
+ ret <- io $ waitForProcess pid
+ case ret of
+ ExitFailure e -> fail $ show e
+ ExitSuccess -> return o
+
+--
+-- tuples
+--
+
+swap :: (t, t1) -> (t1, t)
+swap (x, y) = (y, x)
+
+seqTupL :: ((t, t1), t2) -> ((t, t2), (t1, t2))
+seqTupL ((x, y), z) = ((x, z), (y, z))
+
+seqTupR :: (t, (t1, t2)) -> ((t, t1), (t, t2))
+seqTupR (x, (y, z)) = ((x, y), (x, z))
+
+--
+-- Map
+--
+
+flipMap :: (Ord k, Ord v) => M.Map k v -> M.Map v (S.Set k)
+flipMap = M.fromListWith S.union . map (second S.singleton . swap) . M.toList
40 src/align.hs
@@ -0,0 +1,40 @@
+-- align code to stdin based on args
+-- usage: align <string-to-align-at> [on-nth-incidence-of-string]
+
+import System.Environment
+import FUtil
+
+-- perform a "break-like" function at the nth place instead of the first place
+breaklikeNth :: Int -> [a] -> ([a] -> Maybe ([a], [a])) -> [a] ->
+ Maybe ([a], [a])
+breaklikeNth 1 _ f xs = f xs
+breaklikeNth n glue f xs = do
+ (l, r) <- breaklikeNth (n - 1) glue f xs
+ (rl, rr) <- f r
+ return (l ++ glue ++ rl, rr)
+
+-- take a non-hacky break-like function: returning Maybe (l, r)
+-- and make it hacky like break is: returning (l, glue ++ r)
+breaklikeHack :: [a] -> ([a] -> Maybe ([a], [a])) -> [a] -> ([a], [a])
+breaklikeHack glue f xs = case f xs of
+ Nothing -> (xs, [])
+ Just (l, r) -> (l, glue ++ r)
+
+breakOnNthSublHacky :: Eq a => Int -> [a] -> [a] -> ([a], [a])
+breakOnNthSublHacky n s = breaklikeHack s (breaklikeNth n s (breakOnSubl s))
+
+alignOn :: Int -> String -> [String] -> [String]
+alignOn n s ls = map unbreak (zip (spaceBlock p1) p2) where
+ (p1, p2) = unzip (map (breakOnNthSublHacky n s) ls)
+ unbreak (a, b) = a ++ b
+
+main = do
+ as <- getArgs
+ let
+ argN = length as
+ n = if argN == 1 then Just 1 else if argN == 2
+ then Just $ read $ as !! 1
+ else Nothing
+ case n of
+ Nothing -> putStrLn "usage"
+ Just n -> interactL $ alignOn n (head as)
3  src/sorth.hs
@@ -0,0 +1,3 @@
+import FUtil
+import Data.List
+main = interactL sort
30 src/wordSwap.hs
@@ -0,0 +1,30 @@
+-- swap ith and jth words on every line
+-- (keeping any word-trailing whitespace with the word)
+-- usage: wordSwap i j
+-- note that if there is leading whitespace, the first "word" is ""
+
+import Data.Array
+import Data.Char
+import System.Environment
+import System.IO
+import FUtil
+
+wordsWithWS :: String -> [String]
+wordsWithWS [] = []
+wordsWithWS s = let
+ (a, b) = span (not . isSpace) s
+ (b1, b2) = span isSpace b
+ in (a ++ b1):wordsWithWS b2
+
+swapIndices :: Int -> Int -> [a] -> [a]
+swapIndices i j xs = elems $
+ listArray (1, length xs) xs // [(i, xs !! (j - 1)), (j, xs !! (i - 1))]
+
+swapWords :: Int -> Int -> String -> String
+swapWords i j = concat . swapIndices i j . wordsWithWS
+
+main = do
+ args <- getArgs
+ case sequence $ map readMb args of
+ Just [i, j] -> interactL $ map (swapWords i j)
+ _ -> hPutStrLn stderr "usage"
Please sign in to comment.
Something went wrong with that request. Please try again.