diff --git a/extra/tangle/html/html-tests.factor b/extra/tangle/html/html-tests.factor new file mode 100644 index 0000000000..8e7d8c24e1 --- /dev/null +++ b/extra/tangle/html/html-tests.factor @@ -0,0 +1,7 @@ +USING: html kernel semantic-db tangle.html tools.test ; +IN: tangle.html.tests + +[ "test" ] [ "test" >html ] unit-test +[ "" ] [ { "An Item" } >html ] unit-test +[ "" ] [ { "One" "Two" "Three, ah ah ah" } >html ] unit-test +[ "some link" ] [ "foo/bar" "some link" >html ] unit-test diff --git a/extra/tangle/html/html.factor b/extra/tangle/html/html.factor new file mode 100644 index 0000000000..9c55b66528 --- /dev/null +++ b/extra/tangle/html/html.factor @@ -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 ; +: ( items -- element ) + H{ } clone swap ulist construct-boa ; + +TUPLE: link < element href text ; +: ( href text -- element ) + H{ } clone -rot link construct-boa ; + +GENERIC: >html ( element -- str ) + +M: string >html ( str -- str ) ; + +M: link >html ( link -- str ) + [ > =href a> text>> write ] with-string-writer ; + +M: node >html ( node -- str ) + dup node>path [ + swap node-content >html + ] [ + node-content + ] if* ; + +M: ulist >html ( ulist -- str ) + [ +
    items>> [
  • >html write
  • ] each
+ ] with-string-writer ; diff --git a/extra/tangle/menu/menu.factor b/extra/tangle/menu/menu.factor new file mode 100644 index 0000000000..9740acee1c --- /dev/null +++ b/extra/tangle/menu/menu.factor @@ -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>> ; +: menu>html ( menu -- str ) menu>ulist >html ; diff --git a/extra/tangle/page/page.factor b/extra/tangle/page/page.factor new file mode 100644 index 0000000000..db3d58d5f3 --- /dev/null +++ b/extra/tangle/page/page.factor @@ -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 + +: 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 ; diff --git a/extra/tangle/path/path.factor b/extra/tangle/path/path.factor new file mode 100644 index 0000000000..e7cf3de967 --- /dev/null +++ b/extra/tangle/path/path.factor @@ -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 ] [ "/" join ] if ; + +: node>path ( node -- path ) + ensure-root swap node>path* ; diff --git a/extra/tangle/tangle-tests.factor b/extra/tangle/tangle-tests.factor new file mode 100644 index 0000000000..7b78e07473 --- /dev/null +++ b/extra/tangle/tangle-tests.factor @@ -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 diff --git a/extra/tangle/tangle.factor b/extra/tangle/tangle.factor new file mode 100644 index 0000000000..cbd3b94058 --- /dev/null +++ b/extra/tangle/tangle.factor @@ -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 + +M: echo-template render* drop ; +! METHOD: render* { string echo-template } drop ; +M: object render render* write ; + +TUPLE: tangle db templater ; +C: tangle + +TUPLE: sqlite-tangle ; +TUPLE: postgres-tangle ; + +: make-tangle ( db templater type -- tangle ) + construct-empty [ ] dip tuck set-delegate ; + +: ( db templater -- tangle ) sqlite-tangle make-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 + +M: node-responder call-responder ( path responder -- response ) + "text/plain" nip request-params + [ "node-id" swap at* [ >>body ] [ drop ] if ] when* nip ; + +: test-tangle ( -- ) + f f main-responder set ; +