--- /dev/null
+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
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
--- /dev/null
+! 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> ;
--- /dev/null
+! 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* ;
--- /dev/null
+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
--- /dev/null
+! 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 ;
+
projects / factor.git / commitdiff