more blog than sense

need

My fancy
hello-world program.

EMIT: My
EMIT: fancy
EMIT: hello-world
EMIT: program.

{ open Lexing }

let nonspace = [^ ' ' '\t' '\n']+
let otherwise = _

rule token = parse
              (* non-space sequences are tokens. *)
    nonspace  { ("TOK", lexeme lexbuf) }
              (* 'eof' is special: always include a rule for it. *)
  | eof       { ("EOF", lexeme lexbuf) } 
              (* everything else: in this case, whitespace. *)
  | otherwise { token lexbuf }      (* "ignore" *)

open Pcaml

let replace_lexer lxrule = 
  let wrapped_lexer =     (* for details, see http://is.gd/960EQ *)
    { Plexing.tok_func  = (Token.lexer_func_of_ocamllex lxrule);
      Plexing.tok_using = (fun _ -> ());
      tok_removing      = (fun _ -> ());
      tok_match         = Plexing.default_match;
      tok_comm          = None;
      tok_text          = Plexing.lexer_text }
  in 
    Grammar.Unsafe.gram_reinit Pcaml.gram wrapped_lexer

let () = replace_lexer Simplelex.token

let echo token loc =
  (<:str_item< print_endline ("EMIT: " ^ $str:token$) >>, loc);;

EXTEND
implem:
[ [ st = LIST0 [ s = TOK -> echo s loc ]; EOF -> (st, false) ] ];
END

simplelex.ml: simplelex.mll
        ocamllex simplelex.mll

pa_echo.cma: pa_echo.ml simplelex.ml
        ocamlc -I +camlp5 -pp 'camlp5o pa_extend.cmo q_MLast.cmo' \
                -a -o pa_echo.cma \
                simplelex.ml pa_echo.ml

hello: hello.src pa_echo.cma
        ocamlopt -pp 'camlp5 ./pa_echo.cma pr_dump.cmo -impl' \
        -impl hello.src -o hello

camlp5 ./pa_echo.cma pr_r.cmo -impl hello.src | sed "s/; /;\n/g"

print_endline ("EMIT: " ^ "This");
print_endline ("EMIT: " ^ "is");
print_endline ("EMIT: " ^ "my");
print_endline ("EMIT: " ^ "hello-world");
print_endline ("EMIT: " ^ "program.");

(* define the parser *)
let null_parser stream =
  let loc = Ploc.dummy 
  and directive_found = false 
  in
    ( [ (<:str_item< print_endline "|your code          |"; >>, loc);
        (<:str_item< print_endline "|has been replaced  |"; >>, loc);
        (<:str_item< print_endline "|by the null parser.|"; >>, loc);
      ], directive_found)

(* install it *)
let () = Pcaml.parse_implem := null_parser

<:str_item< print_endline "|by the null parser.|"; >>

pa_null.cmo: pa_null.ml
    ocamlc -I +camlp5 -pp 'camlp5o q_ast.cmo' -c pa_null.ml

hello: hello.ml pa_null.cmo
    ocamlc -pp 'camlp5o ./pa_null.cmo' hello.ml -o hello

$ ./hello
|your code          |
|has been replaced  |
|by the null parser.|

# select * from attempts_brief where quiz=1479;
id    | quiz | person | score | out_of
-------+------+--------+-------+----
14981 | 1479 | admin  |    20 |     20
14982 | 1479 | admin  |       |  
(2 rows)
# delete from attempts_brief where quiz=1479;
ERROR:  cannot delete from a view
HINT:  You need an unconditional ON DELETE DO INSTEAD rule.
# create rule attempts_brief_del as on delete to attempts_brief
# do instead delete from attempts where id=OLD.id;
CREATE RULE
# delete from attempts_brief where quiz=1479;
DELETE 2
-- inspired by
-- http://code-factor.blogspot.com/2007/06/roman-numeral-conversion-in-factor.html

module RomanNumerals (toRoman) where

-- constants

romanValues = [1000, 900, 500, 400, 100, 90, 50, 40, 10, 9, 5, 4, 1]
romanDigits = words "m cm d cd c xc l xl x ix v iv i"
theRomans   = zip romanValues romanDigits

-- internals

-- To do the actual conversion to Roman numerals, we left-fold over
-- theRomans, starting with a seed value of (accumulator,
-- remainder). The initial remainder is the value we want to
-- convert. Using theRomans as a resource, romFold breaks down the
-- remainder by modular arithmetic, adding Roman digits to the
-- accumulator as it goes. Finally we take the accumulator, and we're
-- done.

toRoman' :: Int -> String
romFold  :: ([a], Int) -> (Int, [a]) -> ([a], Int)

toRoman' n = fst $ foldl romFold ("", n) theRomans

romFold (acc, n) (romValue, romDigit) =
let (result, remain) = divMod n romValue
    newDigits = concat $ replicate result romDigit
in (acc ++ newDigits, remain)

romanRangeCheck :: (Monad m) => Int -> m Int
romanRangeCheck n
| 0 < n && n < 4000 = return n
| otherwise = fail "out of bounds [0 < n < 4000]"

-- The public, range-checking version.

toRoman :: Monad m => Int -> m String
toRoman n = romanRangeCheck n >>= (return . toRoman')

(use srfi-1 srfi-26)

(define (group-by keyproc lst #!optional (is-equal equal?))
  ;; examples:
  ;; (group-by identity '(1 2 3 3 4 4 4)) --> ((1) (2) (3 3) (4 4 4))                                         
  ;; (group-by car '((a 1) (a 2) (b 1))) --> '(((a 1) (a 2)) ((b 1)))                                                   
  (let loop ((lst lst) (acc '()))
   (if (null? lst)
       (reverse acc)
       (let ((key (keyproc (car lst))))
         (receive (grouped rest)
             (span (lambda (item) (is-equal key (keyproc item))) lst)
           (loop rest (cons grouped acc)))))))

(group-by first '(("fred" 25) ("Fred" 33) ("mary" 22)))
--> ((("fred" 25)) (("Fred" 33)) (("mary" 22)))
(group-by first '(("fred" 25) ("Fred" 33) ("mary" 22)) string-ci=?)
--> ((("fred" 25) ("Fred" 33)) (("mary" 22)))
;; srss.scm -- simple RSS aggregator in Chicken Scheme

(use http-client              ; to fetch the feeds
     ssax                     ; XML parsing
     sxml-tools               ; XPath-like functions (sxpath)
     hart)                    ; html generation (mine; not public yet)

(define (url->dom url)
  (SSAX:XML->SXML (nth-value 2 (http:send-request url)) '()))

(define-macro (>> obj . rest)
  ;; just a little sugar for getting text from XML nodes.
  ;; e.g. (>> my-htmldoc html head title) --> "doc title"
  ;;      (>> my-htmldoc // h1) --> "first main heading"
  `(let ((lst ((sxpath '(,@rest *text*)) ,obj)))
     (if (null? lst) "" (first lst))))

(define get-items (sxpath '(* * item)))

(define (aggregate urls)
  (hart (html
         (head (title "RSS Aggregate")
               (link (@ (rel "stylesheet")
                        (href "srss.css") (type "text/css"))))
         (body (h1 "RSS Aggregate")
               (for: (dom (map url->dom urls))
                 (div (@ (class "channel"))
                      (h2 (raw: (>> dom * * title)))
                      (ul (for: (item (get-items dom))
                            (li (@ (class "item"))
                                (a (@ (href (>> item link)))
                                   (h3 (raw: (>> item title))))
                                (p (raw: (>> item description))))))))))))

;; main

(match (command-line-arguments)
  ((out-file . urls) (with-output-to-file out-file 
                       (lambda () (aggregate urls))))
  (_ (print "usage: srss outfile [url]*")))

{include-quiz:
{What's the most important feature in a Wiki?}
{Clean markup language | Markup is important, but...}
{Permissions-based editing | There are times when...}
{Revision history | While a crucial feature...}
{All of the above | CORRECT | Yes! They are all...}}

more blog than sense

One-upping the null parser: the amazing Echo language

The lexer

Integrating the lexer

EXTEND-ing the Ocaml grammar

Build and test

Seeing the generated code

Making a null language with Ocaml

(Sidebar: The murky lineage of camlp5 and camlp4)

The null parser

Building and using the parser

PostgreSQL Love: deleting from views

Roman Numerals in Haskell

The kindness of dictators, and an octet-full of eggs

Rethinking OpenURL

Hello planet code4lib!

group-by: like itertools.group in Scheme

hart 0.1 (or, Man lays egg, news at 11)

...minus Chicken, plus Io, ...

Haskell + RSS Aggregator + Chicken − Haskell...

The Search for the Common Lisp

Functional optimizations with PyPy

SQLite Full Text Search

The Cog is back

Boing Boing: Canadian Nat'l Film Board puts 50 classic shorts online

PicoTurbine: A home-brew wind turbine

Nexenta GNU/OpenSolaris

Database Soup: Primary Keyvil

sxpath quick reference

Python-dev: switch, case, static, oh my.

Outed.

"Boring files" in darcs

Oddmuse

Tearing down markup