Planet Haskell

by Holden Karau (holden@pigscanfly.ca) at July 02, 2009 11:36 AM · By

sortBy :: (a -> a -> Ordering) -> [a] -> [a]
maximumBy :: (a -> a -> Ordering) -> [a] -> a
groupBy :: (a -> a -> Bool) -> [a] -> [[a]]
nubBy :: (a -> a -> Bool) -> [a] -> [a]

sortOn :: (Ord b) => (a -> b) -> [a] -> [a]
maximumOn :: (Ord b) => (a -> b) -> [a] -> a
groupOn :: (Eq b) => (a -> b) -> [a] -> [[a]]
nubOn :: (Eq b) => (a -> b) -> [a] -> [a]

{-# LANGUAGE ForeignFunctionInterface #-}

module Win32.Kernel32 (getComputerName) where

import Control.Monad (when, unless)
import Data.Bits ((.|.))
import Foreign.Marshal.Alloc (alloca)
import Foreign.Ptr (nullPtr)
import Foreign.Storable (peek, poke)
import System.Win32.Types (DWORD, LPDWORD, LPTSTR, LPVOID,
                           peekTStringLen, peekTString, withTString)

#include <windows.h>
#include
kernel32.dll
foreign import stdcall unsafe "GetComputerNameW"
  win32_getComputerName :: LPTSTR -> LPDWORD -> IO Bool

foreign import stdcall unsafe "GetLastError"
  win32_getLastError :: IO DWORD

foreign import stdcall unsafe "FormatMessageW"
  win32_formatMessage :: DWORD
                      -> LPVOID
                      -> DWORD
                      -> DWORD
                      -> LPTSTR
                      -> DWORD
                      -> LPVOID
                      -> IO DWORD
getComputerName :: IO String
getComputerName =
  withTString maxBuf $
    \buf ->
      alloca $ \len -> do
        poke len (fromIntegral maxLength)

        success <- win32_getComputerName buf len
        unless success $ failWithLastError "GetComputerName"

        len' <- peek len
        peekTStringLen (buf, (fromIntegral len'))
  where
    maxBuf = replicate maxLength '\0'
    maxLength = #const MAX_COMPUTERNAME_LENGTH
#const
MAX_COMPUTERNAME_LENGTH
failWithLastError :: String -> IO a
failWithLastError name = do
  code <- win32_getLastError
  withTString errbuf $
    \buf -> do
      gotmsg <- win32_formatMessage flags
                                    nullPtr
                                    code
                                    lang
                                    buf
                                    (fromIntegral errlen)
                                    nullPtr
      fmtcode <- win32_getLastError
      when (gotmsg == 0) $
        fail $ name ++ " failed: " ++ show (code, fmtcode)

      msg <- peekTString buf
      fail $ name ++ ": " ++ filter notEOL msg
  where
    errbuf = replicate errlen '\0'
    errlen = 300
    flags = #const FORMAT_MESSAGE_FROM_SYSTEM
            .|.
            #const FORMAT_MESSAGE_IGNORE_INSERTS
    lang = 0
    notEOL c = c /= '\n' && c /= '\r'
$ cabal test
test: user error (GetComputerName: The file name is too long.)
Kernel32.hsc
.hsc
Library
  hs-source-dirs:  src
  exposed-modules: Win32.Kernel32
  build-depends:   base, Win32
  extensions:      ForeignFunctionInterface
  ghc-options:     -Wall
cabal configure -ftest
cabal build
cabal test
@inproceedings{OdeToProlog,
 author = "Ralf L{\"a}mmel",
 title = "{Scrap Your Boilerplate---Prologically!}",
 booktitle = "Proceedings of the 11th ACM SIGPLAN international conference on Principles and practice of declarative programming",
 publisher = ACM,
 year = 2009,
 note = "6 pages"
}

Build-Type: Custom

...

flag test
  description: Build test program.
  default:     False

Executable test
  hs-source-dirs:  src, test
  other-modules:   MyModule1, MyModule2
  main-is:         Main.hs
  build-depends:   base
  if !flag(test)
    buildable:     False
cabal configure -ftest
test
Setup.hs
main = defaultMainWithHooks hooks
  where hooks = simpleUserHooks { runTests = runTests' }

runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()
runTests' _ _ _ lbi = system testprog >> return ()
  where testprog = (buildDir lbi) </> "test" </> "test"
cabal test
test/Main.hs
-ftest
phred
x + y
x `append` y
x in y
x `isInfixOf` y
x < y
x < y
x <= y
x <= y
x == y
x == y
x != y
x /= y
x > y
x > y
x >= y
x >= y
x % (...)

x[i] 
x `index` i
x[i:j]
(j-i) `take` (i `drop` x)
hash(x)

len(x)
length x
x * y
y `replicate` x
x.capitalize()

x.center(y)

x.count()

x.decode()
decode...
x.encode()
encode...
x.endswith(y)
y `isSuffixOf` x
x.expandtabs()

x.find(y)

x.format(...)

x.index(y)

x.isalnum()
all isAlphaNum x
x.isalpha()
all isAlpha x
x.isdigit()
all isDigit x
x.islower()
all isLower x
x.isspace()
all isSpace x
x.istitle()

x.isupper()
all isUpper x
x.join(y)
intercalate x y
x.ljust(w)

x.lower()
toLower x
x.lstrip()
dropWhile isSpace
x.partition(y)
break (==y) x
x.replace(y,z)

x.rfind(y)

x.rindex(y)

x.rjust(y)

x.rpartition(y)

x.rsplit(y)

x.rstrip(y)

x.split(y)

x.splitlines()
lines x
x.startswith(y)
y `isPrefixOf` x
x.strip()

x.swapcase()

x.title()

x.translate(y)

x.upper()
toUpper x
x.zfill()

unicodedata
string
format
Data.Text
Data.Text.Legacy
Data.Text
split :: Char -> Text -> [Text]
split :: Text -> Text -> [Text]
:info
-ddump-minimal-imports
M.imports
module Main where

import Control.Arrow
import Control.Monad
import Data.Char
import Data.List
import Data.Map hiding (filter, map)
import System.Environment
import System.Exit
import System.IO

usage :: IO a
usage = do
  me <- getProgName
  hPutStrLn stderr $ "Usage: " ++ me ++ " [ dictionary ]"
  exitWith (ExitFailure 1)

main :: IO ()
main =
  getPath >>= readFile >>= mapM_ (putStrLn . unwords) . sorted
  where sorted = sort . map sort . anagrams . lines

anagrams :: [String] -> [[String]]
anagrams words = filter ((>1) . length) equiv
  where equiv = elems $
                  fromListWith (++)
                    [ (normal w, [w]) | w <- words ]
        normal = sort . map toLower

getPath :: IO FilePath
getPath = getArgs >>= go
  where go [path] = return path
        go []     = return "/usr/share/dict/words"
        go _      = usage
$ ghc-6.10.3 -ddump-minimal-imports --make anagram.hs 
$ cat Main.imports
import System.IO(IO, FilePath, putStrLn, readFile, hPutStrLn,
                 stderr)
import Data.Map(elems, fromListWith)
import Control.Arrow()    -- Instances only
import Control.Monad(Monad(return, (>>=)), mapM_)
import Data.Char(String, toLower)
import Data.List((++), filter, map, length, lines, unwords, sort)
import System.Environment(getArgs, getProgName)
import System.Exit(ExitCode(ExitFailure), exitWith)
map (normal &&& (:[])) words
-ddump-minimal-imports
Reader Monad
Reader Comonad
Copointed
Comonad<T>
T
Comonad
Comonad
module Main where
import Data.Maybe
import Graphics.Vty
import qualified Data.ByteString.Char8 as B
options = [ (show i) ++ " Foo" | i <- [0..59]]
main = do
    vt <- mkVty
    getChoice vt options >>= print
getChoice vt opts = do
    (sx, sy) <- getSize vt
    _getChoice vt opts 0 sx sy
_getChoice vt opts idx sx sy =
    let
        _calcTop winHeight listLength idx = max 0 ((min listLength ((max 0 (idx - winHeight `div` 2)) + winHeight)) - winHeight)
        _top = _calcTop sy (length opts) idx
        _visible_opts = take sy (drop _top opts)
    in do
        update vt (render _visible_opts (idx - _top) sx)
        k <- getEvent vt
        case k of
            EvKey KDown [] -> _getChoice vt opts (min (length opts - 1) (idx + 1)) sx sy
            EvKey KUp [] -> _getChoice vt opts (max 0 (idx - 1)) sx sy
            EvKey KEsc [] -> shutdown vt >> return Nothing
            EvKey KEnter [] -> shutdown vt >> return (Just $ (idx, opts !! idx))
            EvResize nx ny -> _getChoice vt opts idx nx ny
            _ -> _getChoice vt opts idx sx sy
render opts idx sx = pic {
    pImage = foldr1 (<->) $ map _render1 $ zip [0..] opts
    }
    where
        _render1 (i, o) = renderHFill attr ' ' 5 <|> renderBS (_attr i) (B.pack o) <|> renderHFill attr ' ' (sx - 5 - length o)
        _attr i = if i /= idx
            then attr
            else setRV attr

Python	Haskell
`x + y`	x `append` y
`x in y`	x `isInfixOf` y
`x < y`	`x < y`
`x <= y`	`x <= y`
`x == y`	`x == y`
`x != y`	`x /= y`
`x > y`	`x > y`
`x >= y`	`x >= y`
`x % (...)`
`x[i]`	x `index` i
`x[i:j]`	(j-i) `take` (i `drop` x)
`hash(x)`
`len(x)`	`length x`
`x * y`	y `replicate` x
`x.capitalize()`
`x.center(y)`
`x.count()`
`x.decode()`	`decode...` family
`x.encode()`	`encode...` family
`x.endswith(y)`	y `isSuffixOf` x
`x.expandtabs()`
`x.find(y)`
`x.format(...)`
`x.index(y)`
`x.isalnum()`	`all isAlphaNum x`
`x.isalpha()`	`all isAlpha x`
`x.isdigit()`	`all isDigit x`
`x.islower()`	`all isLower x`
`x.isspace()`	`all isSpace x`
`x.istitle()`
`x.isupper()`	`all isUpper x`
`x.join(y)`	`intercalate x y`
`x.ljust(w)`
`x.lower()`	`toLower x`
`x.lstrip()`	`dropWhile isSpace`
`x.partition(y)`	`break (==y) x`
`x.replace(y,z)`
`x.rfind(y)`
`x.rindex(y)`
`x.rjust(y)`
`x.rpartition(y)`
`x.rsplit(y)`
`x.rstrip(y)`
`x.split(y)`
`x.splitlines()`	`lines x`
`x.startswith(y)`	y `isPrefixOf` x
`x.strip()`
`x.swapcase()`
`x.title()`
`x.translate(y)`
`x.upper()`	`toUpper x`
`x.zfill()`

Planet Haskell

July 02, 2009

July 01, 2009

June 30, 2009

Scrap Your Boilerplate---Prologically!

Notable Updates

The Good

The Bad

The brilliant fix (no need to thank me, Mr. Bezos)

June 29, 2009

Announcements

Discussion

Blog noise

Quotes of the Week

About the Haskell Weekly News

DHS Topic: Highly Scalable Identity Management Tools

DOE Topic: Grid 2.0: Collaboration and Sharing on the Grid

About Galois, Inc.

June 28, 2009

What it is

What is isn’t