charlock_holmes 0.2.0

data/spec/fixtures/core.rkt

@@ -0,0 +1,254 @@
+#lang racket/base
+
+(require (for-syntax syntax/parse racket/syntax racket)
+         ffi/unsafe racket/function racket/string
+         "start.rkt" "c.rkt")
+
+(struct jtype (signature tag predicate ctype racket->java java->racket))
+(struct jtype/object jtype (class))
+(struct jtype/vector jtype/object (element))
+(struct jvector (cpointer type length))
+(struct jprocedure (args return proc))
+
+(define ((single-compose f1 f2) e) (f1 (f2 e)))
+
+(define (make-jtype obj racket->java java->racket)
+  (let ([composed-racket->java (single-compose (jtype-racket->java obj) racket->java)]
+        [composed-java->racket (single-compose java->racket (jtype-java->racket obj))])
+    ; due to limitation in racket's struct-copy
+    (cond
+      [(jtype/vector? obj)
+       (struct-copy jtype/vector obj
+         [racket->java #:parent jtype composed-racket->java]
+         [java->racket #:parent jtype composed-java->racket])]
+      [(jtype/object? obj)
+       (struct-copy jtype/object obj
+         [racket->java #:parent jtype composed-racket->java]
+         [java->racket #:parent jtype composed-java->racket])]
+      [else
+       (struct-copy jtype obj
+         [racket->java                composed-racket->java]
+         [java->racket                composed-java->racket])])))
+
+(define (jtype->ctype obj)
+  (make-ctype (jtype-ctype obj) (jtype-racket->java obj) (jtype-java->racket obj)))
+
+; --- signature makers ---
+(define (make-class-signature c)  (string-append "L" c ";"))
+(define (make-vector-signature s) (string-append "[" s))
+(define (make-signature args return)
+  (let ([args-signature (string-append* (map jtype-signature args))]
+        [return-signature (jtype-signature return)])
+    (string-append "(" args-signature ")" return-signature)))
+
+; --- predicates for java types on racket ---
+(require (only-in web-server/dispatch/extend make-coerce-safe?) srfi/26/cut)
+
+(define jboolean?   boolean?)
+(define jbyte?      byte?)
+(define jchar?      char?)
+(define jshort?     (make-coerce-safe? (cut < -32768 <> 32767)))
+(define jint?       (make-coerce-safe? (cut < -2147483648 <> 2147483647)))
+(define jlong?      (make-coerce-safe? (cut < -9223372036854775808 <> 9223372036854775807)))
+(define jfloat?     single-flonum?)
+(define jdouble?    flonum?)
+(define jstring?    string?)
+(define ((make-jobject-predicate clss) o) (instance-of? o clss))
+(define ((make-jlist-predicate element?) o) (andmap element? o))
+
+; --- java types ---
+(define _jboolean (jtype "Z" 'boolean jboolean? __jboolean #f            #f))
+(define _jbyte    (jtype "B" 'byte    jbyte?    __jbyte    #f            #f))
+(define _jchar    (jtype "C" 'char    jchar?    __jchar    char->integer integer->char))
+(define _jshort   (jtype "S" 'short   jshort?   __jshort   #f            #f))
+(define _jint     (jtype "I" 'int     jint?     __jint     #f            #f))
+(define _jlong    (jtype "J" 'long    jlong?    __jlong    #f            #f))
+(define _jfloat   (jtype "F" 'float   jfloat?   __jfloat   #f            #f))
+(define _jdouble  (jtype "D" 'double  jdouble?  __jdouble  #f            #f))
+(define _jvoid    (jtype "V" 'void    #f        __jvoid    #f            #f))
+; hack for _jobject and _jlist so that they dual as a jtype and function
+(define _jobject
+  ((λ ()
+     (struct _jobject jtype/object ()
+       #:property prop:procedure 
+       (λ (self class-name [racket->java #f] [java->racket #f] [predicate #f])
+         (let ([class-id (find-class class-name)])
+           (struct-copy jtype/object self
+             [signature    #:parent jtype (make-class-signature class-name)]
+             [predicate    #:parent jtype (or predicate (make-jobject-predicate class-id))]
+             [racket->java #:parent jtype racket->java]
+             [java->racket #:parent jtype java->racket]
+             [class                 class-id]))))
+     (let ([class-id (find-class "Ljava/lang/Object;")])
+       (_jobject "Ljava/lang/Object;" 'object (make-jobject-predicate class-id)
+                 __jobject #f #f class-id)))))
+(define _jstring  (_jobject "java/lang/String" new-string get-string jstring?))
+(define _jlist    
+  ((λ ()
+     (struct _jlist jtype/vector ()
+       #:property prop:procedure
+       (λ (self element)
+         (define-values (make-array array-ref array-set!) (tag->array-info (jtype-tag element)))
+         (when (jtype/object? element)
+           (let ([clss (jtype/object-class element)])
+             (set! make-array (λ (n) (new-object-array n clss #f)))))
+         (let* ([signature (make-vector-signature (jtype-signature element))]
+                [element-racket->java (or (jtype-racket->java element) identity)]
+                [element-java->racket (or (jtype-java->racket element) identity)]
+                [element? (or (jtype-predicate element) (λ (_) #t))])
+           (struct-copy jtype/vector self
+             [signature    #:parent jtype signature]
+             [predicate    #:parent jtype (make-jlist-predicate element?)]
+             [ctype        #:parent jtype __jobject]
+             [racket->java #:parent jtype
+              (λ (c)
+                (let ([array (make-array (length c))])
+                  (for ([e (in-list c)] [i (in-naturals)])
+                    (array-set! array i (element-racket->java e)))
+                  array))]
+             [java->racket #:parent jtype
+              (λ (c)
+                (for/list ([i (in-range (get-array-length c))])
+                  (element-java->racket (array-ref c i))))]
+             [class        #:parent jtype/object (find-class signature)]
+             [element               element]))))
+     (let ([class-id (find-class "[Ljava/lang/Object;")]
+           [element-class-id (jtype/object-class _jobject)])
+       (_jlist "[Ljava/lang/Object;" 'object (make-jobject-predicate element-class-id) __jobject
+               (λ (c)
+                 (let ([array (new-object-array (length c) element-class-id #f)])
+                   (for ([e (in-list c)]
+                         [i (in-naturals)])
+                     (set-object-array-element array i e))
+                   array))
+               (λ (c)
+                 (for/list ([i (in-range (get-array-length c))])
+                   (get-object-array-element c i)))
+               class-id
+               _jobject)))))
+(define-syntax (_jmethod stx)
+  (define-syntax-class type #:literals (->)
+    (pattern (~and x (~not (~or (~literal ...) ->)))))
+  (syntax-parse stx #:literals (->)
+    [(_ arg:type ... (~optional (~seq farg:type (~literal ...))) (~optional (~seq -> return*)))
+     (with-syntax* ([(arg* ...) (generate-temporaries #'(arg ...))]
+                    [(larg ... . marg) #`(arg* ... #,@(if (attribute farg) #'arg-rest #`()))]
+                    [(aarg ...) #`(arg* ... #,@(if (attribute farg) #'(arg-rest) #`()))]
+                    [return (if (attribute return*) #'return* #'_jvoid)])
+       #`(let* ([args  (list arg ... #,@(if (attribute farg) #`((_jlist farg)) #`()))])
+           (jprocedure args return
+            (λ (type jnienv clss method func)
+              (case type
+                [(constructor) (λ (larg ... . marg) (func jnienv clss method aarg ...))]
+                [(static-method) (λ (larg ... . marg) (func jnienv clss method aarg ...))]
+                [(method) (λ (o larg ... . marg) (func jnienv o method aarg ...))]
+                [else (error '_jmethod "invalid type provided")])))))]))
+; dynamic and slower version of _jmethod
+(define (_jprocedure args return #:repeat-last-arg? [repeat-last-arg? #f])
+  (define (nest-at lst i)
+    (if (null? lst) (list null)
+        (let loop ([lst lst] [i i])
+          (cond [(null? lst) null]
+                [(zero? i) (list lst)]
+                [else (cons (car lst) (loop (cdr lst) (sub1 i)))]))))
+ (jprocedure args return
+    (if repeat-last-arg?
+        (let ([repeat-position (sub1 (length args))])
+          (λ (type jnienv clss method func)
+            (case type
+              [(constructor) (λ larg  (apply func jnienv clss method (nest-at larg repeat-position)))]
+              [(static-method) (λ larg (apply func jnienv clss method (nest-at larg repeat-position)))]
+              [(method) (λ (o . larg) (apply func jnienv o method (nest-at larg repeat-position)))])))
+        (λ (type jnienv clss method func)
+          (case type
+            [(constructor) (λ larg (apply func jnienv clss method larg))]
+            [(static-method) (λ larg (apply func jnienv clss method larg))]
+            [(method) (λ (o . larg) (apply func jnienv o method larg))]
+            [else (error '_jprocedure "invalid type provided")])))))
+; get-jmethod/get-jconstructor pass the following arguments (type jnienv class method func) 
+; to a function created by _jmethod or _jprocedure 
+; according to the type the function returns one of the following functions
+; | constructor   (λ (args ...) ; doesn't need to take in an object and the class is static
+; | static-method (λ (args ...) ; same reasoning as above
+; | method        (λ (object args ...)
+
+
+; --- interfacing with java methods ---
+(define (get-jconstructor class-id type)
+  (let* ([args      (jprocedure-args type)]
+         [return    (jprocedure-return type)]
+         [proc      (jprocedure-proc type)]
+         [signature (make-signature args return)]
+         [method-id (get-method-id class-id "<init>" signature)]
+         [ffi-func  (get-jrffi-obj "new-object"
+                      (_cprocedure (list* __jnienv __jclass __jmethodID (map jtype->ctype args))
+                                   __jobject))])
+    (proc 'constructor current-jnienv class-id method-id ffi-func)))
+
+(define (get-jmethod class-id method-name type #:static? [static? #f])
+  (let* ([args      (jprocedure-args type)]
+         [return    (jprocedure-return type)]
+         [proc      (jprocedure-proc type)]
+         [signature (make-signature args return)]
+         [method-id (get-method-id class-id method-name signature #:static? static?)]
+         [type      (if static? 'static-method 'method)]
+         [ffi-func  (get-jrffi-obj 
+                     (format "call-~a~a-method" (if static? "static-" "") (jtype-tag return))       
+                     (_cprocedure (append (list __jnienv (if static? __jclass __jobject)
+                                                __jmethodID) (map jtype->ctype args))
+                                  (jtype->ctype return)))])
+    (proc type current-jnienv class-id method-id ffi-func)))
+
+
+; --- interfacing with java fields ---
+(define (get-jaccessor class-id field-name type #:static? [static? #f])
+  (let* ([signature (jtype-signature class-id field-name (jtype-signature type))]
+         [field-id  (get-field-id class-id field-name signature #:static? static?)]
+         [ffi-func  (get-jrffi-obj
+                     (format "get-~a~a-field" (if static? "static-" "") (jtype-tag type))
+                     (_cprocedure (list __jnienv (if static? __jclass __jobject) __jfieldID) type))])
+    (if static? (λ () (ffi-func current-jnienv class-id field-id))
+        (λ (obj) (ffi-func current-jnienv obj field-id)))))
+
+(define (get-jmutator class-id field-name type #:static? [static? #f])
+  (let* ([signature (jtype-signature class-id field-name (jtype-signature type))]
+         [field-id  (get-field-id class-id field-name signature #:static? static?)]
+         [ffi-func (get-jrffi-obj 
+                    (format "set-~a~a-field" (if static? "static-" "") (jtype-tag type))
+                    (_cprocedure (list __jnienv (if static? __jclass __jobject) __jfieldID type) type))])
+    (if static? (λ (new-value) (ffi-func current-jnienv class-id field-id new-value))
+        (λ (obj new-value) (ffi-func current-jnienv obj field-id new-value)))))
+
+(define (get-jparameter class-id field-name type #:static? [static? #f])
+  (let* ([accessor (get-jaccessor class-id field-name type #:static? static?)]
+         [mutator  (get-jmutator class-id field-name type #:static? static?)])
+    (if static?
+        (case-lambda
+          [() (accessor)]
+          [(new-value) (mutator new-value)])
+        (case-lambda
+          [(obj) (accessor obj)]
+          [(obj new-value) (mutator obj new-value)]))))
+
+
+
+(provide _jboolean _jbyte _jchar _jshort _jint _jlong _jfloat _jdouble _jvoid
+         _jobject _jstring _jlist)
+
+(provide get-jconstructor get-jmethod get-jparameter get-jmutator get-jaccessor)
+
+;(provide instance-of? (rename-out [find-class find-class]) get-method-id get-field-id)
+
+
+(provide (all-defined-out)  : -> current-jnienv)
+
+
+
+
+
+
+
+
+
+
+

data/spec/fixtures/laholator.py

@@ -0,0 +1,131 @@
+#!/usr/bin/env python
+# -*- coding: utf-8 -*-
+# 
+# @author:     starenka
+# @email:      'moc]tod[liamg].T.E[0aknerats'[::-1]
+
+import warnings, hashlib, simplejson, string
+from os.path import dirname, abspath
+
+from flask import Flask, render_template, request
+from flaskext.sqlalchemy import SQLAlchemy
+try:
+    from sqlalchemy.exceptions import IntegrityError
+except ImportError:
+    from sqlalchemy.exc import IntegrityError
+
+#Hey monkey patcher! NLTK's NgramModel is not serializable w/ pickle.HIGHEST_PROTOCOL (2)
+from werkzeug.contrib import cache
+cache.HIGHEST_PROTOCOL = 1
+from werkzeug.contrib.cache import SimpleCache
+
+from BeautifulSoup import BeautifulSoup
+import nltk
+
+PUNCT = list(unicode(string.punctuation))
+
+app = Flask(__name__)
+app.config.from_object('settings')
+cache = SimpleCache()
+
+app.config['SQLALCHEMY_DATABASE_URI'] = 'sqlite:///%s/db.sqlite3'%abspath(dirname(__file__))
+db = SQLAlchemy(app)
+
+class Sample(db.Model):
+    id = db.Column(db.Integer, primary_key=True)
+    url = db.Column(db.String(80), unique=True)
+    text = db.Column(db.String())
+    enabled = db.Column(db.Boolean())
+
+    def __unicode__(self):
+        str = unicode(BeautifulSoup(self.text,convertEntities=BeautifulSoup.HTML_ENTITIES))
+        return nltk.clean_html(str)
+
+    @classmethod
+    def get_all(self):
+        cached = cache.get('samples')
+        if cached is None:
+            cached = self.query.filter_by(enabled=True).all()
+            cache.set('samples', cached, timeout=app.config['CACHE_MINUTES'] * 60)
+        return cached
+
+class Output(db.Model):
+    id = db.Column(db.Integer, primary_key=True)
+    hash = db.Column(db.String(128),unique=True)
+    text = db.Column(db.String())
+    params = db.Column(db.String(100))
+    
+    def __init__(self,text,**params):
+        self.hash = hashlib.sha512(text.encode('utf8')).hexdigest()
+        self.text = text
+        self.params = simplejson.dumps(params)
+
+@app.context_processor
+def base_context():
+    return dict(settings=app.config,
+        hits = Output.query.count() + app.config['INIT_HITS']
+    )
+
+@app.errorhandler(404)
+def page_not_found(error):
+    return render_template('404.html',title=u"To tady nemáme!"), 404
+
+@app.route('/faq')
+def faq():
+    return render_template('faq.html',title=u"Často kladené dotazy",samples=Sample.get_all())
+
+@app.route('/permalink/<hash>')
+def permalink(hash):
+    one = Output.query.filter_by(hash=hash).first_or_404()
+    return render_template('generator.html', title=u"Henrykuj!", 
+                           text=one.text, hash=one.hash,  
+                           **simplejson.loads(one.params)
+    )
+
+@app.route('/')
+def index():
+    bigrams = request.args.get('bigrams',False)
+    try:
+        words = int(request.args.get('words',app.config['WORDS']))
+        if words > app.config['MAX_WORDS']:
+            words = app.config['MAX_WORDS']
+    except ValueError:
+        words = app.config['WORDS']
+
+    out = _generate(words,bigrams)
+    output = Output(out,words=words,bigrams=bool(bigrams))
+    try:
+        db.session.add(output)
+        db.session.commit()
+    except IntegrityError:
+        pass
+    
+    return render_template('generator.html', title=u"Henrykuj!",
+                           text=out, hash=output.hash,
+                           words=words, bigrams=bigrams
+    )
+
+def _get_ngram_model(bigrams):
+    #NLTK produces a LOT of warnings - don't mess with my error log
+    warnings.simplefilter("ignore")
+    cached = cache.get('ngram_model')
+    if cached is None:
+        samples = Sample.get_all()
+        if samples:
+            text = [unicode(s) for s in samples]
+            tokenizer = nltk.tokenize.WordPunctTokenizer()
+            tokenized = tokenizer.tokenize(' '.join(text))
+            cached = nltk.NgramModel(3-int(bool(bigrams)), tokenized)
+            cache.set('ngram_model', cached, timeout=app.config['CACHE_MINUTES'] * 60)
+    return cached
+
+def _generate(words,bigrams):
+    model = _get_ngram_model(bigrams)
+    starts = model.generate(100)[-4:]
+    starts = filter(lambda a: a not in PUNCT,starts)
+    generated = model.generate(words, starts)
+    out = ' '.join(generated).replace(' , ',', ').replace(' . ','. ')
+    return '%s%s&hellip;'%(out[0].upper(),out[1:])
+
+if __name__ == '__main__':
+    app.run()

data/spec/fixtures/repl2.cljs

@@ -0,0 +1,109 @@
+;   Copyright (c) Rich Hickey. All rights reserved.
+;   The use and distribution terms for this software are covered by the
+;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;   which can be found in the file epl-v10.html at the root of this distribution.
+;   By using this software in any fashion, you are agreeing to be bound by
+;   the terms of this license.
+;   You must not remove this notice, or any other, from this software.
+
+(ns clojure.browser.repl2
+  (:require [clojure.browser.net   :as net]
+            [clojure.browser.event :as event]
+            [goog.json :as gjson]))
+
+;; Notes
+;; =====
+;;
+;; Using keywords for the service names does not work in Chrome or
+;; FireFox.
+;;
+;; --
+
+(defn log-obj [obj]
+  (.log js/console obj))
+
+;; Outer/Parent Peer
+;; =================
+;;
+;; The code in this section will be run in the parent page which
+;; exists in the application's domain. This is where code will be
+;; evaluated.
+
+(def parent-channel (atom nil))
+
+(defn- ensure-string [val]
+  (if (string? val)
+    val
+    (str val)))
+
+(defn evaluate-javascript
+  "Given a block of JavaScript, evaluate it and transmit the result to
+  the inner peer of the cross domain channel."
+  [block]
+  (log-obj (str "evaluating: " block))
+  (let [result (pr-str
+                (try {:status :success :value (ensure-string (js* "eval(~{block})"))} 
+                     (catch js/Error e {:status :exception :value (pr-str e)})))]
+    (log-obj (str "result: " result))
+    (net/transmit @parent-channel "return-value" result)))
+
+(defn create-cross-domain-channel
+  "Create a cross domain channel with an iframe which can communicate
+  with the REPL server."
+  [url]
+  (let [chnl (doto (net/xpc-connection {:peer_uri (str url "/repl")})
+               (net/register-service "evaluate-javascript" evaluate-javascript)
+               (net/connect document.body
+                            (fn [] (log-obj "Parent channel connected."))
+                            (fn [iframe] (set! iframe.style.display "none"))))]
+    (reset! parent-channel chnl)))
+
+(defn connect
+  "Connect to a ClojureScript REPL server located at the passed url."
+  [url]
+  (goog.events/listen js/window "load" #(create-cross-domain-channel url)))
+
+;; Inner peer
+;; =========
+;;
+;; The code in this section will be run in the child iframe and can
+;; communicate with REPL server.
+
+(def state (atom {:connection nil :url nil}))
+
+(def child-channel (atom nil))
+
+(defn transmit-post [connection url data]
+  (net/transmit connection url "POST" data nil 0))
+
+(defn start-repl-connection
+  "Start the REPL loop"
+  [url]
+  (let [connection (net/xhr-connection)]
+    (reset! state {:connection connection :url url})
+    (event/listen connection
+                  :success
+                  (fn [e]
+                    (net/transmit @child-channel
+                                  "evaluate-javascript"
+                                  (.getResponseText e/currentTarget ()))))
+    ;; The server is expecting to see the string "ready" for the
+    ;; initial connection.
+    (transmit-post connection url "ready")))
+
+(defn return-value [val]
+  (log-obj (str "sending: " val))
+  (transmit-post (:connection @state) (:url @state) val))
+
+;; I can't get this to work using the clojure.browser.net api.
+
+(defn inner-peer-channel
+  "This function will be called from a script in the child iframe."
+  [repl-url]
+  (let [cfg (gjson/parse (.getParameterValue (goog.Uri. window.location.href) "xpc"))
+        chnl (doto (goog.net.xpc.CrossPageChannel. cfg)
+               (net/register-service "return-value" return-value)
+               (.connect #(log-obj "Child channel connected.")))]
+    (do (reset! child-channel chnl)
+        (js/setTimeout #(start-repl-connection repl-url) 500))))
+