initial work on tangle

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
+[ "<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

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 ;
+: <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 ;

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>> <ulist> ;
+: menu>html ( menu -- str ) menu>ulist >html ;

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> 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> ;

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 ] [ <reversed> "/" join ] if ;
+
+: node>path ( node -- path )
+    ensure-root swap node>path* ;

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

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> 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 ;
+