initial work on tangle
parent
21e30d8681
commit
7a748b23c8
|
@ -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
|
|
@ -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 ;
|
|
@ -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 ;
|
|
@ -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> ;
|
|
@ -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* ;
|
|
@ -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
|
|
@ -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 ;
|
||||
|
Loading…
Reference in New Issue