initial work on tangle

db4
Alex Chapman 2008-04-09 09:23:33 +10:00
parent 21e30d8681
commit 7a748b23c8
7 changed files with 211 additions and 0 deletions

View File

@ -0,0 +1,7 @@
USING: html kernel semantic-db tangle.html tools.test ;
IN: tangle.html.tests
[ "test" ] [ "test" >html ] unit-test
[ "<ul><li>An Item</li></ul>" ] [ { "An Item" } <ulist> >html ] unit-test
[ "<ul><li>One</li><li>Two</li><li>Three, ah ah ah</li></ul>" ] [ { "One" "Two" "Three, ah ah ah" } <ulist> >html ] unit-test
[ "<a href='foo/bar'>some link</a>" ] [ "foo/bar" "some link" <link> >html ] unit-test

View File

@ -0,0 +1,33 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors html html.elements io io.streams.string kernel namespaces semantic-db sequences strings tangle.path ;
IN: tangle.html
TUPLE: element attributes ;
TUPLE: ulist < element items ;
: <ulist> ( items -- element )
H{ } clone swap ulist construct-boa ;
TUPLE: link < element href text ;
: <link> ( href text -- element )
H{ } clone -rot link construct-boa ;
GENERIC: >html ( element -- str )
M: string >html ( str -- str ) ;
M: link >html ( link -- str )
[ <a dup href>> =href a> text>> write </a> ] with-string-writer ;
M: node >html ( node -- str )
dup node>path [
swap node-content <link> >html
] [
node-content
] if* ;
M: ulist >html ( ulist -- str )
[
<ul> items>> [ <li> >html write </li> ] each </ul>
] with-string-writer ;

View File

@ -0,0 +1,22 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel semantic-db sequences tangle.html ;
IN: tangle.menu
RELATION: subitem-of
RELATION: before
: get-menus ( -- nodes )
subitem-of-relation ultimate-objects node-results ;
: get-menu ( name -- node )
get-menus [ node-content = ] with find nip ;
: ensure-menu ( name -- node )
dup get-menu [ nip ] [ create-node ] if* ;
: load-menu ( name -- menu )
get-menu subitem-of-relation get-node-tree-s ;
: menu>ulist ( menu -- str ) children>> <ulist> ;
: menu>html ( menu -- str ) menu>ulist >html ;

View File

@ -0,0 +1,23 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel semantic-db sequences sequences.lib ;
IN: tangle.page
RELATION: has-abbreviation
RELATION: has-content
RELATION: has-subsection
RELATION: before
RELATION: authored-by
RELATION: authored-on
TUPLE: page name abbreviation author created content ;
C: <page> page
: load-page-content ( node -- content )
has-content-objects [ node-content ] map concat ;
: load-page ( node -- page )
dup [ has-abbreviation-objects ?first ] keep
[ authored-by-objects ?first ] keep
[ authored-on-objects ?first ] keep
load-page-content <page> ;

View File

@ -0,0 +1,51 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel semantic-db sequences sequences.lib splitting ;
IN: tangle.path
RELATION: has-filename
RELATION: in-directory
: create-root ( -- node ) "" create-node ;
: get-root ( -- node )
in-directory-relation ultimate-objects ?1node-result ;
: ensure-root ( -- node ) get-root [ create-root ] unless* ;
: create-file ( parent name -- node )
create-node swap dupd in-directory ;
: files-in-directory ( node -- nodes ) in-directory-subjects ;
: file-in-directory ( name node -- node )
in-directory-relation subjects-with-cor ?1node-result ;
: parent-directory ( file-node -- dir-node )
in-directory-objects ?first ;
: (path>node) ( node name -- node )
swap [ file-in-directory ] [ drop f ] if* ;
USE: tools.walker
: path>node ( path -- node )
"/" split ensure-root swap [ (path>node) ] each ;
: (node>path) ( root seq node -- seq )
pick over node= [
drop nip
] [
dup node-content pick push
parent-directory [
(node>path)
] [
2drop f
] if*
] if ;
: node>path* ( root node -- path )
V{ } clone swap (node>path) dup empty?
[ drop f ] [ <reversed> "/" join ] if ;
: node>path ( node -- path )
ensure-root swap node>path* ;

View File

@ -0,0 +1,26 @@
USING: accessors arrays continuations db db.sqlite io.files kernel semantic-db sequences tangle tangle.html tangle.menu tangle.page tangle.path tools.test tools.walker tuple-syntax ;
IN: tangle.tests
: db-path "tangle-test.db" temp-file ;
: test-db db-path sqlite-db ;
: delete-db [ db-path delete-file ] ignore-errors ;
: test-tangle ( -- )
ensure-root "foo" create-file "bar" create-file "pluck_eggs" create-file
"How to Pluck Eggs" create-node swap has-filename
"Main Menu" ensure-menu "home" create-node swap subitem-of ;
test-db [
init-semantic-db test-tangle
[ "pluck_eggs" ] [ "foo/bar/pluck_eggs" path>node [ node-content ] when* ] unit-test
[ "How to Pluck Eggs" ] [ "foo/bar/pluck_eggs" path>node [ has-filename-subjects first node-content ] when* ] unit-test
[ "foo/bar/pluck_eggs" ] [ "foo/bar/pluck_eggs" path>node node>path ] unit-test
[ f ] [ TUPLE{ node id: 666 content: "some content" } parent-directory ] unit-test
[ f ] [ TUPLE{ node id: 666 content: "some content" } node>path ] unit-test
[ "Main Menu" ] [ "Main Menu" ensure-menu node-content ] unit-test
[ t ] [ "Main Menu" ensure-menu "Main Menu" ensure-menu node= ] unit-test
[ "Main Menu" { "home" } ] [ "Main Menu" load-menu dup node>> node-content swap children>> [ node>> node-content ] map >array ] unit-test
[ { "home" } ] [ "Main Menu" load-menu menu>ulist items>> [ node>> node-content ] map >array ] unit-test
[ f ] [ TUPLE{ node id: 666 content: "node text" } node>path ] unit-test
[ "node text" ] [ TUPLE{ node id: 666 content: "node text" } >html ] unit-test
] with-db delete-db

View File

@ -0,0 +1,49 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs db db.sqlite db.postgresql http.server io kernel namespaces semantic-db sequences strings ;
IN: tangle
GENERIC: render* ( content templater -- output )
GENERIC: render ( content templater -- )
TUPLE: echo-template ;
C: <echo-template> echo-template
M: echo-template render* drop ;
! METHOD: render* { string echo-template } drop ;
M: object render render* write ;
TUPLE: tangle db templater ;
C: <tangle> tangle
TUPLE: sqlite-tangle ;
TUPLE: postgres-tangle ;
: make-tangle ( db templater type -- tangle )
construct-empty [ <tangle> ] dip tuck set-delegate ;
: <sqlite-tangle> ( db templater -- tangle ) sqlite-tangle make-tangle ;
: <postgres-tangle> ( db templater -- tangle ) postgres-tangle make-tangle ;
: with-tangle ( tangle quot -- )
[ db>> ] dip with-db ;
: init-db ( tangle -- tangle )
dup [ init-semantic-db ] with-tangle ;
GENERIC# new-db 1 ( tangle obj -- tangle )
M: sqlite-tangle new-db ( tangle filename -- tangle )
sqlite-db >>db init-db ;
M: postgres-tangle new-db ( tangle args -- tangle )
postgresql-db >>db init-db ;
TUPLE: node-responder tangle ;
C: <node-responder> node-responder
M: node-responder call-responder ( path responder -- response )
"text/plain" <content> nip request-params
[ "node-id" swap at* [ >>body ] [ drop ] if ] when* nip ;
: test-tangle ( -- )
f f <sqlite-tangle> <node-responder> main-responder set ;