halipeto (empty) → 2.1
raw patch · 9 files changed
+2579/−0 lines, 9 filesdep +HaXmldep +basedep +directorysetup-changed
Dependencies added: HaXml, base, directory, haskell98, pandoc
Files
- COPYING +346/−0
- Halipeto/Dictionary.lhs +558/−0
- Halipeto/Functions.lhs +346/−0
- Halipeto/Pages.lhs +364/−0
- Halipeto/SimpleDB.lhs +385/−0
- Halipeto/Template.lhs +424/−0
- Halipeto/Utilities.lhs +116/−0
- Setup.lhs +8/−0
- halipeto.cabal +32/−0
+ COPYING view
@@ -0,0 +1,346 @@+ GNU GENERAL PUBLIC LICENSE+ Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.+ 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users. This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it. (Some other Free Software Foundation software is covered by+the GNU Library General Public License instead.) You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++ To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have. You must make sure that they, too, receive or can get the+source code. And you must show them these terms so they know their+rights.++ We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++ Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software. If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++ Finally, any free program is threatened constantly by software+patents. We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary. To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++ The precise terms and conditions for copying, distribution and+modification follow.+++ GNU GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License. The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language. (Hereinafter, translation is included without limitation in+the term "modification".) Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++ 1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++ 2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) You must cause the modified files to carry prominent notices+ stating that you changed the files and the date of any change.++ b) You must cause any work that you distribute or publish, that in+ whole or in part contains or is derived from the Program or any+ part thereof, to be licensed as a whole at no charge to all third+ parties under the terms of this License.++ c) If the modified program normally reads commands interactively+ when run, you must cause it, when started running for such+ interactive use in the most ordinary way, to print or display an+ announcement including an appropriate copyright notice and a+ notice that there is no warranty (or else, saying that you provide+ a warranty) and that users may redistribute the program under+ these conditions, and telling the user how to view a copy of this+ License. (Exception: if the Program itself is interactive but+ does not normally print such an announcement, your work based on+ the Program is not required to print an announcement.)+++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++ a) Accompany it with the complete corresponding machine-readable+ source code, which must be distributed under the terms of Sections+ 1 and 2 above on a medium customarily used for software interchange; or,++ b) Accompany it with a written offer, valid for at least three+ years, to give any third party, for a charge no more than your+ cost of physically performing source distribution, a complete+ machine-readable copy of the corresponding source code, to be+ distributed under the terms of Sections 1 and 2 above on a medium+ customarily used for software interchange; or,++ c) Accompany it with the information you received as to the offer+ to distribute corresponding source code. (This alternative is+ allowed only for noncommercial distribution and only if you+ received the program in object code or executable form with such+ an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it. For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable. However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.+++ 4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License. Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++ 5. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Program or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++ 6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++ 7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all. For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.+++ 8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded. In such case, this License incorporates+the limitation as if written in the body of this License.++ 9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number. If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation. If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++ 10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission. For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this. Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++ NO WARRANTY++ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++ END OF TERMS AND CONDITIONS+++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++ Gnomovision version 69, Copyright (C) year name of author+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the program+ `Gnomovision' (which makes passes at compilers) written by James Hacker.++ <signature of Ty Coon>, 1 April 1989+ Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs. If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library. If this is what you want to do, use the GNU Library General+Public License instead of this License.+
+ Halipeto/Dictionary.lhs view
@@ -0,0 +1,558 @@+% +% Halipeto 2.0 - Haskell static web page generator +% Copyright 2004 Andrew Cooke (andrew@acooke.org) +% Copyright 2007 Peter Simons (simons@cryp.to) +% +% This program is free software; you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation; either version 2 of the License, or +% (at your option) any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program; if not, write to the Free Software +% Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +% +% EXCEPT +% +% Files in FromHaxml are from HaXml - http://www.cs.york.ac.uk/HaXml - +% see the COPYRIGHT and LICENSE in that directory. The files included +% are a subset of the full HaXml distribution and have been modified to +% originate from the FromHaxml module (so that install on Win32 is +% easy). +% ++\section{Dictionary}++This section provides a data structure to associate strings with+values (much like a hash table). Key value pairs are added by+generating a new instance, reusing the old structure where+appropriate.++Since Dictionaries are purely functional data structures they provide+stack--like semantics on return (ie. if modified dictionaries are only+passed downwards then returning from a function ``pops'' the data that+was added within that function's scope).++The dictionary may be sensitive to the case of the keys or not (two+different implementations of a single class that share much underlying+code). Since the class interfaces is general the same functions+manipulate either type of dictionary. Functions oustide the class+interface are identified by appending ``NC'' to the case insensitive+version.++\begin{code}+module Halipeto.Dictionary (+ Dictionary, null, empty, emptyNC, toDot, fromDot,+ SubDictionary, OrdDictionary,+ add, add', addAll, addAll', search, search', keys, keys',+ contents, contents', values, children, children', adopt, adopt', merge,+ substitute, subAll, search'', diff, diff'+) where++import Prelude hiding (null)+import Char+import List hiding (find, null, partition, insert)+import Maybe+import Halipeto.Utilities+\end{code}++\subsection{Namespaces and Subsets}++Keys in the dictionary can be used to construct a hierarchical+namespace by following the convention that the null character+separates ``words''.++%%Haddock: The namespace separator+\begin{code}+null :: Char+null = chr 0+\end{code}++There's a slight ugliness in the code here, because the field+separators are stored in the same way as the fields themselves (as+text). This could lead to confusing results if searches are made that+include null.++Since null is messy for the end user to manipulate (which is why the+problem above is not so serious in practice), two alternative+interfaces are provided to this hierarchical namespace. One uses+``.'' to represent the separator in keys, the other represents keys as+a list of words.++%%Haddock: Convert a list of strings to a ``dot'' separated string+\begin{code}+toDot :: [String] -> String+toDot = toSep '.'+\end{code}+%%Haddock: Convert a ``dot'' separated string to a list of strings+\begin{code}+fromDot :: String -> [String]+fromDot = fromSep '.'+\end{code}++%%Haddock: Convert an array of strings to a null-separated string+\begin{code}+toNull :: [String] -> String+toNull = toSep null+\end{code}+%%Haddock: Convert a null separated string to a list of strings+\begin{code}+fromNull :: String -> [String]+fromNull = fromSep null+\end{code}++Functions in the class interface that use simple strings have a tick+(single quote) suffix (in general, the list based interfaces should be+used in Haskell; the string based interfaces give a simpler interface+to paths embedded in HTML templates).++\subsection{Class}++The general dictionary class. This requires -fglasgow-exts for+compilation with ghc because more than one type parameter is present+(a is needed to make the SubDictionary class, as far as I can see).++%%Haddock: Associate string keys with values+\begin{code}+class Dictionary d a where+ add :: d a -> ([String], a) -> d a -- ^ Add a key-value pair+ add' :: d a -> (String, a) -> d a -- ^ Add .-format+ addAll :: d a -> [([String], a)] -> d a -- ^ Add a key-value list+ addAll' :: d a -> [(String, a)] -> d a -- ^ Add list .-format+ search :: d a -> [String] -> Maybe a -- ^ Lookup a key+ search' :: d a -> String -> Maybe a -- ^ Lookup .-format+ keys :: d a -> [[String]] -- ^ All keys+ keys' :: d a -> [String] -- ^ All keys .-format+ contents :: d a -> [([String], a)] -- ^ All key-value pairs+ contents' :: d a -> [(String, a)] -- ^ All pairs .-format+ values :: d a -> [a] -- ^ All values+ children :: d a -> [String] -> [d a] -- ^ Sub-dictionaries+ children' :: d a -> String -> [d a] -- ^ Children .-format+ adopt :: d a -> ([String], d a) -> d a -- ^ Append sub-dictionary+ adopt' :: d a -> (String, d a) -> d a -- ^ Adopt .-format+ merge :: d a -> d a -> d a -- ^ Combine two dictionaries+\end{code}++\subsection{Case Sensitive}++This builds directly on the tree--based implementation described below.++\begin{code}+data DictCase a = DictCase (Dict a) (Maybe a)++instance (Show a) => Show (DictCase a) where+ show (DictCase d v) = "{" ++ show d ++ "," ++ show v ++ "}"+\end{code}+%%Haddock: An empty dictionary+\begin{code}+empty :: Dictionary DictCase a => DictCase a+empty = DictCase Empty Nothing++pack :: Unpacked a -> DictCase a+pack (d, v) = DictCase d v++unpack :: DictCase a -> Unpacked a+unpack (DictCase d v) = (d, v)++instance Dictionary DictCase a where+ add d (k, v) = pack $ insert (unpack d) (toNull k, v)+ add' d (k, v) = add d (fromDot k, v)+ addAll = foldl add+ addAll' = foldl add'+ search d k = find (unpack d) (toNull k)+ search' d k = search d (fromDot k)+ keys = map fst . contents+ keys' = map toDot . keys+ contents = map (\(k, v) -> (fromNull k, v)) . contents'' . unpack+ contents' = map (\(k, v) -> (toDot k, v)) . contents+ values = map snd . contents+ children d k = map pack $ children'' (unpack d) (toNull k)+ children' d k = children d (fromDot k)+ adopt d1 (k, d2) = pack $ adopt'' (unpack d1) (toNull k) (unpack d2)+ adopt' d1 (k, d2) = adopt d1 (fromDot k, d2)+ merge d1 d2 = pack $ merge'' (unpack d1) (unpack d2)+\end{code}++\subsection{Case Insensitive}++Again, this builds on the tree--based implementation described below.++Is there a better way to generalise this packing/unpacking to a common+form that occurs in the code above and below?++\begin{code}+data DictNoCase a = DictNoCase (Dict a) (Maybe a)++instance (Show a) => Show (DictNoCase a) where+ show (DictNoCase d v) = "{" ++ show d ++ "," ++ show v ++ "}"+\end{code}+%%Haddock: An empty case-insensitive dictionary+\begin{code}+emptyNC :: Dictionary DictNoCase a => DictNoCase a+emptyNC = DictNoCase Empty Nothing++packNC :: Unpacked a -> DictNoCase a+packNC (d, v) = DictNoCase d v++unpackNC :: DictNoCase a -> Unpacked a+unpackNC (DictNoCase d v) = (d, v)++uncase :: String -> String+uncase = map toLower++instance Dictionary DictNoCase a where+ add d (k, v) = packNC $ insert (unpackNC d) (uncase $ toNull k, v)+ add' d (k, v) = add d (fromDot k, v)+ addAll = foldl add+ addAll' = foldl add'+ search d k = find (unpackNC d) (uncase $ toNull k)+ search' d k = search d (fromDot k)+ keys = map fst . contents+ keys' = map toDot . keys+ contents = map (\(k, v) -> (fromNull k, v)) . contents'' . unpackNC+ contents' = map (\(k, v) -> (toDot k, v)) . contents+ values = map snd . contents+ children d k = map packNC $ children'' (unpackNC d) (uncase $ toNull k)+ children' d k = children d (fromDot k)+ adopt d1 (k, d2) = + packNC $ adopt'' (unpackNC d1) (uncase $ toNull k) (unpackNC d2)+ adopt' d1 (k, d2) = adopt d1 (fromDot k, d2)+ merge d1 d2 = packNC $ merge'' (unpackNC d1) (unpackNC d2)+\end{code}++\subsection{Partition}++Diff generates the differences between two dictionaries. The first+list in the result contains entries in d1 that are not present in d2;+the second contains entries in d2 that are not present in d1; the+third entries comomn to both.++%%Haddock: A dictionary whose values can be ordered (and so sorted)+\begin{code}+class (Ord a, Dictionary d a) => OrdDictionary d a where+ diff :: d a -> d a + -> ([([String], a)], [([String], a)], [([String], a)])+ -- ^ Partition into common and distinct values+ diff' :: d a -> d a + -> ([(String, a)], [(String, a)], [(String, a)])+ -- ^ Partition into common and distinct values .-format++instance Ord a => OrdDictionary DictCase a where+ diff d1 d2 = mapT3 (map (\(k, v) -> (fromNull k, v))) $ + diff'' (unpack d1) (unpack d2)+ diff' d1 d2 = mapT3 (map (\(k, v) -> (toDot k, v))) $ diff d1 d2++instance Ord a => OrdDictionary DictNoCase a where+ diff d1 d2 = mapT3 (map (\(k, v) -> (fromNull k, v))) $ + diff'' (unpackNC d1) (unpackNC d2)+ diff' d1 d2 = mapT3 (map (\(k, v) -> (toDot k, v))) $ diff d1 d2++diff'' :: Ord a => Unpacked a -> Unpacked a + -> ([(String, a)], [(String, a)], [(String, a)])+diff'' d1 d2 = partition [] [] [] (contents'' d1) (contents'' d2)++partition :: Ord a => [(String, a)] -> [(String, a)] -> [(String, a)]+ -> [(String, a)] -> [(String, a)]+ -> ([(String, a)], [(String, a)], [(String, a)])+partition o1 o2 b [] [] = (o1, o2, b)+partition o1 o2 b d1 [] = (o1++d1, o2, b)+partition o1 o2 b [] d2 = (o1, o2++d2, b)+partition o1 o2 b d1'@((k1, v1):d1) d2'@((k2, v2):d2) =+ case compare k1 k2 of+ LT -> partition (o1++[(k1, v1)]) o2 b d1 d2'+ GT -> partition o1 (o2++[(k2, v2)]) b d1' d2+ EQ -> case compare v1 v2 of + LT -> partition (o1++[(k1, v1)]) o2 b d1 d2'+ GT -> partition o1 (o2++[(k2, v2)]) b d1' d2+ EQ -> partition o1 o2 (b++[(k1, v1)]) d1 d2+\end{code}++\subsection{Substitution}++A very simple ``language'' for substituting values from dictionaries+into strings simplifies several parts of Halipeto. Clearly the+dictionary must return string values for this to work.++The syntax is simple: text within curly braces is taken as a path name+and substituted for the corresponding text. If the key does not+correspond to any value it is left as literal text.++Braces can be nested (inner braces are necesarily evaluated first)+and can be escaped using the ``$\backslash$'' character (which itself+must be escaped if required as a literal).++For example, given the dictionary:+\begin{verbatim}+foo.bar = baz+foo.baz = hello+\end{verbatim} +the string ``\{foo.\{foo.bar\}\} $\backslash$$\backslash$ world'' will+evaluate to ``hello $\backslash$ world''.++%%Haddock: A dictionary that supports recursive substitution+\begin{code}+class (OrdDictionary d String) => SubDictionary d where+ substitute :: d String -> String -> String -- ^ Replace keys+ substitute d s = unescape $ txt d s+ subAll :: d String -> [String] -> [String] -- ^ Replace on all+ subAll d = map (substitute d)+ search'' :: d String -> [String] -> Maybe String -- ^ Replace & search+ search'' d s = search d $ subAll d s++instance SubDictionary DictCase++instance SubDictionary DictNoCase+\end{code}++The following code processes the text from left to right (the mutually+recursive structure of the code, with no returns and multiple passes+along the string was a surprise --- I was intending to write a+traditional recursive descent parser, but I think this is different+--- and any comments would be welcome).++\begin{code}+txt, txt' :: (Dictionary d String) => d String -> String -> String+txt _ "" = ""+txt d (c:s) | c == '\\' = c : (txt' d s)+ | c == '{' = pth d [] "" s+ | otherwise = c : (txt d s)+txt' _ "" = error "end of string during character escape"+txt' d (c:s) = c : (txt d s)++pth, pth' :: (Dictionary d String) => + d String -> [String] -> String -> String -> String+pth _ _ _ "" = error $ "end of string during substitution\n" +++ " (probably missing '}')"+pth d l p (c:s) | c == '\\' = pth' d l (p++[c]) s+ | c == '.' = pth d (l++[p]) "" s+ | c == '{' = pth d l p (pth d [] "" s)+ | c == '}' =+ case search d (l++[p]) of+-- Nothing -> error $ "cannot find translation for " ++ (toDot (l++[p]))+ Nothing -> (toDot $ l++[p]) ++ (txt d s)+ Just x -> (txt d x) ++ (txt d s)+ | otherwise = pth d l (p++[c]) s+pth' _ _ _ "" = error "end of string during character escape"+pth' d l p (c:s) = pth d l (p++[c]) s++unescape, unescape' :: String -> String+unescape "" = ""+unescape (c:s) | c == '\\' = unescape' s+ | otherwise = c : (unescape s)+unescape' "" = error "end of string during character escape"+unescape' (c:s) = c : (unescape s)+\end{code}++\subsection{Unpacked}++The Unpacked type adds support to Dict for values associated with the+empty string.++\begin{code}+type Unpacked a = (Dict a, Maybe a)+\end{code}++\subsection{Access}++Insert and find are the two basic dictionary operations.++\begin{code}+insert :: Unpacked a -> (String, a) -> Unpacked a+insert (d, _) ("", x) = (d, Just x)+insert (d, v) sx = (copy f d sx, v)+ where+ f n v' = n {value = Just v'}++find :: Unpacked a -> String -> Maybe a+find (_, v) "" = v+find (d, _) s = apply f d s+ where+ f Empty = Nothing+ f n = value n+\end{code}++The keys available in a dictionary can be listed with keys''.++\begin{code}+contents'' :: Unpacked a -> [(String, a)]+contents'' (d, Just x) = ("", x) : (contents'' (d, Nothing))+contents'' (d, Nothing) = map rev $ foldD f (\_ -> []) d ""+ where+ f c (Just v) l m r s = [(c:s, v)] ++ (l s) ++ (m $ c:s) ++ (r s)+ f c Nothing l m r s = (l s) ++ (m $ c:s) ++ (r s)+ rev (s, x) = (reverse s, x)+\end{code}++Merge adds values from the second dictionary into the first (I suspect+there's a more efficient version of this that works on nodes+directly).++\begin{code}+merge'' :: Unpacked a -> Unpacked a -> Unpacked a+merge'' d1 d2 = foldl insert d1 (contents'' d2)+\end{code}++\subsection{Subtrees}++The children and adopt functions make explicit use of this namespace.++Children returns a labelled forest under a given key. For example, if+a dictionary included+\begin{verbatim}+mytext.1.a = "A1"+mytext.2.a = "A2"+mytext.2.b = "B2"+\end{verbatim}++then the children of mytext would be two dictionaries, associated with+the lablels ``1'' and ``2'':+\begin{verbatim}+1: a = "A1"+2: a = "A2"; b = "B2"+\end{verbatim}++The labels are sorted so that they will be correctly ordered when they+are integer values, as above.++In addition, empty keys are handled correctly (not consistently,+necesarily, but in a way that is intuitively correct when iterating+over values in a template). So, in the example above, if+\begin{verbatim}+mytext.3 = "3 with no key"+\end{verbatim}++then the forest would also contain a dictionary with label ``3'' that+associates the empty string with the value ``3 with no key''.++A sub--tree can be re--inserted into the dictionary at a different+path using adopt. This provides a natural way of iterating over data+in the dictionary (note that a level of hierarchy --- the values that+are returned as lables by children --- is removed by adopting a+child).++The SU type is a wrapper for (String, Unpacked a) that allows sorting+via the Ord class.++\begin{code}+children'' :: Unpacked a -> String -> [Unpacked a]+children'' (d, Just x) "" = + combine $ (SU "" (Empty, Just x)):(sort $ subTree d [null])+children'' (d, _) s = combine . sort $ subTree d (s ++ [null])++subTree :: Dict a -> String -> [SU a]+subTree = apply f+ where+ f Empty = []+ f n = collect (match n)+\end{code}++Collect should gather each key and the associated subtree. So it+should collect each node below a null.++\begin{code}+collect :: Dict a -> [(SU a)]+collect d = foldD' f g d ("", Nothing)+ where+ f n c v l m r pre'@(pre, vp) | c == null = + (l pre') ++ [SU (reverse pre) (match n, vp)] ++ (r pre')+ | otherwise =+ (l pre') ++ (m $ (c:pre, v)) ++ (r pre')+ g (pre, Just vp) = [SU (reverse pre) (Empty, Just vp)]+ g (_, Nothing) = []++data SU a = SU String (Unpacked a)++instance Ord (SU a) where+ compare (SU s1 _) (SU s2 _) = compare' s1 s2 EQ++instance Eq (SU a) where+ (==) a b = EQ == compare a b++compare' :: String -> String -> Ordering -> Ordering+compare' [] [] def = def+compare' _ [] _ = GT+compare' [] _ _ = LT+compare' (a:as) (b:bs) EQ = compare' as bs (compare a b)+compare' (_:as) (_:bs) def = compare' as bs def++combine :: [SU a] -> [Unpacked a]+combine l = map (\(SU _ x) -> x) $ foldr f [] l+ where+ f x [] = [x]+ f a@(SU _ (_, Just _)) (b@(SU _ (_, Just _)):bs) = a:b:bs+ f (SU sa (_, Just xa)) ( (SU sb (db, _)):bs) | sa == sb = (SU sa (db, Just xa)):bs+ f (SU sa (da, _)) ( (SU sb (_, Just xb)):bs) | sa == sb = (SU sa (da, Just xb)):bs+ f a@(SU _ _) (b@(SU _ _):bs) = a:b:bs++adopt'' :: Unpacked a -> String -> Unpacked a -> Unpacked a+adopt'' d s (d', Just x) = adopt'' (insert d (s, x)) s (d', Nothing)+adopt'' (d, x) s (d', Nothing) = (copy f d (s ++ [null], d'), x)+ where+ f n1 n2 = n1 {match = fst $ merge'' (match n1, Nothing) (n2, Nothing)}+\end{code}++\subsection{Tree Implementation}++The underlying implementation for all this is a simple ternary tree.+It's not very efficient, but will do for now. Here we define the+structure and basic folds. The second fold includes the node itself,+which saves us from having to reconstruct sub-trees (an efficiency+hack).++\begin{code}+data Dict a = Node {char :: Char,+ value :: Maybe a,+ left :: Dict a, + match :: Dict a, + right :: Dict a}+ | Empty++foldD :: (Char -> Maybe b -> a -> a -> a -> a) -> a -> Dict b -> a+foldD _ a Empty = a+foldD f a (Node c v l m r) = f c v (foldD f a l) (foldD f a m) (foldD f a r)++foldD' :: (Dict b -> Char -> Maybe b -> a -> a -> a -> a) -> a -> Dict b -> a+foldD' _ a Empty = a+foldD' f a n@(Node c v l m r) = f n c v (foldD' f a l) + (foldD' f a m) (foldD' f a r)++instance (Show a) => Show (Dict a) where+ show x = showDict x++showDict :: (Show t) => Dict t -> [Char]+showDict Empty = "-"+showDict (Node c v l m r) = "[" ++ [c] ++ ":" ++ (show v) ++ "," +++ (show l) ++ "," ++ (show m) ++ "," ++ + (show r) ++ "]"+\end{code}++The support functions copy and apply descend the tree to the point+specified by the string and then apply a function. On the way down,+copy copies the tree.++\begin{code}+apply :: (Dict a -> b) -> Dict a -> String -> b+apply fn = foldD' f (\_ -> fn Empty)+ where+ f n c _ l _ r s'@[s] | s == c = fn n+ | s < c = l s'+ | s > c = r s'+ f _ c _ l m r s'@(s:ss) | s == c = m ss+ | s < c = l s'+ | s > c = r s'++copy :: (Dict a -> b -> Dict a) -> Dict a -> (String, b) -> Dict a+copy fn = foldD' f g+ where+ f n c _ l m r a@((s:ss), v') | s == c && ss == [] = fn n v'+ | s == c = n {match = m (ss, v')}+ | s < c = n {left = l a}+ | s > c = n {right = r a}+ g ((s:ss), v') | ss == [] = fn (Node s Nothing Empty Empty Empty) v'+ | otherwise = Node s Nothing Empty (g (ss, v')) Empty+\end{code}
+ Halipeto/Functions.lhs view
@@ -0,0 +1,346 @@+% +% Halipeto 2.0 - Haskell static web page generator +% Copyright 2004 Andrew Cooke (andrew@acooke.org) +% Copyright 2007 Peter Simons (simons@cryp.to) +% +% This program is free software; you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation; either version 2 of the License, or +% (at your option) any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program; if not, write to the Free Software +% Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +% +% EXCEPT +% +% Files in FromHaxml are from HaXml - http://www.cs.york.ac.uk/HaXml - +% see the COPYRIGHT and LICENSE in that directory. The files included +% are a subset of the full HaXml distribution and have been modified to +% originate from the FromHaxml module (so that install on Win32 is +% easy). +% ++\section{Functions}++This section describes the Custom Functions available by default in+the hal namespace.++\begin{code}+module Halipeto.Functions (+ split, parse,+ eval, attribute, text, textReplace, textAfter, repeat,+ addDefaultsFn,+ parseElements, parseElement, mkElements, mkElement, xhtml, element+) where++import Prelude hiding (repeat)+import Halipeto.Template+import Halipeto.Dictionary+import Halipeto.Utilities+import Char+import Text.XML.HaXml.Parse+import Text.XML.HaXml.Types+\end{code}++\subsection{Argument Lists}++A function may require more than one argument, but attributes have+only a single value. The convention used here is for a fixed number+of space delimited arguments, with the possibility of spaces in the+final value (usually text).++%%Haddock: Separate the argument into the expected number of values+\begin{code}+split :: Int -> String -> [String]+split n s = + case split' n [] "" (dropSpace s) of+ Just ss -> ss+ Nothing -> error $ "too few arguments (<" ++ (show n) ++ "): " ++ s++split' :: Int -> [String] -> String -> String -> Maybe [String]+split' _ _ _ "" = Nothing+split' 1 l _ s = Just $ l ++ [dropSpace s]+split' n l a (c:s) | isSpace c = split' (n-1) (l++[a]) "" (dropSpace s)+ | otherwise = split' n l (a++[c]) s+\end{code}++\subsection{Argument Parsing}++I had to decide whether to do substittion before or after splitting an+argument. If it introduces spaces then early substitution may alter+how the argument is split. While this might have lead to cool+meta-programming hacks, I thought it more likely to confuse. So+substitution is later. The only danger with this that I can see is+that one might incorrectly assume that initial arguments, after+parsing and substitution, never contain embedded spaces.++%%Haddock: Separate argument and do substituion from state+\begin{code}+parse :: SubDictionary d => d String -> Int -> String -> [String]+parse d n = subAll d . split n+\end{code}++\subsection{hal:eval}++Evaluate a function. Probably pointless, but I can't resist the+temptation. All substitution takes place during the first evaluation.++\begin{verbatim}+<element hal:eval="fn-path arg"/>+-> <element fn="arg"/>+-> ...++<element hal:eval="hal.attribute name value"/>+-> <element hal:attribute="name value"/>+-> <element name="value"/>+\end{verbatim}++%%Haddock: Evaluate a named function+\begin{code}+eval :: (SubDictionary s, Dictionary f (CustomFn s f)) => CustomFn s f+eval ctx arg = case search' (funcs ctx) nm of+ Nothing -> return $ error $ "cannot find function " ++ nm+ Just fn -> fn ctx val+ where+ [nm,val] = parse (state ctx) 2 arg+\end{code}++\subsection{hal:attribute}++Add an attribute to the current element.++\begin{verbatim}+<element hal:attribute="name value"/>+-> <element name="value"/>+\end{verbatim}++%%Haddock: Add an attribute to the current element+\begin{code}+attribute :: (SubDictionary s, Dictionary f (CustomFn s f)) => CustomFn s f+attribute ctx arg = do return (ctx, Attr nm val)+ where+ [nm, val] = parse (state ctx) 2 arg+\end{code}++\subsection{hal:text}++Append / prepend text to the contents of the current element.++\begin{verbatim}+<element hal:text="value"/>+-> <element>value</element>+\end{verbatim}++\begin{code}+text' :: (SubDictionary s, Dictionary f (CustomFn s f)) =>+ Position -> CustomFn s f+text' pos ctx arg = do return (ctx, Text pos $ substitute (state ctx) arg)+\end{code}+%%Haddock: Prepend text to the current element+\begin{code}+text :: + (SubDictionary s, Dictionary f (CustomFn s f)) => CustomFn s f+text = text' Before+\end{code}+%%Haddock: Append text to the current element+\begin{code}+textAfter :: + (SubDictionary s, Dictionary f (CustomFn s f)) => CustomFn s f+textAfter = text' After+\end{code}+%%Haddock: Replace text to the current element+\begin{code}+textReplace :: + (SubDictionary s, Dictionary f (CustomFn s f)) => CustomFn s f+textReplace = text' Replace+\end{code}++\subsection{hal:repeat}++Assign the sub-elements of root (in the state dictionary) to name, one+at a time, evaluating the template sub--tree.++\begin{verbatim}+root.1 = a+root.2 = b+<element hal:repeat="name root">+ <p hal:text="{name}"/>+</element>+-> <element>+ <p>a</p>+ <p>b</p>+ </element>+\end{verbatim}++%%Haddock: Repeat the evaluation of the remaining attributes and+%%Haddock: contents while the related function returns a Return+%%Haddock: value+\begin{code}+repeat :: (SubDictionary s, Dictionary f (CustomFn s f)) => CustomFn s f+repeat ctx arg = repeat' nm vals ctx ""+ where+ dct = state ctx+ [nm, val] = parse dct 2 arg+ vals = children' dct val++repeat' :: (SubDictionary s, Dictionary f (CustomFn s f)) => + String -> [s String] -> CustomFn s f+repeat' p [] ctx _ = do putStrLn $ "end of repeat: " ++ p+ return (ctx, Skip)+repeat' p (s:ss) ctx _ = do putStrLn $ "repeat: " ++ p ++ ": " ++ + (show (contents s))+ return (ctx', Repeat $ repeat' p ss)+ where+ ctx' = ctx {state = adopt' (state ctx) (p, s)}+\end{code}++\subsection{hal:eq, hal:neq}++Test for (non--)equality of the two arguments.++\begin{verbatim}+<element hal:eq="a b">foo</element> -> <element/>+\end{verbatim}++%%Haddock: Continue evaluation of contents if two arguments equal+\begin{code}+eq :: (SubDictionary s, Dictionary f (CustomFn s f)) => CustomFn s f+eq ctx arg = eq' ctx True $ parse (state ctx) 2 arg+\end{code}+%%Haddock: Continue evaluation of contents if two arguments inequal+\begin{code}+neq :: (SubDictionary s, Dictionary f (CustomFn s f)) => CustomFn s f+neq ctx arg = eq' ctx False $ parse (state ctx) 2 arg++eq' :: (SubDictionary s, Dictionary f (CustomFn s f)) => + Context s f -> Bool -> [String] -> IO (Context s f, Result s f)+eq' ctx x (a:[b]) = do return $ (ctx, if x `xor` (a /= b)+ then Continue+ else Skip)+ where+ p `xor` q = (p && not q) || (q && not p)+\end{code}++\subsection{Support for Insertion}++These functions provide basic support for meta-templates. You can+place template HTML in the database then insert it in a ``skeleton''+template. They're also useful for writing small ``abbreviation''+functions.++%%Haddock: Parse text as XML+\begin{code}+parseElements :: String -> [Element]+parseElements txt = fromElement $ parseElement "parseelements" txt+ where+ fromElement (Elem "parseelements" _ els) = map unContent els+ unContent (CElem x) = x+ unContent s@(CString _ _) = Elem "p" [] [s]+ unContent _ = error "cannot parse xml as element"+\end{code}+%%Haddock: Parse text as XML within an element+\begin{code}+parseElement :: String -> String -> Element+parseElement elt txt = fromDoc $ xmlParse txt txt'+ where+ txt' = "<?xml version='1.0' encoding='iso-8859-1'?><" ++ elt ++ ">"+ ++ txt ++ "</" ++ elt ++ ">"+ fromDoc (Document _ _ el _) = el+\end{code}+%%Haddock: Generate a function that inserts XML parsed from text+\begin{code}+mkElements :: Position -> String -> CustomFn s f+mkElements pos txt ctx _ = do return (ctx, Xml pos (parseElements txt))+\end{code}+%%Haddock: Generate a function that inserts XML parsed from text, +%%Haddock: within an element+\begin{code}+mkElement :: Position -> String -> String -> CustomFn s f+mkElement pos elt txt ctx _ = do return (ctx, Xml pos [parseElement elt txt])+\end{code}++\subsection{hal:xhtml}++Insert a group of elements (bare text is enclosed in p tags).++\begin{verbatim}+link = foo+text = hello <a hal:attribute="href {link}">world</a>+<element hal:xhtml="{text}"/>+-> <element>+ <p>hello</p>+ <a href="foo">world</a>+ </element>+\end{verbatim}++%%Haddock: A custom function for inserting XHTML+\begin{code}+xhtml :: (SubDictionary s, Dictionary f (CustomFn s f)) => + Position -> CustomFn s f+xhtml pos ctx txt = do return (ctx, Xml pos (parseElements txt'))+ where+ txt' = substitute (state ctx) txt+\end{code}++\subsection{hal:element}++Insert a named element.++\begin{verbatim}+link = foo+text = hello <a hal:attribute="href {link}">world</a>+<element hal:element="p {text}"/>+-> <element>+ <p>hello <a href="foo">world</a></p>+ </element>+\end{verbatim}++%%Haddock: A custom function for inserting XHTML within an element+\begin{code}+element :: (SubDictionary s, Dictionary f (CustomFn s f)) => + Position -> CustomFn s f+element pos ctx txt = do return (ctx, Xml pos [parseElement tag txt''])+ where+ [tag, txt'] = split 2 txt+ txt'' = substitute (state ctx) txt'+\end{code}++For an example of the element tag in use, see the image.html teplate+in the demo. Insertion of a p element allows the body text to contain+template functions without the need for explicit $<$p$>$ markup around+each paragraph.++\subsection{Load Defaults}++Make the custom functions above available in the funcs dictionary+under the hal namespace.++%%Haddock: Add standard functions to a dictionary+\begin{code}+addDefaultsFn :: (SubDictionary s, Dictionary f (CustomFn s f)) => + f (CustomFn s f) -> f (CustomFn s f)+addDefaultsFn fn = addAll fn fns+ where+ fns = map (\(n,f) -> ([hal, n], f)) lst+ lst = [("eval", eval),+ ("attribute", attribute),+ ("text", text),+ ("textafter", textAfter),+ ("textreplace", textReplace),+ ("repeat", repeat),+ ("eq", eq),+ ("neq", neq),+ ("xhtml", xhtml Before),+ ("xhtmlafter", xhtml After),+ ("xhtmlreplace", xhtml Replace),+ ("element", element Before),+ ("elementafter", element After),+ ("elementreplace", element Replace)]+\end{code}+
+ Halipeto/Pages.lhs view
@@ -0,0 +1,364 @@+% +% Halipeto 2.0 - Haskell static web page generator +% Copyright 2004 Andrew Cooke (andrew@acooke.org) +% Copyright 2007 Peter Simons (simons@cryp.to) +% +% This program is free software; you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation; either version 2 of the License, or +% (at your option) any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program; if not, write to the Free Software +% Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +% +% EXCEPT +% +% Files in FromHaxml are from HaXml - http://www.cs.york.ac.uk/HaXml - +% see the COPYRIGHT and LICENSE in that directory. The files included +% are a subset of the full HaXml distribution and have been modified to +% originate from the FromHaxml module (so that install on Win32 is +% easy). +% ++\section{Pages}++A website is a collection of related pages. The code here fixes these+relationships, relating page names, directories and templates.++\begin{code}+module Halipeto.Pages (+ PageGen, PageGenS, idD, page, noPage, append, repeat, leafP, foldT,+ setSiteDetails, generate,+ menuClass, menuClass', Label, Collect, baseMenu, listMenu+) where++import Prelude hiding (repeat, all)+import Halipeto.Template+import Halipeto.Dictionary+import Halipeto.Utilities+import Text.XML.HaXml.Pretty+import Text.XML.HaXml.Types+import Maybe+import IO+import Monad+import System.Directory+\end{code}++First we extend the definition of the Page type defined in the+Template section.++\begin{code}+instance Show (Page s) where+ show p = (toSlash $ path p) ++ ": " ++ (template p)++instance Eq (Page s) where+ (==) a b = (==) (path a) (path b)++instance Show (TreeSite s) where+ show t = foldT (\p ts -> (show p) ++ ":" ++ (show ts)) "" t+\end{code}++This fold uses foldr to preserve the order of children (for some+reason I keep getting the order wrong when I try to use a foldl and+correct in the folded function).++%%Haddock: Fold over the TreeSite structure+\begin{code}+foldT :: (Maybe (Page s) -> a -> a) -> a -> TreeSite s -> a+foldT f a (TreeSite p ts) = f p (foldr (flip $ foldT f) a ts)+\end{code}++\subsection{Using the Database}++We can use use the information in Halipeto's SimpleDB database to help+define paes. In particular, we can iterate over groups just as we do+in templates. The aim is to support code like (copied from the+Demo code):++\begin{verbatim}+(page ["index.html"] "front-page.html" idD+ (repeat "locale" "locale-list"+ (page ["{locale}", "index.html"] "index-locale.html" idD+ (append+ (repeat "group" "group-list"+ (page ["{locale}", "{group}.html"] "index-group.html" idD+ (repeat "image" "groups.{group}.images"+ (page ["{locale}", "{image}.html"] "image.html" idD leafP))))+ (page ["{locale}", "order.html"] "order.html" idD leafP)))))+\end{verbatim}++That is applied to a suitable dictionary to generate site structure+like:++\begin{verbatim}++- index++- locale-1+: +- group-1+ | +- image-1+ | +- image-2+ | :+ +- group...+ :+ +- order+\end{verbatim}++So page associates a parent with children pages; repeat generates a+set of siblings (and modifies the dictionary), and append adds a page+to others at the same level.++Hopefully the parallels with iterating over values in a template (see,+for example, the ``How To'' section near the start of this+documentation) are clear.++Of course, you are also free to specify the site structure as you+like. Simply construct the appropriate TreeSite instances.++One final feature --- these functions store changes to the state+dictionary with the site information. These changes are re--applied+when the page is generated. So templates can assume that the+variables used by repeat during the definition of the page structure+are available during page generation (they appear as children of+``hal.menu'' to avoid conflicts with simialr values in the template).++In the example above ``hal.menu.locale'' will be defined for all pages+except the initial index.++%%Haddock: The intermediate function used to construct a page+%%Haddock: within a hierarchy+\begin{code}+type PageGen s = s String -> s String -> TreeSite s+\end{code}+%%Haddock: The intermediate function used to construct a list +%%Haddock: of pages within a hierarchy+\begin{code}+type PageGenS s = s String -> s String -> [TreeSite s]+\end{code}++It is also possible to define additional additional values in the+state for a particular page. IdD should be used when no extra values+are equired (see example above).++%%Haddock: Default function when no additional values are added+%%Haddock: to the state for this page.+\begin{code}+idD :: UpdateDict s+idD d _ = d+\end{code}++%%Haddock: Construct a page with its children+\begin{code}+page :: SubDictionary s => + [String] -> String -> UpdateDict s -> PageGenS s -> PageGen s+page pth tmpl upd ts dct dc0 = + TreeSite (Just $ Page pth' tmpl' upd') (ts dct' dc0)+ where+ dct' = upd dct []+ pth' = subAll dct' pth+ tmpl' = substitute dct' tmpl+ (dif, _, _) = diff dct' dc0+ upd' d s = addAll d $ map (\(k, v) -> (s++k, v)) $ dif+\end{code}++LeafP is used in place of the list of child pages when the page is a+leaf node.+%%Haddock: Placeholder for when a page has no children+\begin{code}+leafP :: PageGenS s+leafP _ _ = []+\end{code}++A group of pages may exist in the hierarchy without a parent page.+%%Haddock: Group pages without a parent page+\begin{code}+noPage :: SubDictionary s => PageGenS s -> PageGen s+noPage ts dct dc0 = TreeSite Nothing (ts dct dc0)+\end{code}++%%Haddock: Append a page to a list of pages+\begin{code}+append :: PageGenS s -> PageGen s -> PageGenS s+append pg1 pg2 dct dc0 = (pg1 dct dc0) ++ [(pg2 dct dc0)]+\end{code}++%%Haddock: Iterate over the children of a node in the state dictionary+\begin{code}+repeat :: SubDictionary s => String -> String -> PageGen s -> PageGenS s+repeat to frm pg dct dc0 = repeat' to' frm (children' dct frm') pg dct dc0+ where+ [to', frm'] = subAll dct [to, frm]++repeat' :: SubDictionary s => + String -> String -> [s String] -> PageGen s -> PageGenS s+repeat' _ frm [] _ dct _ = error $ "nothing to repeat for " ++ frm +++ "\n" ++ (show $ contents dct)+repeat' to _ ch pg dct dc0 = foldr f [] ch+ where+ f ch pgs = (pg (adopt' dct (to, ch)) dc0):pgs+\end{code}++\subsection{Standard State}++The following values are assumed to be present in the context state.+They can be provided by calling setSiteDetails.++\begin{tabular}{l|l}+key&value\\+\hline+hal.destination&Path to prepend to generated file names\\+hal.templates&Path to prepend to template names+\end{tabular}++\begin{code}+destination = [hal, "destination"]+templates = [hal, "templates"]++orBlank :: Maybe String -> String+orBlank = fromMaybe ""+\end{code}+%%Haddock: Define standard state+\begin{code}+setSiteDetails :: SubDictionary s =>+ s String -> String -> String -> s String+setSiteDetails dct dest tmpl = addAll dct [(destination, dest),+ (templates, tmpl)]+\end{code}++\subsection{Generation}++These functions generate the pages that were previously defined in the+context's TreeSite structure.++%%Haddock: Generate the pages described for the site+\begin{code}+generate :: (SubDictionary s, Dictionary f (CustomFn s f)) =>+ Context s f -> IO ()+generate ctx = do foldT (generate' ctx) (do return ()) (site ctx)++generate' :: (SubDictionary s, Dictionary f (CustomFn s f)) =>+ Context s f -> Maybe (Page s) -> IO () -> IO ()+generate' _ Nothing prv = prv+generate' ctx (Just pg) prv =+ do putStrLn $ "generating " ++ htmlPath ++ " from " ++ tmplPath+ tmpl <- readTemplate tmplPath+ html <- evalDocument ctx' tmpl+ checkDir htmlPath+ hOut <- openFile htmlPath WriteMode+ hPutStr hOut $ show (document html)+ hClose hOut+ prv+ where+ dct = updateState (state ctx) pg+ ctx' = ctx {state = dct}+ to = orBlank $ search dct destination+ htmlPath = toSlash $ [to] ++ path pg+ frm = orBlank $ search dct templates+ tmplPath = frm `slash` (template pg)++updateState :: (SubDictionary s) => s String -> Page s -> s String+updateState dct pg = addAll (dictionary pg dct []) + [rootPath pth, + pathPath pth,+ ([hal, "template"], template pg)]+ where+ pth = path pg++-- the path to the current page+pathPath :: [String] -> ([String], String)+pathPath pth = ([hal, "path"], toSlash pth)++-- the path "back" to home+rootPath :: [String] -> ([String], String)+rootPath pth = ([hal, "root"], stepUp (depth pth - 1))++depth :: [String] -> Int+depth [] = 0+depth ("..":p) = depth p - 1+depth (".":p) = depth p+depth ("":p) = depth p+depth (_:p) = 1 + depth p++stepUp :: Int -> String+stepUp 0 = "."+stepUp n = (stepUp $ n-1) ++ "/.."++checkDir :: FilePath -> IO String+checkDir pth = checkDir' (allButOne $ fromSlash pth)++checkDir' :: [String] -> IO String+checkDir' pth = foldl f (do return "") pth+ where+ f p s = do p' <- p+ p'' <- return $ p' `slash` s+ ok <- doesDirectoryExist p''+ if ok then return () else createDirectory p''+ return p''++allButOne :: [a] -> [a]+allButOne [] = [] -- or error+allButOne [_] = []+allButOne (x:xs) = x:(allButOne xs)+\end{code}++\subsection{Menu}++Menus for sites can be pretty complex. Here we provide some basic+infrastructure. The functions below are modified using two functions.++Label selects pages and gives the HTML associated with each.++%%Haddock: Define a menu label for a page+\begin{code}+type Label s = s String -> Page s -> Maybe [Element]+\end{code}++Collect groups the HTML associated with pages.++%%Haddock: Combine menu labels+\begin{code}+type Collect = [Element] -> [Element] -> [Element]+\end{code}++\begin{code}+menuClass' = ("class", AttValue [Left "menu"])+menuClass = [menuClass']+\end{code}++Traverse the page structure collecting the menu labels for each page.++%%Haddock: Generate a menu+\begin{code}+baseMenu :: Collect -> TreeSite s -> s String -> Label s -> [Element]+baseMenu col ste dct lab = foldT (baseNode col dct lab) [] ste++baseNode :: Collect -> s String -> Label s+ -> Maybe (Page s) -> [Element] -> [Element]+baseNode _ _ _ Nothing rows = rows+baseNode col dct lab (Just pg) rows =+ case lab dct' pg of+ Nothing -> rows+ Just els -> col els rows+ where+ dct' = (dictionary pg) dct [hal, "menu"]+\end{code}++ListMenu is a menu generating function that assumes the Label will+return a list of elements that should be encapsulated in a table row.+The generated menu is a table containing those rows.++%%Haddock: Generate a flat menu+\begin{code}+listMenu :: TreeSite s -> s String -> Label s -> Element+listMenu ste dct lab = Elem "table" menuClass (map CElem rows)+ where+ rows = baseMenu makeRow ste dct lab++makeRow :: Collect+makeRow els rows = (Elem "tr" menuClass+ [CElem $ Elem "td" menuClass (map CElem els)]) : rows+\end{code}
+ Halipeto/SimpleDB.lhs view
@@ -0,0 +1,385 @@+%+% Halipeto 2.0 - Haskell static web page generator+% Copyright 2004 Andrew Cooke (andrew@acooke.org)+% Copyright 2007 Peter Simons (simons@cryp.to)+%+% This program is free software; you can redistribute it and/or modify+% it under the terms of the GNU General Public License as published by+% the Free Software Foundation; either version 2 of the License, or+% (at your option) any later version.+%+% This program is distributed in the hope that it will be useful,+% but WITHOUT ANY WARRANTY; without even the implied warranty of+% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+% GNU General Public License for more details.+%+% You should have received a copy of the GNU General Public License+% along with this program; if not, write to the Free Software+% Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+%+% EXCEPT+%+% Files in FromHaxml are from HaXml - http://www.cs.york.ac.uk/HaXml -+% see the COPYRIGHT and LICENSE in that directory. The files included+% are a subset of the full HaXml distribution and have been modified to+% originate from the FromHaxml module (so that install on Win32 is+% easy).+%++\section{Simple Database}++This is a very simple database, implemented on top of the file system+using the Dictionary class. The Dictionary namespace reflects the+file path to the text (plus, in some cases, an additional name that+depends on the file type as described below).++There is currently no support for writing data.++Some care must be taken with the cases of characters in filenames on+Windows systems. It may be wise to force all filenames to lower case+via the translate function, or to use a dictionary that is case+insensitive.++The main disadvantage of the SimpleDB implementation, to my mind, is+that there is no formal specification of the structure that verifies+that the information in related directories is consistent. Nothing+warns the user that the second image directory is missing a+details.haldx file, for example. This could be fixed, but it's+difficult to find the energy to make a ``quick fix'' better. A full+SQL interface should be developed instead.++\begin{code}+module Halipeto.SimpleDB (+ Translate, noCVS, allFiles, ReadDB, addDefaultsDB, readDB, readDB'+) where++import Prelude hiding (readList)+import Halipeto.Template+import Halipeto.Dictionary+import Halipeto.Utilities+import Text.Pandoc+import IO+import Directory+import Monad+import List+import Char+\end{code}++\subsection{File Formats}++Three different file formats are supported, giving three ways of+associating the content with the dictionary namespace. The formats+are distinguished by the file extension.++\begin{itemize}++\item {\bf hal} Files ending in ``.hal'' have all their contents stored+under the file's main name (with the associated directory path). For+example, the contents of file diary/2004/jul/text.hal would be stored+in ``diary.2004.jul.text''.++\begin{code}+readHal :: Dictionary d String =>+ Translate -> d String -> FilePath -> [String] -> IO (d String)+readHal _ dct fp ky = do txt <- readFile fp+ return $ add dct (ky, txt)+\end{code}++\item {\bf hals} Each paragraph (separated by one or more blank lines)+in a file with extension ``.hals'' is numbered. So if the contents of+file months.hals had the contents++\begin{verbatim}+jan++feb++mar+..+\end{verbatim}++then the dictionary would associate, for example, ``months.5'' with+``May'' (this could be used to order the months for display, for+example --- a simpler solution might be available via the translation+facility described below).++More often this format is used to store several paragraphs of text+that are iterated over in a template so that each paragraph is enlosed+within its own $<$p$>$ element.++\begin{code}+readHals :: Dictionary d String =>+ Translate -> d String -> FilePath -> [String] -> IO (d String)+readHals tr dct fp ky = do h <- openFile fp ReadMode+ dct' <- readParas h tr dct ky 0+ hClose h+ return dct'++readParas :: Dictionary d String =>+ Handle -> Translate -> d String -> [String] -> Int -> IO (d String)+readParas h tr dct ky n =+ do done <- hIsEOF h+ if done+ then return $ dct+ else do txt <- hGetPara h+ case txt of+ Nothing -> readParas h tr dct ky n+ Just txt' ->+ case tr $ ky ++ [(show n)] of+ Nothing -> readParas h tr dct ky n+ Just k -> readParas h tr (add dct (k, txt')) ky (n+1)++hGetPara :: Handle -> IO (Maybe String)+hGetPara h = do done <- hIsEOF h+ if done+ then return Nothing+ else do txt <- hGetLine h+ if "" == dropSpace txt+ then hGetPara h+ else do txt' <- collect h txt+ return $ Just txt'++collect :: Handle -> String -> IO String+collect h txt = do done <- hIsEOF h+ if done+ then return txt+ else do txt' <- hGetLine h+ if "" == dropSpace txt'+ then return txt+ else collect h $ txt ++ "\n" ++ txt'+\end{code}++\item {\bf haldx} The contents of files ending in ``.haldx'' are read as key+value pairs. The first word on each line is the key, subsequent text,+starting with the first non--space character, is the value. For+example, if the file diary/2004/highlights.haldx contains++\begin{verbatim}+1.month Jan+1.day 2+1.p 4+2.month July+2.day 20+2.p 1+\end{verbatim}++Then the dictionary would associate the value ``July'' with the key+``diary.2004.highlights.2.month''.++\begin{code}+readHaldx :: Dictionary d String =>+ Translate -> d String -> FilePath -> [String] -> IO (d String)+readHaldx tr dct fp ky = do h <- openFile fp ReadMode+ dct' <- readLines h tr dct ky+ hClose h+ return dct'++readLines :: Dictionary d String =>+ Handle -> Translate -> d String -> [String] -> IO (d String)+readLines h tr dct ky =+ do done <- hIsEOF h+ if done+ then return $ dct+ else do txt <- hGetLine h+ txt' <- return $ dropWindowsReturn txt+ case splitLine tr ky txt' of+ Nothing -> readLines h tr dct ky+ Just (k, v) -> readLines h tr (add dct (k, v)) ky++dropWindowsReturn :: String -> String+dropWindowsReturn "" = ""+dropWindowsReturn (c:s) | c == '\r' = dropWindowsReturn s+ | otherwise = c:(dropWindowsReturn s)++splitLine :: Translate -> [String] -> String -> Maybe ([String], String)+splitLine tr ky txt =+ case keyVal txt of+ Nothing -> Nothing+ Just (k, v) -> case tr $ ky ++ k of+ Nothing -> Nothing+ Just ky' -> Just (ky', v)++keyVal :: String -> Maybe ([String], String)+keyVal s = keyVal' "" $ dropSpace s+ where+ keyVal' _ "" = Nothing+ keyVal' k (c:s) | isSpace c = Just (fromDot k, dropSpace s)+ | otherwise = keyVal' (k ++ [c]) s+\end{code}++\end{itemize}++Given those formats it is possible to define two different values with+the same key. In such cases the final result in the dictionary is+undefined (the key will be associated with one of the values, but the+choice will depend on implementation details).++The functions for parsing these file formats are stored in a+dictionary, indexed by file extension. The database can be extended+to handle other formats by adding to this dictionary.++%%Haddock: Map file extension to file reading function+\begin{code}+type ReadDB d = Translate -> d String -> FilePath -> [String] -> IO (d String)+\end{code}+%%Haddock: Add the default file functions (hal, hals, haldx)+\begin{code}+addDefaultsDB :: (Dictionary d String, Dictionary r (ReadDB d)) =>+ r (ReadDB d) -> r (ReadDB d)+addDefaultsDB d = addAll' d [ (hal, readHal)+ , (hal++"s", readHals)+ , (hal++"dx", readHaldx)+ , ("rst", readRstMsg)+ , ("mdwn", readMdwnMsg)+ , ("lst", readList)+ ]+\end{code}++\subsection{Translation}++Before a file is read, its full path (from the base directory of the+database, but excluding the file extension) is passed to a translate+function which returns either a (possibly modified) value or Nothing.+A valid value is used as the base key for the contents, a value of+Nothing will cause that file to be ignored.++Directories are also translated --- their names are not used as keys,+but a value of Nothing will prevent traversal of that directory.++%%Haddock: Type of translation function to select or modify file names+\begin{code}+type Translate = [String] -> Maybe [String]+\end{code}+%%Haddock: Block CVS directories+\begin{code}+noCVS :: Translate+noCVS s | last s == "CVS" = Nothing+ | otherwise = Just s+\end{code}+%%Haddock: Select all files+\begin{code}+allFiles :: Translate+allFiles = Just+\end{code}++\subsection{HTML}++All file contents are read as plain text. Functions called during the+generation of the site may parse some of these values as HTML, but+that functionality is not part of this database.++\subsection{Reading Data}++So here's the code...++\begin{code}+safety :: Translate+safety [] = Nothing+safety l | last l == "" = Nothing+ | head (last l) == '.' = Nothing+ | head (last l) == '/' = Nothing+ | head (last l) == '\\' = Nothing+ | otherwise = Just l+\end{code}+%%Haddock: Read a database from disk using the default file functions+\begin{code}+readDB' :: Dictionary d String =>+ Translate -> d String -> FilePath -> IO (d String)+readDB' = readDB (addDefaultsDB empty)+\end{code}+%%Haddock: Read a database from disk+\begin{code}+readDB :: (Dictionary d String, Dictionary r (ReadDB d)) =>+ r (ReadDB d) -> Translate -> d String -> FilePath -> IO (d String)+readDB d tr dc dr = readFP d (safety `thenMaybe` tr) dc dr []++readFP :: (Dictionary d String, Dictionary r (ReadDB d)) =>+ r (ReadDB d) -> ReadDB d+readFP d tr dct fp ky =+ do isD <- doesDirectoryExist fp+ if isD+ then readDir d tr dct fp ky $ getDirectoryContents fp+ else readHFile d tr dct fp ky++readDir :: (Dictionary d String, Dictionary r (ReadDB d)) =>+ r (ReadDB d) -> Translate -> d String -> FilePath -> [String]+ -> IO [FilePath] -> IO (d String)+readDir d tr dct fp ky l = do l' <- l+ foldM fn dct l'+ where+ fn dct' f = case tr $ ky ++ [beforeDot f] of+ Nothing -> do return dct'+ Just ky' -> readFP d tr dct' (fp `slash` f) ky'+ where+ beforeDot "" = ""+ beforeDot (c:s) | c == '.' = ""+ | otherwise = c:(beforeDot s)++readHFile :: (Dictionary d String, Dictionary r (ReadDB d)) =>+ r (ReadDB d) -> ReadDB d+readHFile d tr dct fp ky = case search' d (suffix fp) of+ Nothing -> do putStrLn $ "no match for " ++ fp+ return dct+ Just fn -> do putStrLn $ "reading " ++ fp+ fn tr dct fp ky++suffix :: String -> String+suffix = suffix' ""++suffix' :: String -> String -> String+suffix' x "" = x+suffix' x (c:s) | c == '.' = suffix' s s+ | otherwise = suffix' x s+\end{code}++Support for Internet Message style entries.++\begin{code}+readMessage :: FilePath -> IO ([(String,String)], String)+readMessage fp = do+ (header,body) <- fmap (span (not . List.null) . lines) (readFile fp)+ let headerLinesWords = map (words . concat) (groupBy (\l r -> isSpace (head r)) header)+ headerLines = map (\wrds -> (fixKeyword (head wrds), unwords (tail wrds))) headerLinesWords+ fixKeyword k+ | ":" `isSuffixOf` k = map toLower $ reverse . tail . reverse $ k+ | otherwise = error $ "unknown header keyword " ++ show k ++ " in " ++ fp+ return (headerLines, unlines . drop 1 $ body)+\end{code}++Support for ReStructured Text Messages.++\begin{code}+readRstMsg :: Dictionary d String => Translate -> d String -> FilePath -> [String] -> IO (d String)+readRstMsg _ dct fp ky = do+ (header,body) <- readMessage fp+ let st = defaultParserState+ opt = defaultWriterOptions { writerStrictMarkdown = True }+ pdoc = readRST st body+ html = writeHtmlString opt pdoc+ dct' = foldl (\d (k,v) -> add d (ky ++ [k], v)) dct header+ return $ add dct' (ky ++ ["body"], html)+\end{code}++Support for Markdown Text Messages.++\begin{code}+readMdwnMsg :: Dictionary d String => Translate -> d String -> FilePath -> [String] -> IO (d String)+readMdwnMsg _ dct fp ky = do+ (header,body) <- readMessage fp+ let st = defaultParserState+ opt = defaultWriterOptions { writerStrictMarkdown = True }+ pdoc = readMarkdown st body+ html = writeHtmlString opt pdoc+ dct' = foldl (\d (k,v) -> add d (ky ++ [k], v)) dct header+ return $ add dct' (ky ++ ["body"], html)+\end{code}++Support for simple entry-by-line lists.++\begin{code}+readList :: Dictionary d String => Translate -> d String -> FilePath -> [String] -> IO (d String)+readList _ dct fp ky = do+ ls <- fmap lines (readFile fp)+ let dct' = foldl (\d (k,v) -> add d (ky ++ [show k], v)) dct (zip [1..] ls)+ return $ dct'+\end{code}
+ Halipeto/Template.lhs view
@@ -0,0 +1,424 @@+%+% Halipeto 2.0 - Haskell static web page generator+% Copyright 2004 Andrew Cooke (andrew@acooke.org)+% Copyright 2007 Peter Simons (simons@cryp.to)+%+% This program is free software; you can redistribute it and/or modify+% it under the terms of the GNU General Public License as published by+% the Free Software Foundation; either version 2 of the License, or+% (at your option) any later version.+%+% This program is distributed in the hope that it will be useful,+% but WITHOUT ANY WARRANTY; without even the implied warranty of+% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+% GNU General Public License for more details.+%+% You should have received a copy of the GNU General Public License+% along with this program; if not, write to the Free Software+% Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+%+% EXCEPT+%+% Files in FromHaxml are from HaXml - http://www.cs.york.ac.uk/HaXml -+% see the COPYRIGHT and LICENSE in that directory. The files included+% are a subset of the full HaXml distribution and have been modified to+% originate from the FromHaxml module (so that install on Win32 is+% easy).+%++\section{Templates}++Templates describe the structure of related pages. It also defines+the basic data structures used elsewhere (to avoid circular module+references).++\begin{code}+module Halipeto.Template (+ CustomFn, Result (Attr, Text, Xml, Repeat, Continue, Skip),+ Position (Before, After, Replace), hal,+ UpdateDict, Page (Page), TreeSite (TreeSite), path, template, dictionary,+ Context (Ctx), state, funcs, site,+ readTemplate, evalElement, evalDocument+) where+\end{code}++\begin{code}+import Maybe+import Char+import Halipeto.Dictionary+import Text.XML.HaXml.Parse hiding ( reference )+import Text.XML.HaXml.Types+\end{code}++\subsection{Context}++The context is the environment in which the template is processed.+Functions may modify the context (ie, return a new instance) if+necessary. Generally only the state will be modified.++The context contains three dictionaries (the type below is more+general, but all functions in Halipeto assume that f implements the+Dictionary class and s the SubDictionary class). The Dictionary type+is described later. It is a pure data structure that associates keys+(strings) with values.++The funcs dictionary contains the custom functions available to the+template engine (see below). The state dictionary provides a unified+way for the system to store and retrieve text. The site component+defines the structure of the site that is being generated.++Non--textual data, or large quantities of text, should be manipulated+indirectly. Functions may include references to other data or execute+IO actions, for example. In such cases the state dictionary would+still be used to manage the associated meta--data (eg table names or+keys for SQL access).++%%Haddock: The context within which a template is evaluated+\begin{code}+data Context s f =+ Ctx {state :: s String, -- ^ State dictionary+ funcs :: f (CustomFn s f), -- ^ Functions dictionary+ site :: TreeSite s -- ^ Site structure+ }+\end{code}++\subsection{Custom Functions}++The template is modified by custom functions that are stored within+the context. Functions are invoked by appearing as attributes in the+template, under a non-empty namespace (the name of the function+corresponds to the attribute name; namespace and function name+together define a hierarchical key for the dictionary --- see the+Dictionary documentation for more details).++The argument supplied to the function is the value of the+corresponding attribute.++%%Haddock: The attribute value+\begin{code}+type Arg = String+\end{code}+%%Haddock: A function invoked by the template+\begin{code}+type CustomFn s f = Context s f -> Arg -> IO (Context s f, Result s f)+\end{code}++Note that currently fuctions do not have access to the XML structure+of the template. This has not been necessary so far, and I'm+reluctant to introduce it until I find a compelling need (partly+because I'm not sure how until I have an example, and partly because+I'm not at all sure it's necessary).++The return code of the function controls subsequent processing.++%%Haddock: Control the position of inserted elements+\begin{code}+data Position = Before -- ^ Insert data before current contents+ | After -- ^ Insert data after current contents+ | Replace -- ^ Replace current contents+\end{code}+%%Haddock: The result from a function called by the template engine+\begin{code}+data Result s f = Attr Name String -- ^ Add an attribute+ | Text Position String -- ^ Add text+ | Xml Position [Element] -- ^ Add XML+ | Repeat (CustomFn s f) -- ^ Recurse on function+ | Continue -- ^ Process next attribute+ | Skip -- ^ Delete contents+\end{code}+%%Haddock: The XML namespace for builtin functions+\begin{code}+hal :: String+hal = "hal"+\end{code}++These types are discussed in more detail in the documentation for+Custom Functions.++\subsection{Pages}++The Page data type carries information used to process a particular+page. Pages are grouped together in a hierarchy using TreeSite.++In addition, some information related to site structure is stored in+the state dictionary. See the Pages documentation for more details.++%%Haddock: Modify the state to contain values for this page+\begin{code}+type UpdateDict s = s String -> [String] -> s String+\end{code}+%%Haddock: Description of a page+\begin{code}+data Page s =+ Page {path :: [String], -- ^ Path to page+ template :: String, -- ^ Page template+ dictionary :: UpdateDict s -- ^ State for page+ }+\end{code}+%%Haddock: Hierarchical site structure+\begin{code}+data TreeSite s =+ TreeSite {page :: Maybe (Page s), -- ^ Parent page+ children :: [TreeSite s] -- ^ Sub-pages+ }+\end{code}++\subsection{Reading a Template}++Templates are read as XML (so you have to use XHTML). This is+necessary because the HaXml parser ``corrects'' HTML --- an important+feature of HaXml, but a problem here because it will discard something+like++\begin{verbatim}+<b hal:text="foo"/>+\end{verbatim}++which is invalid (or at least pointless) HTML, but a valid template.++%%Haddock: Current implementation uses HaXml+\begin{code}+type Template = Document+\end{code}+%%Haddock: Read and parse a template+\begin{code}+readTemplate :: String -> IO Template+readTemplate name = do text <- readFile name+ return $ xmlParse name text+\end{code}++\subsection{Applying Functions}++We visit the elements in the HTML document in pre-order, checking for+attributes with associated namespaces. If an attribute exists, we+evaluate the function and modify the HTML accordingly.++Note that changes to the HTML document are global, but changes to the+context only apply to sub--nodes in the tree. If we use recursive+functions without accumulators then this corresponds to passing both+context and tree as function arguments, but returning only modified+HTML (so returning to a higher level function uses an earlier context,+as expected).++All changes are restricted to sub-trees, so there is no need to+re-evaluate elements. Repeating functions repeat over the initial+context and structure, not over modified structure (but the+sub-structure may itself change each iteration).++%%Haddock: Evaluate the element (and its contents)+\begin{code}+evalElement :: (SubDictionary s, Dictionary f (CustomFn s f)) =>+ Context s f -> Element -> IO Element+evalElement ctx e@(Elem _ _ _) =+ evalAttributes ctx evalContents e []+\end{code}++The function nxt below is a continuation that evaluates the element+contents. In general, when we are evaluating a template, we evaluate+the attributes and then the contents (which is why evalElement above+passes evalContents as the continuation).++\begin{code}+evalAttributes :: (SubDictionary s, Dictionary f (CustomFn s f)) =>+ Context s f -> (Context s f -> Element -> IO Element) -> Element+ -> [Attribute] -> IO Element+evalAttributes ctx nxt (Elem nm [] cn) at =+ nxt ctx $ Elem nm (reverse at) cn+evalAttributes ctx nxt (Elem nm (a@(anm, val):as) cn) at =+ if pth == []+ then evalAttributes ctx nxt (Elem nm as cn) (a:at)+ else case fn of+ Just f ->+ evalFunction ctx nxt (Elem nm as cn) at f $ attVal val+ Nothing ->+ evalAttributes ctx nxt (Elem nm as cn) (a:at)+ where+ fnm@[pth,_] = parseFunction anm+ fn = search (funcs ctx) fnm+\end{code}++No error is flagged if function lookup fails because not all+attributes with namespaces need to be functions (consider the xml+namespace). A future improvement might let the user specify which+namespaces should be associated with functions.++\begin{code}+parseFunction :: Name -> [String]+parseFunction = parseFunction' "" ""++parseFunction' :: String -> String -> String -> [String]+parseFunction' p n "" = [p,n]+parseFunction' "" n (c:s) | c == ':' = parseFunction' n "" s+ | otherwise = parseFunction' "" (n++[c]) s+parseFunction' p n (c:s) = parseFunction' p (n++[c]) s+\end{code}++If a function returns a Repeat constructor (with a ``repeat+function'') then we do the following:++\begin{itemize}++\item create a new element that contains the remaining attributes and+all the content of the current element++\item evaluate the new element and sub-elements (continuation+evalContents) --- this is the ``first iteration''++\item after executing the first iteration, call evalFunction with the+initial element, the repeat function, and the modified context+(continuation skip - we're already managing the contents) --- this+gives the ``remaining iterations''++\item combine the results from the first iteration and the remaining+iterations to give the final result++\end{itemize}++Note the recursion on calling evalFunction, which is terminated by a+return value of Continue. This is not tail recursive, so we may need+to improve things later.++\begin{code}+evalFunction :: (SubDictionary s, Dictionary f (CustomFn s f)) =>+ Context s f -> (Context s f -> Element -> IO Element) -> Element+ -> [Attribute] -> CustomFn s f -> String -> IO Element+evalFunction ctx nxt (Elem nm at cn) at' f val =+ do (ctx', res) <- f ctx val+ case res of+ Attr n v -> evalAttributes ctx' nxt (Elem nm at cn)+ ((n, AttValue [Left v]):at')+ Text p s ->+ case p of+ Before -> evalAttributes ctx' nxt+ (Elem nm at ([CString False s]++cn)) at'+ After -> evalAttributes ctx' nxt+ (Elem nm at (cn++[CString False s])) at'+ Replace -> evalAttributes ctx' nxt+ (Elem nm at [CString False s]) at'+ Xml p e ->+ case p of+ Before -> evalAttributes ctx' nxt+ (Elem nm at ((map CElem e)++cn)) at'+ After -> evalAttributes ctx' nxt+ (Elem nm at (cn++(map CElem e))) at'+ Replace -> evalAttributes ctx' nxt+ (Elem nm at (map CElem e)) at'+ Repeat f' -> loopAttribute ctx' (Elem nm at cn) at' f' val+ Continue -> evalAttributes ctx' nxt (Elem nm at cn) at'+ Skip -> evalAttributes ctx' skip (Elem nm [] []) at'++skip :: Context s f -> Element -> IO Element+skip _ e = do return e++loopAttribute :: (SubDictionary s, Dictionary f (CustomFn s f)) =>+ Context s f -> Element -> [Attribute] -> CustomFn s f -> String+ -> IO Element+loopAttribute ctx e@(Elem nm _ _) at1 f val =+ do (Elem _ at2 cn2) <- evalAttributes ctx evalContents e [] -- first+ (Elem _ at3 cn3) <- evalFunction ctx skip e [] f val -- remain+ return $ Elem nm (joinAtts at1 at2 at3) (cn2++cn3)++revAppend :: [a] -> [a] -> [a]+revAppend base [] = base+revAppend base (x:xs) = revAppend (x:base) xs++joinAtts :: [Attribute] -> [Attribute] -> [Attribute] -> [Attribute]+joinAtts at1 at2 at3 = reverse (revAppend (revAppend at1 at2) at3)++evalContents :: (SubDictionary s, Dictionary f (CustomFn s f)) =>+ Context s f -> Element -> IO Element+evalContents ctx (Elem nm at cn) = do cn' <- mapM (evalContent ctx) cn+ return $ Elem nm at cn'++evalContent :: (SubDictionary s, Dictionary f (CustomFn s f)) =>+ Context s f -> Content -> IO Content+evalContent ctx (CElem e) = do e' <- evalElement ctx e+ return $ CElem e'+evalContent _ c = do return c+\end{code}++\subsection{Driver}++The following code generates HTML from a template.++%%Haddock: Evaluate a complete template+\begin{code}+evalDocument :: (SubDictionary s, Dictionary f (CustomFn s f)) =>+ Context s f -> Document -> IO Document+evalDocument ctx (Document p st elt msc) =+ do elt' <- evalElement ctx elt+ return $ erase $ Document p st elt' msc+\end{code}++\subsection{Removing Elements}++Version 1.0 of Halipeto had some problems generating valid XHTML. In+particular, repetition repeats the contents of an element, but not the+element itself. This is for good reason --- the document's tree+structure is strictly respected so that the scope of any change to the+stae is always clearly defined. However, the usual solution ---+adding an additional div or span element to carry the repeating+attribute --- is not always consistent with the XHTML DTD.++I'm unsure how to handle this. Having "special" functions that don't+respect the document's tree structure sounds confusing. Maybe I need+to introduce a completely different mechanism that involves re-writing+the tree (this would perhaps give a neater solution to the problem I+faced in the Pancito site, where database information was arranged by+row then column, but needed to be displayed by column then row).++For now, I'm going to implement a completely ad--hoc solution. The+attribute hal:erase (unless defined as a function, probably in error)+will be used to indicate that an element should be removed from the+document. The contents of the element are not removed, but included+in the parent element.++I'd appreciate feedback on this. It implies that templates will still+not comply with DTDs, even though the final document will (but then+that has always been possible) --- is this a problem?++\begin{code}+erase :: Document -> Document+erase (Document p st elt msc) = Document p st (eraseChildren elt) msc++eraseChildren :: Element -> Element+eraseChildren (Elem nm at cn) = Elem nm at $ foldl eraseContent [] cn++eraseContent :: [Content] -> Content -> [Content]+eraseContent cn (CElem el) = if hasErase el'+ then cn++cn'+ else cn++[CElem el']+ where+ el'@(Elem _ _ cn') = eraseChildren el+eraseContent cn x = cn++[x]++hasErase :: Element -> Bool+hasErase (Elem _ at _) = any f at+ where+ f ("hal:erase", _) = True+ f _ = False+\end{code}++\subsection{Attribute Values}++HaXml parses attributes as lists of strings and references, which is+nice and correct, but not the simple interface we want for Halipeto.+So these functions, pulled from the pretty printer internals of+HaXml, convert the attribute value to a string before the custom+function is called.++\begin{code}+attVal :: AttValue -> [Char]+attVal (AttValue esr) = concatMap (either id reference) esr++reference :: Reference -> [Char]+reference (RefEntity er) = entityref er+reference (RefChar cr) = charref cr++entityref :: EntityRef -> [Char]+entityref n = "&" ++ show n ++ ";"++charref :: CharRef -> [Char]+charref c = "&" ++ show c ++ ";"+\end{code}+
+ Halipeto/Utilities.lhs view
@@ -0,0 +1,116 @@+% +% Halipeto 2.0 - Haskell static web page generator +% Copyright 2004 Andrew Cooke (andrew@acooke.org) +% Copyright 2007 Peter Simons (simons@cryp.to) +% +% This program is free software; you can redistribute it and/or modify +% it under the terms of the GNU General Public License as published by +% the Free Software Foundation; either version 2 of the License, or +% (at your option) any later version. +% +% This program is distributed in the hope that it will be useful, +% but WITHOUT ANY WARRANTY; without even the implied warranty of +% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +% GNU General Public License for more details. +% +% You should have received a copy of the GNU General Public License +% along with this program; if not, write to the Free Software +% Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +% +% EXCEPT +% +% Files in FromHaxml are from HaXml - http://www.cs.york.ac.uk/HaXml - +% see the COPYRIGHT and LICENSE in that directory. The files included +% are a subset of the full HaXml distribution and have been modified to +% originate from the FromHaxml module (so that install on Win32 is +% easy). +% +\section{Utilities}++Various general routines.++\begin{code}+module Halipeto.Utilities (+ slash, toSlash, fromSlash, toSep, fromSep, dropSpace,+ mapT2, mapT3,+ thenMaybe+) where++import Char+\end{code}++Concatenation of paths and files.++\begin{code}+slash' :: Char+slash' = '/'+\end{code}+%%Haddock: Concatenate two directories+\begin{code}+slash :: String -> String -> String+slash p f = if null f || head f == slash' || null p || last p == slash'+ then p ++ f+ else p ++ [slash'] ++ f+\end{code}+%%Haddock: Convert a list of directories to a file path+\begin{code}+toSlash :: [String] -> FilePath+toSlash = foldl slash ""+\end{code}+%%Haddock: Convert a file path to a list of directories+\begin{code}+fromSlash :: FilePath -> [String]+fromSlash = fromSep slash'+\end{code}++Separation and expansion of strings.++%%Haddock: Join a list with a given separator character+\begin{code}+toSep :: Char -> [String] -> String+toSep _ [] = undefined+toSep _ [s] = s+toSep sep (s:ss) = s ++ [sep] ++ toSep sep ss+\end{code}+%%Haddock: Split a list on a given separator character+\begin{code}+fromSep :: Char -> String -> [String]+fromSep sep s' = uncurry (:) $ foldr f ("", []) s'+ where+ f c (s, l) | c == sep && l == [] && s == "" = ("", l)+ | c == sep = ("", s:l)+ | otherwise = (c:s, l)+\end{code}++Remove space from the start of a string.++%%Haddock: Drop leading spaces+\begin{code}+dropSpace :: String -> String+dropSpace "" = ""+dropSpace (c:s) | isSpace c = dropSpace s+ | otherwise = (c:s)+\end{code}++Maps over uniform tuples.++%%Haddock: Map over a uniform tuple+\begin{code}+mapT2 :: (a -> b) -> (a, a) -> (b, b)+mapT2 f (x1, x2) = (f x1, f x2)+\end{code}+%%Haddock: Map over a uniform triple+\begin{code}+mapT3 :: (a -> b) -> (a, a, a) -> (b, b, b)+mapT3 f (x1, x2, x3) = (f x1, f x2, f x3)+\end{code}++Chain functions that return Maybe.++%%Haddock: Chain Maybe functions+\begin{code}+thenMaybe :: (a -> Maybe b) -> (b -> Maybe c) -> (a -> Maybe c)+thenMaybe f1 f2 a = case f1 a of+ Nothing -> Nothing+ Just a' -> f2 a'+\end{code}
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++> module Main (main) where+>+> import Distribution.Simple+>+> main :: IO ()+> main = defaultMain
+ halipeto.cabal view
@@ -0,0 +1,32 @@+Name: halipeto+Version: 2.1+Copyright: (c) 2004-2010 Peter Simons+License: GPL+License-File: COPYING+Copyright: (c) 2004-2008 Andrew Cooke <andrew@acooke.org>+ (c) 2007-2010 Peter Simons <simons@cryp.to>+Author: Andrew Cooke <andrew@acooke.org>, Peter Simons <simons@cryp.to>+Maintainer: Peter Simons <simons@cryp.to>+Homepage: http://gitorious.org/halipeto+Category: Text+Synopsis: Haskell Static Web Page Generator+Description: A library for generating static HTML pages from XML+ templates and a file-based value dictionary.+Cabal-Version: >= 1.6+Build-Type: Simple+Tested-With: GHC == 6.12.1++Source-Repository head+ Type: git+ Location: git://gitorious.org/halipeto/mainline.git++Library+ Exposed-Modules: Halipeto.Dictionary,+ Halipeto.Functions,+ Halipeto.Pages,+ Halipeto.SimpleDB,+ Halipeto.Template,+ Halipeto.Utilities+ Build-Depends: base >= 2 && < 5, haskell98, HaXml == 1.13.*, directory, pandoc+ Extensions: MultiParamTypeClasses, FlexibleInstances, FlexibleContexts+ Ghc-Options: -Wall