Planet Haskell

by shapr at May 16, 2012 02:53 PM · my

make install
./configure --disable-hardening
grep HARDEN config.log

clang: warning: argument unused during compilation: '-foo'
CC="$srcdir/scripts/wrap-compiler-for-flag-check $CC"
export DEB_BUILD_MAINT_OPTIONS = hardening=-stackprotector
-include /usr/share/dpkg/buildflags.mk
$ ./build.sh --disable-hardening
+ autoreconf -fi
+ ./configure --disable-hardening
...
+ make
...
$ ~/checksec.sh --file src/test
No RELRO       No canary found  NX enabled  No PIE

$ ./build.sh
+ autoreconf -fi
+ ./configure
...
checking whether C compiler accepts -fno-strict-overflow... yes
checking whether C++ compiler accepts -fno-strict-overflow... yes
checking whether C compiler accepts -D_FORTIFY_SOURCE=2... yes
checking whether C++ compiler accepts -D_FORTIFY_SOURCE=2... yes
checking whether C compiler accepts -fstack-protector-all... yes
checking whether C++ compiler accepts -fstack-protector-all... yes
checking whether the linker accepts -fstack-protector-all... yes
checking whether C compiler accepts -Wstack-protector... yes
checking whether C++ compiler accepts -Wstack-protector... yes
checking whether C compiler accepts --param ssp-buffer-size=1... yes
checking whether C++ compiler accepts --param ssp-buffer-size=1... yes
checking whether C compiler accepts -fPIE... yes
checking whether C++ compiler accepts -fPIE... yes
checking whether the linker accepts -fPIE -pie... yes
checking whether the linker accepts -Wl,-z,relro... yes
checking whether the linker accepts -Wl,-z,now... yes
...
+ make
...
$ ~/checksec.sh --file src/test
Full RELRO     Canary found     NX enabled  PIE enabled

b80:  sub   $0x18,%rsp
b84:  mov   %fs:0x28,%rax
b8d:  mov   %rax,0x8(%rsp)

      ... function body ...

b94:  mov   0x8(%rsp),%rax
b99:  xor   %fs:0x28,%rax
ba2:  jne   bb4 <c_fun+0x34>

      ... normal epilogue ...

bb4:  callq 9c0 <__stack_chk_fail@plt>
$ ./build.sh LDFLAGS=-static
+ autoreconf -fi
+ ./configure LDFLAGS=-static
...
checking whether C compiler accepts -fPIE... yes
checking whether C++ compiler accepts -fPIE... yes
checking whether the linker accepts -fPIE -pie... no
...
+ make
...
$ file src/test
src/test: ELF 64-bit LSB executable, x86-64, version 1 (GNU/Linux),
statically linked, for GNU/Linux 2.6.26, not stripped
$ ~/checksec.sh --file src/test
Partial RELRO  Canary found     NX enabled  No PIE

exec: ../dist/build/pgtest/pgtest
args:
    - production
host: pgtest
postgres: true
rm -f pgtest.keter
tar zcfv pgtest.keter dist/build/pgtest/pgtest static config
b <- buttonNew
image <- imageNewFromStock stockAdd IconSizeSmallToolbar
containerAdd b image
set b [buttonRelief := ReliefNone]
on b buttonActivated {
     ... button activated action ...
}

-- | A GADT describing abstracted, user interface components for manipulating
-- values of type a.
data VE a where
    -- | A String field
    Entry :: VE String

    -- | An enumeration. A list of label string are supplied,
    -- the VE value is the integer index of the selected label.
    EnumVE :: [String] -> VE Int

    -- | Annotate a VE with a text label
    Label :: String -> VE a -> VE a

    -- | A "product" VE that combines values from two other VEs
    AndVE :: (VE a) -> (VE b) -> VE (a,b)

    -- | A "sum" VE that captures the value from either of two other VEs
    OrVE  :: (VE a) -> (VE b) -> VE (Either a b)

    -- | A VE for manipulating  a list of values. The supplied function lets the
    -- the VE display the list items to the user (eg for selection).
    ListVE :: (a->String) -> VE a -> VE [a]

    -- | Convert a VE over a type a, to a VE over a type b, given
    -- the necessary mappings. Either String captures the potential
    -- failure in the mapping.
    MapVE :: (a -> Either String b) -> (b -> a) -> VE a -> VE b

    -- | Annotate a VE with a default value
    DefaultVE :: a -> VE a -> VE a

-- A typeclass to build VEs
class HasVE a where
  mkVE :: VE a

(.*.) = AndVE
(.+.) = OrVE
infixr 5 .*.
infixr 5 .+.

data Gender = Male | Female deriving (Show,Enum)

data Person = Person {
    st_name :: String,
    st_age :: Int,
    st_gender :: Gender
} deriving (Show)

instance HasVE Person
  where
    mkVE = MapVE toStruct fromStruct
        (   Label "Name" nonEmptyString
        .*. Label "Age"   mkVE
        .*. Label "Gender"   mkVE
        )
      where
        toStruct (a,(b,c)) = Right (Person a b c)
        fromStruct (Person a b c) = (a,(b,c))

nonEmptyString :: VE String
nonEmptyString = ...

instance HasVE Int ...
instance HasVE String ...
instance HasVE Gender ...

data GTKWidget a = GTKWidget {
    ui_widget :: Widget,
    ui_set :: a -> IO (),
    ui_get :: IO (ErrVal a),
    ui_reset :: IO ()
}

uiGTK  :: VE  a -> IO (GTKWidget a)

data ModalDialog e a = ModalDialog {
    md_dialog :: Dialog,
    md_gw :: GTKWidget a,
    md_run :: IO (Maybe a)
}

modalDialogNew :: String -> VE a -> IO (ModalDialog a)

dialog <- modalDialogNew "Example 2" (mkVE :: Person)
ma <- md_run dialog

data Team = Team {
    t_leader :: Person,
    t_followers :: [Person]
} deriving (Show)

instance HasVE Team ...

data VEJSON a = VEJSON {
        uj_tojson ::  a -> DA.Value,
        uj_fromjson :: DA.Value -> Maybe a
}

uiJSON :: VE ConstE a -> VEJSON a

#!/usr/bin/env python

from sys import argv
from collections import Counter

if __name__ == "__main__":
    with open(argv[1]) as f:
        c = Counter(i.partition("-")[0] for i in f)

    for k,v in c.most_common():
        print '{:>4} {}'.format(v,k)
module Main where

import System.Environment (getArgs)
import qualified Data.Text as T hiding (map, head, zip)
import qualified Data.Text.IO as TI (readFile)
import Data.Map hiding (map)

type Counter = (T.Text, Int)

mapUnpack :: Counter -> String
mapUnpack (k,v) = show v ++ " " ++ T.unpack k

sortMapByValue :: Map T.Text Int -> [Counter]
sortMapByValue = rqsort . toList

-- copied & modified by LYHGG in the recusion chapter
-- doing in reverse order as to better suit the output
rqsort :: [Counter] -> [Counter]
rqsort [] = []
rqsort ((k,v):xs) =
    let smallerSorted = rqsort [(k',v') | (k',v') <- xs, v' <= v]
        biggerSorted  = rqsort [(k',v') | (k',v') <- xs, v' > v]
    in biggerSorted ++ [(k,v)] ++ smallerSorted

main :: IO ()
main = do
    results <- getArgs >>= TI.readFile . head
    let results' = map (\x -> T.replace space nothing $ head $ T.splitOn dash x) $ T.lines results
    let results'' = fromListWith (+) . zip results' $ repeat (1 :: Int)
    mapM_ (print . mapUnpack) $ sortMapByValue results''
    where dash    = T.pack "-"
          space   = T.pack " "
          nothing = T.pack ""
class QueryResults a where
    convertResults :: [Field] -> [Maybe ByteString] -> Either SomeException a

instance (Result a, Result b) => QueryResults (a,b) where
    convertResults [fa,fb] [va,vb] = do
        !a <- convert fa va
        !b <- convert fb vb
        return (a,b)
    convertResults fs vs  = convertError fs vs 2

-- RowParser has instances for Applicative, Alternative, and Monad
class FromRow a where
    fromRow :: RowParser a

-- field is exported from Database.PostgreSQL.Simple.FromRow
field :: FromField a => RowParser a

instance (FromField a, FromField b) => FromRow (a,b) where
    fromRow = (,) <$> field <*> field

data a :. b = a :. b 

infixr 3 :.

instance (FromRow a, FromRow b) => FromRow (a :. b) where
   fromRow = (:.) <$> fromRow <*> fromRow

CREATE TABLE users                     (uid int not null, username text   not null);
CREATE TABLE posts   (pid int not null, uid int not null, content  text   not null);
CREATE TABLE ratings (pid int not null, uid int not null, score    float4 not null);

data User = User { u_uid :: Int, username :: Text }

instance FromRow User where
  fromRow = User <$> field <*> field

data Post = Post { p_pid :: Int, p_uid :: Int,  content :: Text } 

instance FromRow Post where
  fromRow = Post <$> field <*> field <*> field

type Score = Float

    rows :: [User :. Post :. Only Score] <- 
       query conn [sql|  SELECT u.*, p.*, avg(r.score) as avg_score
                           FROM users as u JOIN posts as p JOIN ratings as r  
                                ON u.uid = p.uid AND p.pid = r.pid
                          GROUP BY p.pid
                          ORDER BY avg_score DESC                             |] ()
    forM rows $ \(user :. post :. Only score) -> do
        -- generate the HTML for a single post here

{-# LANGUAGE GADTs, TypeFamilies, TypeOperators #-}
import Prelude hiding (head, tail, (++), (+), replicate)
import Data.Natural
data Zero

data Succ nat
data List el len where

    Nil  ::                      List el Zero

    Cons :: el -> List el len -> List el (Succ len)
toList :: List el len -> [el]
toList Nil           = []
toList (Cons el els) = el : toList els
instance (Show el) => Show (List el len) where

    show = show . toList
head :: List el (Succ len) -> el
head (Cons el _) = el
tail :: List el (Succ len) -> List el len
tail (Cons _ els) = els
infixl 6 :+

type family nat1 :+ nat2 :: *

type instance Zero      :+ nat2 = nat2
type instance Succ nat1 :+ nat2 = Succ (nat1 :+ nat2)
infixr 5 ++

(++) :: List el len1 -> List el len2 -> List el (len1 :+ len2)
Nil         ++ list = list
Cons el els ++ list = Cons el (els ++ list)
data Nat nat where

    Zero ::            Nat Zero

    Succ :: Nat nat -> Nat (Succ nat)
toNatural :: Nat nat -> Natural
toNatural Zero       = 0
toNatural (Succ nat) = succ (toNatural nat)

instance Show (Nat nat) where

    show = show . toNatural
infixl 6 +

(+) :: Nat nat1 -> Nat nat2 -> Nat (nat1 :+ nat2)
Zero      + nat2 = nat2
Succ nat1 + nat2 = Succ (nat1 + nat2)
replicate :: Nat len -> el -> List el len
replicate Zero       _  = Nil
replicate (Succ len) el = Cons el (replicate len el)
infix 4 :==

data val1 :== val2 where

    Refl :: val :== val
instance Show (val1 :== val2) where

    show Refl = "Refl"
rightUnit :: Nat nat -> nat :+ Zero :== nat
rightUnit Zero       = Refl
rightUnit (Succ nat) = case rightUnit nat of
                           Refl -> Refl
assoc :: Nat nat1                                          ->
         Nat nat2                                          ->
         Nat nat3                                          ->
         (nat1 :+ nat2) :+ nat3 :== nat1 :+ (nat2 :+ nat3)
assoc Zero        nat2 nat3 = Refl
assoc (Succ nat1) nat2 nat3 = case assoc nat1 nat2 nat3 of
                                  Refl -> Refl
descendingTree [] = E
descendingTree [x] = T E x E
descendingTree xs = T l x r
    where x = maximum xs
          (ls,_:rs) = L.break (== x) xs
          l = descendingTree ls
          r = descendingTree rs

> :m Math.Algebras.Structures Math.Combinatorics.CombinatorialHopfAlgebra
> descendingTree [3,5,1,4,2]
T (T E 3 E) 5 (T (T E 1 E) 4 (T E 2 E))

shape :: PBT a -> PBT ()
shape t = fmap (\_ -> ()) t

> shape $ T (T E 3 E) 5 (T (T E 1 E) 4 (T E 2 E))
T (T E () E) () (T (T E () E) () (T E () E))

descendingTreeMap :: (Eq k, Num k) => Vect k SSymF -> Vect k (YSymF ())
descendingTreeMap = nf . fmap (\(SSymF xs) -> (YSymF . shape .  descendingTree) xs)
True

True

> ssymF [3,2,1] * ssymF [1,2]
F [3,2,1,4,5]+F [3,2,4,1,5]+F [3,2,4,5,1]+F [3,4,2,1,5]+F [3,4,2,5,1]+F [3,4,5,2,1]+F [4,3,2,1,5]+F [4,3,2,5,1]+F [4,3,5,2,1]+F [4,5,3,2,1]

> comult $ ssymF [3,5,1,4,2]
(F [],F [3,5,1,4,2])+(F [1],F [4,1,3,2])+(F [1,2],F [1,3,2])+(F [2,3,1],F [2,1])+(F [2,4,1,3],F [1])+(F [3,5,1,4,2],F [])

prop_HopfAlgebraMorphism f x = (f . antipode) x == (antipode . f) x

> quickCheck (prop_HopfAlgebraMorphism descendingTreeMap)
+++ OK, passed 100 tests.
$('canvas').each(function(i,e){ var img = e.toDataURL("image/png"); $(e).replaceWith(  $('<img src="'+img+'"/>').attr({width: $(e).attr("width"), height: $(e).attr("height"), style: $(e).attr("style") }) ) });

(define quote
    (vau (x) env
        x))
(define list (vau xs env
    (if (null? xs)
        (quote ())
        (cons
            (eval env (car xs))
            (eval env (cons list (cdr xs)))))))
(eval env (cons list (cdr xs)))
(cons list (cdr xs))
(<some-value-representing-an-operative> 2 3)
( (vau (x) _ x) 3 )
( ;; local frame
  ((x 3))

  ;; global frame
  ((cons <operative>)
   (car  <operative>)
   ...) )
(define (bind param val) (cond
    ((and (null? param) (null? val))
        '())
    ((eq? param '_)
        '())
    ((symbol? param)
        (list (list param val)))
    ((and (pair? param) (pair? val))
        (append
            (bind (car param) (car val))
            (bind (cdr param) (cdr val))))
    (else
        (error "can't bind" param val))))
(bind
    '((a b) . c)
    '((1 2) 3 4))
((a 1)
 (b 2)
 (c (3 4)))
(define (m-lookup name env)
    (if (null? env)
        (error "could not find" name)
        (let ((binding (assq name (car env))))
            (if binding
                binding
                (m-lookup name (cdr env))))))
(define (m-eval env exp) (cond
    ((symbol? exp)
        (cadr (m-lookup exp env)))
    ((pair? exp)
        (m-operate env (m-eval env (car exp)) (cdr exp)))
    (else
        exp)))

(define (m-operate env operative operands)
    (operative env operands))
(define (m-vau static-env vau-operands)
    (let ((params    (car   vau-operands))
          (env-param (cadr  vau-operands))
          (body      (caddr vau-operands)))

        (lambda (dynamic-env operands)
            (m-eval
                (cons
                    (bind
                        (cons env-param   params)
                        (cons dynamic-env operands))
                    static-env)
                body))))
(define (make-global-frame)
    (define (wrap-primitive fun)
        (lambda (env operands)
            (apply fun (map (lambda (exp) (m-eval env exp)) operands))))
    (list
        (list 'vau m-vau)
        (list 'eval    (wrap-primitive m-eval))
        (list 'operate (wrap-primitive m-operate))
        (list 'lookup  (wrap-primitive m-lookup))
        (list 'bool    (wrap-primitive (lambda (b t f) (if b t f))))
        (list 'eq?     (wrap-primitive eq?))
        ; more like these
        ))

(define global-env (list (make-global-frame)))
(set-car! env
    (cons
        (cons <name> (cons <value> null))
        (car env)))
((vau (name-of-define null) env
    (set-car! env (cons
        (cons name-of-define
            (cons (vau (name exp) defn-env
                    (set-car! defn-env (cons
                        (cons name (cons (eval defn-env exp) null))
                        (car defn-env))))
                null))
        (car env))))
    define ())
(define if (vau (b t f) env
    (eval env
        (bool (eval env b) t f))))
(define wrap (vau (operative) oper-env
    (vau args args-env
        (operate args-env
            (eval    oper-env operative)
            (operate args-env list args)))))
(define lambda (vau (params body) static-env
    (wrap
        (eval static-env
            (list vau params '_ body)))))
(define fact (lambda (n)
    (if (<= n 1)
        1
        (* n (fact (- n 1))))))
(lambda (x) a b c)
(lambda (x) (begin a b c))
(define last (lambda (xs)
    (if (null? (cdr xs))
        (car xs)
        (last (cdr xs)))))

(define begin (lambda xs (last xs)))
(define set! (vau (name exp) env
    (set-cdr!
        (lookup name env)
        (list (eval env exp)))))

(set! lambda
    ((lambda (base-lambda)
        (vau (param . body) env
            (eval env (list base-lambda param (cons begin body)))))
    lambda))
((lambda (base-lambda) ...) lambda)
(define apply (wrap (vau (operative args) env
    (eval env (cons
        operative
        (map (lambda (x) (list quote x)) args))))))
(execute-file "prelude.qop")
$ guile -l qoppa.scm
guile> (m-eval global-env '(fact 5))
$1 = 120
guile> (execute-file "qoppa.scm")
$2 = done
guile> (m-eval global-env '(m-eval global-env '(fact 5)))
$3 = 120
> {-# LANGUAGE GADTs #-}
> import Control.Applicative
> data Option a = Option
>   { optName :: String
>   , optParser :: String -> Maybe a
>   }
> 
> instance Functor Option where
>   fmap f (Option name p) = Option name (fmap f . p)
> 
> optMatches :: Option a -> String -> Bool
> optMatches opt s = s == '-' : '-' : optName opt
> data Parser a where
>   NilP :: a -> Parser a
>   ConsP :: Option (a -> b)
>         -> Parser a -> Parser b
> 
> instance Functor Parser where
>   fmap f (NilP x) = NilP (f x)
>   fmap f (ConsP opt rest) = ConsP (fmap (f.) opt) rest
> 
> instance Applicative Parser where
>   pure = NilP
>   NilP f <*> p = fmap f p
>   ConsP opt rest <*> p =
>     ConsP (fmap uncurry opt) ((,) <$> rest <*> p)
1
2
3

opt :: Option (a -> b -> c)
rest :: Parser a
p :: Parser b

1

fmap uncurry opt :: Option ((a, b) -> c)

1

(,) <$> rest <*> p :: Parser (a, b)

> option :: String -> (String -> Maybe a) -> Parser a
> option name p = ConsP (fmap const (Option name p)) (NilP ())
> optionR :: Read a => String -> Parser a
> optionR name = option name p
>   where
>     p arg = case reads arg of
>       [(r, "")] -> Just r
>       _       -> Nothing
> data User = User
>   { userName :: String
>   , userId :: Integer
>   } deriving Show
> parser :: Parser User
> parser = User <$> option "name" Just <*> optionR "id"
> runParser :: Parser a -> [String] -> Maybe (a, [String])
> runParser (NilP x) args = Just (x, args)
> runParser (ConsP _ _) [] = Nothing
> runParser p (arg : args) =
>   case stepParser p arg args of
>     Nothing -> Nothing
>     Just (p', args') -> runParser p' args'
> 
> stepParser :: Parser a -> String -> [String] -> Maybe (Parser a, [String])
> stepParser p arg args = case p of
>   NilP _ -> Nothing
>   ConsP opt rest
>     | optMatches opt arg -> case args of
>         [] -> Nothing
>         (value : args') -> do
>           f <- optParser opt value
>           return (fmap f rest, args')
>     | otherwise -> do
>         (rest', args') <- stepParser rest arg args
>         return (ConsP opt rest', args')
> ex1 :: Maybe User
> ex1 = fst <$> runParser parser ["--name", "fry", "--id", "1"]
> {- Just (User {userName = "fry", userId = 1}) -}
> ex2 :: Maybe User
> ex2 = fst <$> runParser parser ["--id", "2", "--name", "bender"]
> {- Just (User {userName = "bender", userId = 2}) -}
> ex3 :: Maybe User
> ex3 = fst <$> runParser parser ["--name", "leela"]
> {- Nothing -}
type Graph = Map Node [Node]

type LabelledGraph n e = Map Node (n, [(Node,e)])

type PlanarGraph n e = ( Map Node (n, [Edge])
                       , Map Edge (Node, e, Node, Edge)
                       )

type LabelledGraph' n e = Map Node (n, [(Node,[e])])

type FGLGraph n e = Map Node ([(Node,e)], n, [(Node,e)])

[( node index
 , node label
 , [( edge index
    , node index that this edge points to
    , edge label
    , inverse edge index
   )]
)]

class (Graph (SubGraph gt)) => GraphTransformer gt where
    type SubGraph gt :: *

    .....

compositions 0 = [[]]
compositions n = [i:is | i <- [1..n], is <- compositions (n-i)]

> :m Math.Algebras.Structures Math.Combinatorics.CombinatorialHopfAlgebra
> compositions 4
[[1,1,1,1],[1,1,2],[1,2,1],[1,3],[2,1,1],[2,2],[3,1],[4]]

newtype QSymM = QSymM [Int] deriving (Eq)

instance Ord QSymM where
    compare (QSymM xs) (QSymM ys) = compare (sum xs, xs) (sum ys, ys)

instance Show QSymM where
    show (QSymM xs) = "M " ++ show xs

qsymM :: [Int] -> Vect Q QSymM
qsymM xs | all (>0) xs = return (QSymM xs)
         | otherwise = error "qsymM: not a composition"

M [1,2]+2M [3,1]
quasiShuffles (x:xs) (y:ys) = map (x:) (quasiShuffles xs (y:ys)) ++
                              map ((x+y):) (quasiShuffles xs ys) ++
                              map (y:) (quasiShuffles (x:xs) ys)
quasiShuffles xs [] = [xs]
quasiShuffles [] ys = [ys]

> quasiShuffles [1,2] [3]
[[1,2,3],[1,5],[1,3,2],[4,2],[3,1,2]]

instance (Eq k, Num k) => Algebra k QSymM where
    unit x = x *> return (QSymM [])
    mult = linear mult' where
        mult' (QSymM alpha, QSymM beta) = sumv [return (QSymM gamma) | gamma <- quasiShuffles alpha beta]

instance (Eq k, Num k) => Coalgebra k QSymM where
    counit = unwrap . linear counit' where counit' (QSymM alpha) = if null alpha then 1 else 0
    comult = linear comult' where
        comult' (QSymM gamma) = sumv [return (QSymM alpha, QSymM beta) | (alpha,beta) <- deconcatenations gamma]

> comult $ qsymM [1,2,3]
(M [],M [1,2,3])+(M [1],M [2,3])+(M [1,2],M [3])+(M [1,2,3],M [])

instance (Eq k, Num k) => Bialgebra k QSymM where {}

coarsenings (x1:x2:xs) = map (x1:) (coarsenings (x2:xs)) ++ coarsenings ((x1+x2):xs)
coarsenings xs = [xs] -- for xs a singleton or null

> coarsenings [1,2,3]
[[1,2,3],[1,5],[3,3],[6]]

instance (Eq k, Num k) => HopfAlgebra k QSymM where
    antipode = linear antipode' where
        antipode' (QSymM alpha) = (-1)^length alpha * sumv [return (QSymM beta) | beta <- coarsenings (reverse alpha)]

COMPLETENESS:
  Illumina mapped:      77.0411%
  PSL hits:
    all_transcripts_165.rna.psl.uniq:   92.0361%, 28398 matching sequences
    l.salmonis-mtDNA.dna.psl.uniq:      90.1952%, 3 matching sequences
    fosmids_fwd.dna.psl.uniq:   66.002%, 9411 matching sequences
    fosmids_rev.dna.psl.uniq:   63.7143%, 5886 matching sequences
FRAGMENTATION:
  N25/50/75:    76308   46116   24010   using 600000000 as total size.
  Illumina pairs proportion:    67.7091%
ACCURACY:
  SFF average match:    148.565
  Illum average match:  46.7718
REDUNDANCY:
  Total size: 675758373, 112.626% of estimated size.
  SFF reads mapped:     117.235%
  PSL score, total vs unique:
    all_transcripts_165.rna.psl:            233.564%    67439222/28873929
    l.salmonis-mtDNA.dna.psl:       179.406%    76115/42426
    fosmids_fwd.dna.psl:            1046.08%    67459110/6448777
    fosmids_rev.dna.psl:            963.377%    37459791/3888385
foo: bar
	process bar > foo
%.o: %.c
	$(CC) $<
STATS    := $(patsubst %.bam,%.stats,$(BAMS))
all-fstats: $(FSTATS)
	for a in $(FSTATS); do echo "$a	`grep % $a | tr '\n' '\t'`"; done > $@
all-fstats.tab: all-fstats
	sed -e 's/\t[^\t]*(\([0-9][0-9]*\.[0-9]*%\))/\t\1/g' < $< | \
		awk ' BEGIN { OFS="\t" } { print; mapped += $2; paired += $3; single += $4 } \
		END { print "totals:    ",mapped/NR "%",paired/NR "%",single/NR "%" }' > $@
darcs get http://malde.org/~ketil/asmeval
sudo apt-get install cabal-install darcs bwa
cabal update
darcs get http://malde.org/~ketil/asmeval
cd asmeval
cabal install
asmeval GENOME=mygenome.fasta ESTS=transcripts.fasta
GENOME := mygenome.fasta
ESTS   := transcripts.fasta
nice nohup time asmeval -j8 &
nice nohup time asmeval THREADS=4 -j2 &
{-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell, KindSignatures,
             TypeFamilies, FlexibleContexts, GADTs, MultiParamTypeClasses,
             FlexibleInstances, TypeSynonymInstances
  #-}
import Yesod.Core
import Yesod.Persist
import Data.Text (Text)
import Database.Persist.Sqlite
import Network.Wai.Handler.Warp (run)
import Yesod.Json
import Yesod.Form.Jquery (YesodJquery)
import Network.HTTP.Types (status201, status204)
import Yesod.Javascript
import Data.Aeson hiding (object)
import Control.Applicative ((<$>), (<*>))
import Text.Lucius (lucius)
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
Todo
    text Text
    done Bool
|]

instance ToJSON (Entity Todo) where
    toJSON (Entity tid (Todo text done)) = object
        [ "id" .= tid
        , "text" .= text
        , "done" .= done
        ]
instance FromJSON Todo where
    parseJSON (Object o) = Todo
        <$> o .: "text"
        <*> o .: "done"
    parseJSON _ = fail "Invalid todo"
data App = App ConnectionPool

mkYesod "App" [parseRoutes|
/ HomeR GET
/todo TodosR GET PUT
/todo/#TodoId TodoR GET DELETE
|]
instance Yesod App
instance YesodPersist App where
    type YesodPersistBackend App = SqlPersist
    runDB f = do
        App pool <- getYesod
        runSqlPool f pool
instance YesodJquery App
getTodosR :: Handler RepJson
getTodosR =
    runDB (selectList [] []) >>= jsonToRepJson . asTodoEntities
  where
    asTodoEntities :: [Entity Todo] -> [Entity Todo]
    asTodoEntities = id

putTodosR :: Handler ()
putTodosR = do
    todo <- parseJsonBody_
    tid <- runDB $ insert todo
    sendResponseCreated $ TodoR tid

getTodoR :: TodoId -> Handler RepJson
getTodoR tid = runDB (get404 tid) >>= jsonToRepJson . Entity tid

deleteTodoR :: TodoId -> Handler ()
deleteTodoR tid = do
    runDB (delete tid)
    sendResponseStatus status204 ()
jsTodoText :: JSValue (Entity Todo) -> JSValue Text
jsTodoText = jsGetter "text"

jsTodoDone :: JSValue (Entity Todo) -> JSValue Bool
jsTodoDone = jsGetter "done"
jsTodo :: JSValue Text -> JSValue Bool -> JSValue Todo
jsTodo text done = jsonObject
  [ ("text", jsCast text)
  , ("done", jsCast done)
  ]
getHomeR :: Handler RepHtml
getHomeR = defaultLayout $ do
    toWidget [lucius|
.done {
    color: #999;
}
|]
    runJS $ do
        (todos, reload) <- ajaxJson TodosR
        list <- htmlOutput $ wrapTag "ul" $ jsjoin $ jsfor todos $ \todo ->
            wrapTagClass "li"
                (jsif (jsTodoDone todo) "done" "notdone")
                $ jsToHtml $ jsTodoText todo
        countWidget <- textOutput $ jsShowInt $ jslength todos
        (taskWidget, taskValue) <- textInput
        putter <- putJson TodosR (jsTodo taskValue jsFalse) reload
        submitWidget <- button [whamlet|Add Item|] putter
        lift [whamlet|
<h2>Item count: ^{countWidget}
^{list}
<form>
    Enter new task: #
    ^{taskWidget}
    ^{submitWidget}
|]
main :: IO ()
main = do
    pool <- createSqlitePool "todo.db3" 5
    runSqlPool (runMigration migrateAll) pool
    toWaiApp (App pool) >>= run 3000
import Graphics.Gloss
thePattern = [5,2,5,1,2]
initial g = (-1, 0.0, [], cycle thePattern)
step dt (hand, time, balls, pattern) = (newhand, newtime, newballs, newpattern)
    where (throw, newtime) = properFraction (time + dt)
          newhand    = if throw == 1 then -hand else hand
          thrown     = if throw == 1 then [ (hand, newtime, head pattern) ]
                                     else []
          newpattern = if throw == 1 then tail pattern else pattern
          newballs   = [ (bhand, btime + dt, height)
                       | (bhand, btime, height) <- balls,
                         btime + dt < fromIntegral height ]
                       ++ thrown
draw (hand, time, balls, pattern) = pictures [
    juggler,
    pictures [ ball b | b <- balls ]
    ]
ball (bhand, btime, height) = translate (50*x) (50*y) (circleSolid 10)
    where t = 1 - 2 * (btime / fromIntegral height)
          x = if even height then bhand else bhand * t
          y = if height < 3 then 0 else fromIntegral (height - 1) * (1 - t^2)
juggler = pictures [
    line [(-50, 0), (0, 25), (50, 0)],
    line [(-30, -100), (0, -50), (30, -100)],
    line [( 0, 25), (0, -50)],
    translate 0 50 (circle 25)
    ]
 -- Control.Concurrent.STM
 data STM a
 instance Monad STM

 atomically :: STM a -> IO a

 data TVar a
 newTVar   :: a -> STM (TVar a)
 readTVar  :: TVar a -> STM a
 writeTVar :: TVar a -> a -> STM ()

 retry  :: STM a
 orElse :: STM a -> STM a -> STM a

 type Account = TVar Int

 withdraw :: Account -> Int -> STM ()        
 withdraw acc amount = do
     bal <- readTVar acc
     writeTVar acc (bal - amount)

 deposit :: Account -> Int -> STM ()
 deposit acc amount = withdraw acc (- amount)

 -- still just a transaction
 transfer :: Account -> Account -> Int -> STM ()
 transfer from to amount = do
     deposit to amount
     withdraw from amount

 -- now we have an action!
 doTransfer :: Account -> Account -> Int -> IO ()
 doTransfer from to amount =
     atomically $ transfer from to amount

main = do
    v1 <- atomically $ newTVar "Joe"
    v2 <- atomically $ newTVar "Bob"
    done <- atomically $ newTVar 0
    -- thread A (you can just pretend forkDelayIO == forkIO)
    forkDelayIO . atomically $ do
                              -- transaction log if A runs first
        x <- readTVar v1      -- v1: Joe -> Joe
        y <- readTVar v2      -- v1: Joe -> Joe, v2: Sue -> Sue 
        writeTVar v1 "Sue"    -- v1: Joe -> Sue
        writeTVar v2 x        -- v1: Joe -> Sue, v2: Bob -> Joe 
        writeTVar v1 y        -- v1: Joe -> Bob, v2: Bob -> Joe
        modifyTVar done (+1)  -- (stm 2.3 but easy to define)
    -- thread B 
    forkDelayIO . atomically $ do
                              -- (if A runs first)
        writeTVar v1 "Jean"   -- v1: Bob -> Jean
        writeTVar v2 "Paul"   -- v1: Bob -> Jean, v2: Joe -> Paul
        modifyTVar done (+1)
    waitThreads 2 done
    people <- atomically $ do -- (if A runs first)
        p1 <- readTVar v1     -- v1: Jean -> Jean
        p2 <- readTVar v2     -- v1: Jean -> Jean, v2: Paul -> Paul
        return (p1, p2)
    print people -- if A runs first, (Jean, Paul)
                 -- if B runs first, (Paul, Jean).

-- boring details just for this example
forkDelayIO job = forkIO $
    randomRIO (1, 1000000) >>= threadDelay >> job
waitThreads n v = atomically $
    do { d <- readTVar v;  when (d < n) retry }

{-# LANGUAGE OverloadedStrings #-}
module Main where

import Control.Concurrent
import Control.Exception
import qualified Data.Text as T
import System.Environment
import qualified System.Remote.Label as Label
import System.Remote.Monitoring

mean :: Fractional a => [a] -> a
mean xs = sum xs / fromIntegral (length xs)

main :: IO ()
main = do
    handle <- forkServer "localhost" 8000
    label <- getLabel "args" handle
    args <- getArgs
    Label.set label $ T.intercalate " " $ map T.pack args
    -- Busy work:
    let loop n = do
            evaluate $ mean [1..n]
            threadDelay 2000
            loop n
    loop 1000000

class Monad m where
    return :: a -> m a
    (=<<) :: (a -> m b) -> m a -> m b
before :: (a -> m b) -> m a -> m b
after  :: (a -> b) -> a -> b
data Distance = Dist Double
data Mass = Mass Double
$ ghci ltmt.hs
GHCi, version 7.0.3: http://www.haskell.org/ghc/  :? for helpghci> :t Dist
Dist :: Double -> Distance
ghci> :t Mass
Mass :: Double -> Mass
ghci> :t Distance
<interactive>:1:1: Not in scope: data constructor `Distance'
data Pair a = MkPair a a
MkPair :: a -> a -> Pair a
values : types    ::   types : kinds
ghci> :k Distance
Distance :: *
ghci> :k Mass
Mass :: *
ghci> :k Dist
<interactive>:1:1: Not in scope: type constructor or class `Dist'
ghci> :k Pair
Pair :: * -> *
ghci> :k Pair Mass
Pair Mass :: *
data Tuple a b = Tuple a b
data HardA a = HardA (a Int)
data HardB a b c = HardB (a b) (c a Int)
module Tree where

data Tree a = Empty
            | Node a (Tree a) (Tree a)
            deriving (Eq, Show)

-- some binary trees

t0 = Empty
t1 = Node 1 Empty Empty
t3 = Node 2 (Node 1 Empty Empty) (Node 3 Empty Empty)

preorder_traversal f z tree = go tree z
  where
    go Empty        z = z
    go (Node v l r) z = let z'   = f v z     -- current node
                            z''  = go l z'   -- left subtree
                            z''' = go r z''  -- right subtree
                        in z'''

inorder_traversal f z tree = go tree z
  where
    go Empty        z = z
    go (Node v l r) z = let z'   = go l z    -- left subtree
                            z''  = f v z'    -- current node
                            z''' = go r z''  -- right subtree
                        in z'''

flatten traversal = reverse . traversal (:) []

test0i = flatten inorder_traversal t3   -- [1,2,3]
test0p = flatten preorder_traversal t3  -- [2,1,3]

inorder_traversal2 f z tree = go tree z
  where
    go Empty        z = z
    go (Node v l r) z = go r . f v . go l $ z

traverse step f z tree = go tree z
  where
    go Empty        z = z
    go (Node v l r) z = step (f v) (go l) (go r) z

preorder   = traverse $ \n l r -> r . l . n
inorder    = traverse $ \n l r -> r . n . l
postorder  = traverse $ \n l r -> n . r . l

test1p = flatten preorder t3   -- [2,1,3]
test1i = flatten inorder t3    -- [1,2,3]
test1o = flatten postorder t3  -- [1,3,2]

leftorder  = traverse $ \n l r -> l . n
rightorder = traverse $ \n l r -> r . n

treemin = leftorder min maxBound
treemax = rightorder max minBound

test2l = treemin t3 :: Int  -- 1
test2r = treemax t3 :: Int  -- 3

git-add
-p
git-commit -a
git-add -p
git-commit -a
git-commit -a -m ...
git-add -p
WIP
git-reset HEAD^
git-diff
git-add -p
git diff --cached
git-rebase --interactive
git-add -p
git-add
-p
git-rebase
--interactive
WIP
c-domain
        055a2f7 correction to bulk consumer template
        d9630bd DomainActivator half of Pobox Domain consumer
        ebebb4a Add HasDomain role to provide ->domain reader for domain consumers
        ade6ac6 stubbed domain test
        e170e77 start templates for Pobox domain consumers
        067ca81 stubbed Domain::ThumbTwiddler
        685a3ee cost calculations for DomainActivator
        ec8b1cc test fixes; trivial domain test passes now
        845b1f2 rename InvoiceCharge::CreateDomain to ..::RegisterDomain
(e)     6083a97 add durations to Domain consumers and charges
        c64fda0 tests for Domain::Activator consumer
        41e4292 repeat activator tests for 1-year and 3-year durations
        7d68065 tests for activator's replacement
(d)     87f3b09 move days_in_year to Moonpig::Util
        3cd9f3b WIP
        e5063d4 add test for sent invoice in domain.t
        c8dbf41 WIP
        9e6ffa4 add missing MakesReplacement stuff
        fc13059 bring in Net::OpenSRS module
(c)     52c18fb OpenSRS interface
        893f16f notes about why domain queries might fail
(b)     f64361f rename "croak" method to "fail" to avoid conflicts
        4e500ec Domain::Activator initial_invoice_charge_pairs
(a)     3c5cdd4 WIP

croak
Carp
git-checkout -b
cleanup c-domain
git-reset --hard c-domain
origin/c-domain
origin
WIP
git-reset HEAD^
git-status
         M lib/Pobox/Moonpig/Consumer/Domain/Activator.pm
         M lib/Pobox/Moonpig/Role/HasDomain.pm
         M lib/Pobox/Moonpig/TemplateSet.pm
        ?? bin/register_domains
         M t/consumer/domain.t
        ?? t/lib/MockOpenSRS.pm

git-status --short
git s
git-status
bin/register-domains
        % git add bin
        % git commit -m 'new register_domains utility program'

t/lib/MockOpenSRS.pm
git-add
-p
        % git add t/lib
        % git add -p
        ...
        % git s
        MM lib/Pobox/Moonpig/Consumer/Domain/Activator.pm
         M lib/Pobox/Moonpig/Role/HasDomain.pm
         M lib/Pobox/Moonpig/TemplateSet.pm
        A  t/lib/MockOpenSRS.pm
        MM t/consumer/domain.t
        % git ix
        ...

git ix
git diff
--cached
        % git commit -m 'mock OpenSRS object; add tests'

        % git stash
        % make test
        ...
        OK
        % git stash pop

git-stash
t/consumer/domain.t
git commit --amend
        % git diff
        ...
        % git add -p lib/Pobox/Moonpig/Role/HasDomain.pm
        ...
        % git commit -m 'Domains do not have explicit start dates'
        % git diff
        ...
        % git add -p
        ...
        % git commit --fixup :/mock

fixup!
:/text
        % git diff
        ...
        % git add -p ...
        ...
        % git commit -m 'Activator consumer can generate special charges'
        % git diff
        ...
        % git checkout lib/Pobox/Moonpig/Role/HasDomain.pm

HasDomain.pm
        % git diff
        ...
        % git add -u
        % git commit -m 'separate templates for domain-registering and domain-renewing consumers'

git-add -u
WIP
        a3c0b92 new register_domains utility program
        53d704d mock OpenSRS object; add tests
        a24acd8 Domains do not have explicit start dates
        17a915d fixup! mock OpenSRS object; add tests
        86e472b Activator consumer can generate special charges
        5b2ad2b separate templates for domain-registering and domain-renewing consumers

fixup!
        % git rebase -i --autosquash HEAD~6

--autosquash
git-rebase
        a3c0b92 new register_domains utility program
        ea8dacd Domains do not have explicit start dates
        297366a separate templates for domain-registering and domain-renewing consumers
        4ef0e28 mock OpenSRS object; add tests
        c3ab1eb Activator consumer can generate special charges

git-vee
git log --decorate --cherry-mark
--oneline --graph --boundary A"..."B
c-domain
cleanup
        % git vee c-domain
        * c3ab1eb (HEAD, cleanup) Activator consumer can generate special charges
        * 4ef0e28 mock OpenSRS object; add tests
        * 297366a separate templates for domain-registering and domain-renewing consumer
        * ea8dacd Domains do not have explicit start dates
        * a3c0b92 new register_domains utility program
        | * 3c5cdd4 (origin/c-domain, c-domain) WIP
        |/  
        o 4e500ec Domain::Activator initial_invoice_charge_pairs

git-vee
git-vee
ORIG_HEAD
git-vee remote
git-vee
git-treehash
HEAD
ORIG_HEAD
        % git treehash c-domain HEAD
        d360408d1afa90e0176aaa73bf8d3cae641a0850 HEAD
        f0fd6ea0de7dbe60520e2a69fbec210260370d78 c-domain

HasDomain.pm
git-diff
        % git diff c-domain
        diff --git a/lib/Pobox/Moonpig/Role/HasDomain.pm b/lib/Pobox/Moonpig/Role/HasDomain.pm
        index 3d8bb8c..21cb752 100644
        --- a/lib/Pobox/Moonpig/Role/HasDomain.pm
        +++ b/lib/Pobox/Moonpig/Role/HasDomain.pm
        @@ -5,7 +5,6 @@ use Carp qw(croak confess);
         use ICG::Handy qw(is_domain);
         use Moonpig::Types qw(Factory Time);
         use Moose::Util::TypeConstraints qw(duck_type enum subtype);
        -use MooseX::SetOnce;

         with (
           'Moonpig::Role::StubBuild',

        % git checkout -b wip-cleanup c8dbf41
        % git reset HEAD^
        % ... (a lot of git-add -p as above) ...
        ...

        % git vee c8dbf41
        * 4c6ff45 (wip-cleanup) get rid of unused twiddler test
        * b328de5 test full payment cycle
        * 201a4f2 abstract out pay_invoice operation
        * 55ae45e add upper limit (default 30d) to wait_until utility
        | * c8dbf41 WIP
        |/  
        o e5063d4 add test for sent invoice in domain.t

        % git treehash c8dbf41 HEAD
        7f52ba68923e2ede8fda407ffa9c06c5c48338ae
        % git checkout cleanup
        % git rebase wip-cleanup

git-treehash
wip-cleanup
cleanup
wip-cleanup
        % git vee c-domain
        * a425aa1 (HEAD, cleanup) Activator consumer can generate special charges
        * 2bb0932 mock OpenSRS object; add tests
        * a77bfcb separate templates for domain-registering and domain-renewing consumer
        * 4c44db2 Domains do not have explicit start dates
        * fab500f new register_domains utility program
        = 38018b6 Domain::Activator initial_invoice_charge_pairs
        = aebbae6 rename "croak" method to "fail" to avoid conflicts
        = 45a224d notes about why domain queries might fail
        = 80e4a90 OpenSRS interface
        = 27f4562 bring in Net::OpenSRS module
        = f5cb624 add missing MakesReplacement stuff
        * 4c6ff45 (wip-cleanup) get rid of unused twiddler test
        * b328de5 test full payment cycle
        * 201a4f2 abstract out pay_invoice operation
        * 55ae45e add upper limit (default 30d) to wait_until utility
        | * 3c5cdd4 (origin/c-domain, c-domain) WIP
        | = 4e500ec Domain::Activator initial_invoice_charge_pairs
        | = f64361f rename "croak" method to "fail" to avoid conflicts
        | = 893f16f notes about why domain queries might fail
        | = 52c18fb OpenSRS interface
        | = fc13059 bring in Net::OpenSRS module
        | = 9e6ffa4 add missing MakesReplacement stuff
        | * c8dbf41 WIP
        |/  
        o e5063d4 add test for sent invoice in domain.t

git-vee
git-commit -a
git-add -u
git-commit
git-commit -a
> set QTDIR=C:\QtSDK\Desktop\Qt\4.8.0\msvc2010
> set QMAKESPEC=%QTDIR%\mkspecs\win32-msvc2010
> set PATH=%PATH%;%QTDIR%\bin;C:\QtSDK\QtCreator\bin
@echo off
setlocal
call "C:\Program Files (x86)\Microsoft Visual Studio 10.0\VC\vcvarsall.bat"
start C:\Eclipse\Indigo\eclipse.exe
endlocal
#include <iostream>
#include <Qt/QtGui>

int main(int argc, char **argv)
{
    std::cout << __FUNCTION__ << std::endl;
    QApplication app(argc, argv);
    return(app.exec());
}
TEMPLATE = app
TARGET = 
DEPENDPATH += .
INCLUDEPATH += .

CONFIG += qt

HEADERS +=
SOURCES += main.cxx
> qmake ..\Test.pro
  %   cumulative      self          
 time    seconds   seconds  name    
 68.75      0.14      0.14  scmutil.py:546:revrange
  6.25      0.01      0.01  cmdutil.py:1006:walkchangerevs
  6.25      0.01      0.01  revlog.py:241:__init__
  [...blah blah blah...]
  0.00      0.01      0.00  util.py:237:__get__
---
Sample count: 16
Total time: 0.200000 seconds

Protections	Netbook	Laptop	Desktop
Everything	16.0	4.4	2.1
All except PIE	4.7	3.3	2.2
All except stack protector	11.0	1.0	1.1

Planet Haskell

May 16, 2012

Coq

Ur/Web

Haskell

Conclusion

May 15, 2012

May 14, 2012

Goals for the project

Later

News and discussions

Issues resolved in the last week (3)

Patches applied in the last week (77)

May 13, 2012

How it works

Complications

The flags

Demonstration

Performance

May 12, 2012

May 11, 2012

Advantages

Usage

Keter Bundles

How it Works

TODO

May 10, 2012

May 09, 2012

An Abstract UI

A GTK UI

JSON Serialisation

Related Work

Future Work

May 08, 2012

May 07, 2012

May 05, 2012

May 04, 2012

May 03, 2012

May 02, 2012

Prerequisites

Dependently typed programming

Theorem proving

May 01, 2012

April 30, 2012

April 29, 2012

News and discussions

Issues resolved in the last week (4)

Patches applied in the last week (111)

April 28, 2012

Operatives in Qoppa

Implementing Qoppa

Qoppa builtins

Scheme as a Qoppa library

Testing

April 27, 2012

What is a graph?

Planar graphs

Library implementation

Abstract node identifiers

Half-edges

Distinguishing between structure and content

Serialisation and encoding

Plans for the new graph library

April 24, 2012

April 23, 2012

Measures and input data

Defining qualities

Completeness

Fragmentation