diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -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. + + + Copyright (C) + + 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. + + , 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. + diff --git a/Halipeto/Dictionary.lhs b/Halipeto/Dictionary.lhs new file mode 100644 --- /dev/null +++ b/Halipeto/Dictionary.lhs @@ -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} diff --git a/Halipeto/Functions.lhs b/Halipeto/Functions.lhs new file mode 100644 --- /dev/null +++ b/Halipeto/Functions.lhs @@ -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} + +-> +-> ... + + +-> +-> +\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} + +-> +\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} + +-> value +\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 + +

+ +-> +

a

+

b

+ +\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} +foo -> +\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' = "<" ++ elt ++ ">" + ++ txt ++ "" + 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 world + +-> +

hello

+ world + +\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 world + +-> +

hello world

+ +\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} + diff --git a/Halipeto/Pages.lhs b/Halipeto/Pages.lhs new file mode 100644 --- /dev/null +++ b/Halipeto/Pages.lhs @@ -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} diff --git a/Halipeto/SimpleDB.lhs b/Halipeto/SimpleDB.lhs new file mode 100644 --- /dev/null +++ b/Halipeto/SimpleDB.lhs @@ -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} diff --git a/Halipeto/Template.lhs b/Halipeto/Template.lhs new file mode 100644 --- /dev/null +++ b/Halipeto/Template.lhs @@ -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} + +\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} + diff --git a/Halipeto/Utilities.lhs b/Halipeto/Utilities.lhs new file mode 100644 --- /dev/null +++ b/Halipeto/Utilities.lhs @@ -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} diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runhaskell + +> module Main (main) where +> +> import Distribution.Simple +> +> main :: IO () +> main = defaultMain diff --git a/halipeto.cabal b/halipeto.cabal new file mode 100644 --- /dev/null +++ b/halipeto.cabal @@ -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 + (c) 2007-2010 Peter Simons +Author: Andrew Cooke , Peter Simons +Maintainer: Peter Simons +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