home *** CD-ROM | disk | FTP | other *** search
/ PSION CD 2 / PsionCDVol2.iso / Programs / 876 / hugs.sis (.txt) next >
EPOC Installation Package  |  2000-09-21  |  895KB  |  11,048 lines
  1. RProcess.SISSTDLIB.SIShugs.hlp!:\System\Apps\Hugs\Hugs.hlphugs.app!:\System\Apps\Hugs\Hugs.apphugs.aif!:\System\Apps\Hugs\Hugs.aifbitmaps.mbm!:\System\Apps\Hugs\bitmaps.mbm..\..\..\demos\prolog\stdlib!:\System\Apps\Hugs\Demos\prolog\stdlib..\..\..\demos\prolog\readme!:\System\Apps\Hugs\Demos\prolog\readme..\..\..\demos\prolog\Subst.hs!:\System\Apps\Hugs\Demos\prolog\Subst.hs..\..\..\demos\prolog\StackEngine.hs!:\System\Apps\Hugs\Demos\prolog\StackEngine.hs..\..\..\demos\prolog\PureEngine.hs!:\System\Apps\Hugs\Demos\prolog\PureEngine.hs..\..\..\demos\prolog\Prolog.hs!:\System\Apps\Hugs\Demos\prolog\Prolog.hs..\..\..\demos\prolog\Main.hs!:\System\Apps\Hugs\Demos\prolog\Main.hs..\..\..\demos\prolog\CombParse.hs!:\System\Apps\Hugs\Demos\prolog\CombParse.hs..\..\..\demos\prolog\AndorraEngine.hs!:\System\Apps\Hugs\Demos\prolog\AndorraEngine.hs..\..\..\demos\Tree.hs!:\System\Apps\Hugs\Demos\Tree.hs..\..\..\demos\Stack.hs!:\System\Apps\Hugs\Demos\Stack.hs..\..\..\demos\Say.hs!:\System\Apps\Hugs\Demos\Say.hs..\..\..\demos\Queens.hs!:\System\Apps\Hugs\Demos\Queens.hs..\..\..\demos\Minsrand.hs!:\System\Apps\Hugs\Demos\Minsrand.hs..\..\..\demos\Mersenne.hs!:\System\Apps\Hugs\Demos\Mersenne.hs..\..\..\demos\Matrix.hs!:\System\Apps\Hugs\Demos\Matrix.hs..\..\..\demos\Literate.lhs!:\System\Apps\Hugs\Demos\Literate.lhs..\..\..\demos\Ldfs.hs!:\System\Apps\Hugs\Demos\Ldfs.hs..\..\..\demos\Lattice.hs!:\System\Apps\Hugs\Demos\Lattice.hs..\..\..\demos\Gofer.hs!:\System\Apps\Hugs\Demos\Gofer.hs..\..\..\demos\FastSort.hs!:\System\Apps\Hugs\Demos\FastSort.hs..\..\..\demos\Expr.hs!:\System\Apps\Hugs\Demos\Expr.hs..\..\..\demos\Examples.hs!:\System\Apps\Hugs\Demos\Examples.hs..\..\..\demos\EvalRed.hs!:\System\Apps\Hugs\Demos\EvalRed.hs..\..\..\demos\Eliza.hs!:\System\Apps\Hugs\Demos\Eliza.hs..\..\..\demos\Demos.hs!:\System\Apps\Hugs\Demos\Demos.hs..\..\..\demos\CommaInt.lhs!:\System\Apps\Hugs\Demos\CommaInt.lhs..\..\..\demos\Calendar.hs!:\System\Apps\Hugs\Demos\Calendar.hs..\..\..\demos\ArrayEx.hs!:\System\Apps\Hugs\Demos\ArrayEx.hs..\..\..\demos\AnsiDemo.hs!:\System\Apps\Hugs\Demos\AnsiDemo.hs..\..\..\lib\hugs\Trex.hs!:\System\Apps\Hugs\Lib\hugs\Trex.hs..\..\..\lib\hugs\Trace.hs!:\System\Apps\Hugs\Lib\hugs\Trace.hs..\..\..\lib\hugs\StdLibs.hs!:\System\Apps\Hugs\Lib\hugs\StdLibs.hs..\..\..\lib\hugs\Sequence.hs!:\System\Apps\Hugs\Lib\hugs\Sequence.hs..\..\..\lib\hugs\ParseLib.hs!:\System\Apps\Hugs\Lib\hugs\ParseLib.hs..\..\..\lib\hugs\OldWeak.hs!:\System\Apps\Hugs\Lib\hugs\OldWeak.hs..\..\..\lib\hugs\Number.hs!:\System\Apps\Hugs\Lib\hugs\Number.hs..\..\..\lib\hugs\ListUtils.hs!:\System\Apps\Hugs\Lib\hugs\ListUtils.hs..\..\..\lib\hugs\IOExtensions.hs!:\System\Apps\Hugs\Lib\hugs\IOExtensions.hs..\..\..\lib\hugs\Interact.hs!:\System\Apps\Hugs\Lib\hugs\Interact.hs..\..\..\lib\hugs\HugsLibs.hs!:\System\Apps\Hugs\Lib\hugs\HugsLibs.hs..\..\..\lib\hugs\HugsInternals.hs!:\System\Apps\Hugs\Lib\hugs\HugsInternals.hs..\..\..\lib\hugs\HugsDynamic.hs!:\System\Apps\Hugs\Lib\hugs\HugsDynamic.hs..\..\..\lib\hugs\GenericPrint.hs!:\System\Apps\Hugs\Lib\hugs\GenericPrint.hs..\..\..\lib\hugs\CVHAssert.hs!:\System\Apps\Hugs\Lib\hugs\CVHAssert.hs..\..\..\lib\hugs\AnsiScreen.hs!:\System\Apps\Hugs\Lib\hugs\AnsiScreen.hs..\..\..\lib\hugs\AnsiInteract.hs!:\System\Apps\Hugs\Lib\hugs\AnsiInteract.hs..\..\..\lib\exts\Word.hs!:\System\Apps\Hugs\Lib\exts\Word.hs..\..\..\lib\exts\Weak.hs!:\System\Apps\Hugs\Lib\exts\Weak.hs..\..\..\lib\exts\Stable.hs!:\System\Apps\Hugs\Lib\exts\Stable.hs..\..\..\lib\exts\ST.hs!:\System\Apps\Hugs\Lib\exts\ST.hs..\..\..\lib\exts\Semaphore.lhs!:\System\Apps\Hugs\Lib\exts\Semaphore.lhs..\..\..\lib\exts\SampleVar.lhs!:\System\Apps\Hugs\Lib\exts\SampleVar.lhs..\..\..\lib\exts\Pretty.lhs!:\System\Apps\Hugs\Lib\exts\Pretty.lhs..\..\..\lib\exts\NumExts.hs!:\System\Apps\Hugs\Lib\exts\NumExts.hs..\..\..\lib\exts\Memo.hs!:\System\Apps\Hugs\Lib\exts\Memo.hs..\..\..\lib\exts\LazyST.hs!:\System\Apps\Hugs\Lib\exts\LazyST.hs..\..\..\lib\exts\IOExts.hs!:\System\Apps\Hugs\Lib\exts\IOExts.hs..\..\..\lib\exts\Int.hs!:\System\Apps\Hugs\Lib\exts\Int.hs..\..\..\lib\exts\GetOpt.lhs!:\System\Apps\Hugs\Lib\exts\Getopt.lhs..\..\..\lib\exts\Foreign.hs!:\System\Apps\Hugs\Lib\exts\Foreign.hs..\..\..\lib\exts\Dynamic.lhs!:\System\Apps\Hugs\Lib\exts\Dynamic.lhs..\..\..\lib\exts\Concurrent.lhs!:\System\Apps\Hugs\Lib\exts\Concurrent.lhs..\..\..\lib\exts\ConcBase.hs!:\System\Apps\Hugs\Lib\exts\ConcBase.hs..\..\..\lib\exts\ChannelVar.lhs!:\System\Apps\Hugs\Lib\exts\ChannelVar.lhs..\..\..\lib\exts\Channel.lhs!:\System\Apps\Hugs\Lib\exts\Channel.lhs..\..\..\lib\exts\Bits.hs!:\System\Apps\Hugs\Lib\exts\Bits.hs..\..\..\lib\exts\Addr.hs!:\System\Apps\Hugs\Lib\exts\Addr.hs..\..\..\lib\System.hs!:\System\Apps\Hugs\Lib\System.hs..\..\..\lib\Ratio.hs!:\System\Apps\Hugs\Lib\Ratio.hs..\..\..\lib\Random.hs!:\System\Apps\Hugs\Lib\Random.hs..\..\..\lib\Prelude.hs!:\System\Apps\Hugs\Lib\Prelude.hs..\..\..\lib\Numeric.hs!:\System\Apps\Hugs\Lib\Numeric.hs..\..\..\lib\Monad.hs!:\System\Apps\Hugs\Lib\Monad.hs..\..\..\lib\Maybe.hs!:\System\Apps\Hugs\Lib\Maybe.hs..\..\..\lib\Locale.lhs!:\System\Apps\Hugs\Lib\Locale.lhs..\..\..\lib\List.hs!:\System\Apps\Hugs\Lib\List.hs..\..\..\lib\Ix.hs!:\System\Apps\Hugs\Lib\Ix.hs..\..\..\lib\IO.hs!:\System\Apps\Hugs\Lib\IO.hs..\..\..\lib\Complex.hs!:\System\Apps\Hugs\Lib\Complex.hs..\..\..\lib\Char.hs!:\System\Apps\Hugs\Lib\Char.hs..\..\..\lib\Array.hs!:\System\Apps\Hugs\Lib\Array.hs\epoc32\release\marm\rel\hugs.exe!:\system\apps\hugs\hugs.exeHugs February 2000
  2. RPRocess.oxh!:\System\OPL\RProcess.oxh\epoc32\release\marm\rel\RPRocess.opx!:\System\OPX\RPRocess.opxRPRocess OPX7
  3. REM RProcess.OXH Version 1.0
  4. REM Header file for RPRocess.OPX
  5. CONST KOpxRProcessUid&=&100094A2
  6. CONST KOpxRPRocessVersion%=$100
  7. REM --------------------------------------------- Methods
  8. DECLARE OPX RPRocess,KOpxRProcessUid&,KOpxRPRocessVersion%
  9.     ProcessOPXVersion%:() : 1
  10.     ProcessNewProcess&:() : 2
  11.     ProcessDeleteProcess:(BYREF this&) : 3
  12.     ProcessCreate%:(this&, command$, arg$) : 4
  13.     ProcessOpenName%:(this&, name$) : 5
  14.     ProcessOpenFind%:(this&, find$, skip%) : 6
  15.     ProcessRename%:(this&, name$) : 7
  16.     ProcessPriority&:(this&) : 8
  17.     ProcessSetPriority&:(this&, prio&) : 9
  18.     ProcessResume:(this&) : 10
  19.     ProcessKill:(this&, reason&) : 11
  20.     ProcessPanic:(this&, category$, reason&) : 12
  21.     ProcessExitType%:(this&) : 13
  22.     ProcessExitReason%:(this&) : 14
  23.     ProcessUIDType:(this&, BYREF UID1&, BYREF UID2&, BYREF UID3&) : 15
  24.     ProcessFileName$:(this&) : 16
  25.     ProcessCommandLine$:(this&) : 17
  26.     ProcessGetRamSizes:(this&, BYREF CodeSize&, BYREF ConstDataSize&, BYREF InitializedDataSize&, BYREF UninitializedDataSize&) : 18
  27.     ProcessLoadedFromRam%:(this&) : 19
  28.     ProcessProtected%:(this&) : 20
  29.     ProcessOwner%:(this&, BYREF that&) : 21
  30.     ProcessSetUIDType:(this&, UID1&, UID2&, UID3&) : 22
  31.     ProcessSetProtected:(this&, prot%) : 23
  32.     ProcessSetOwner:(this&, that&) : 24
  33. END DECLARE
  34. *TextEd.app
  35. OPLR[10000077].DLL
  36. EUSER[100000c1].DLL
  37. 000D0T0`0l0x0
  38. ;(;4;@;L;X;d;p;|;
  39. <$<0<<<H<T<`<l<x<
  40. = =,=8=D=P=\=h=t=
  41. ESTLIB.DLL!:\System\Libs\ESTLIB.dllStandard C Libraryy
  42. j3EPOC
  43. yhC@A.
  44. =v<y5
  45. v<y5G
  46. ESTLIB-INIT
  47. T_DLL OOM
  48. /System/temp/
  49. ESTLIB-INIT
  50. FFFF86
  51. Posix-%d
  52. Starting CPosixServer
  53. estlib
  54. Posix server
  55. Posix-*
  56. Are you my mother, %S?
  57. Found parent process %S
  58. I've become an orphan
  59. Posix-%d is a top-level process
  60. POpen3 created process %d
  61. Process %d asks am I its mother?
  62. Found child process
  63. Process %d is requesting its inheritance
  64. Process %d appears to have terminated with status %d
  65. POSIXIF (%d)
  66. %F%*E %*N %D %H:%T:%S %Y
  67. Error
  68. STDOUT
  69. ESTLIB Console
  70. Console closed - press any key
  71. estlib
  72. CPipeDesc
  73. %d.%d.%d.%d
  74. assertion "%s" failed: file "%s", line %d
  75. error %d
  76. =v<y5G
  77. Not owner
  78. No such file or directory
  79. No such process
  80. Interrupted system call
  81. I/O error
  82. No such device or address
  83. Arg list too long
  84. Exec format error
  85. Bad file number
  86. No children
  87. No more processes
  88. Not enough space
  89. Permission denied
  90. Bad address
  91. Block device required
  92. Device or resource busy
  93. File exists
  94. Cross-device link
  95. No such device
  96. Not a directory
  97. Is a directory
  98. Invalid argument
  99. Too many open files in system
  100. Too many open files
  101. Not a character device
  102. Text file busy
  103. File too large
  104. No space left on device
  105. Illegal seek
  106. Read-only file system
  107. Too many links
  108. Broken pipe
  109. Math argument
  110. Result too large
  111. No message of desired type
  112. Identifier removed
  113. Deadlock
  114. No lock
  115. Not a socket
  116. Remote address not available
  117. Address not supported by protocol
  118. Socket already connected
  119. Connection refused by remote host
  120. Address already in use
  121. Connection timed out
  122. Not a stream
  123. Stream ioctl timeout
  124. No stream resources
  125. Machine is not on the network
  126. No package
  127. Resource is remote
  128. Virtual circuit is gone
  129. Advertise error
  130. Srmount error
  131. Communication error
  132. Protocol error
  133. Multihop attempted
  134. Bad message
  135. Cannot access a needed shared library
  136. Accessing a corrupted shared library
  137. .lib section in a.out corrupted
  138. Attempting to link in more shared libraries than system limit
  139. Cannot exec a shared library directly
  140. Function not implemented
  141. No more files
  142. Directory not empty
  143. File or path name too long
  144. Saturday
  145. Friday
  146. Thursday
  147. Wednesday
  148. Tuesday
  149. Monday
  150. Sunday
  151. December
  152. November
  153. October
  154. September
  155. August
  156. April
  157. March
  158. February
  159. January
  160.  %.2d %2.2d:%2.2d:%2.2d %.4d
  161. %2.2d
  162. %1.1d
  163.  %.2d %.4d
  164. %2.2d:%2.2d:%2.2d
  165. /System/temp/t%x.%x
  166.                 0000000000000000
  167. 0123456789abcdef
  168. (null)
  169. 0123456789ABCDEF
  170. bug in vfprintf: bad base
  171. ESOCK[10000047].DLL
  172. efsrv[100000bd].dll
  173. euser[100000c1].dll
  174. 000D0T0`0l0x0
  175. = =$=(=,=0=4=8=<=@=D=H=L=P=T=X=\=`=d=h=l=p=t=x=|=
  176. 4p6`7<8
  177. >X?\?`?d?h?l?p?t?x?|?
  178. X5\5`5d5h5l5p5t5x5
  179. :`;d;
  180. = =$=(=,=0=4=,>`>
  181. 2H3L3P3
  182. 1H4\4l4
  183. 2\4`4d4h4l4@5
  184. 0P2T2X2\2
  185. 4 5d6h688
  186. l1p1t1x1|1
  187. 2 2$2(2,2024282<2@2D2H2L2P2T2X2\2`2d2h2l2p2t2x2|2
  188. 5 5$5(5,5054585<5@5D5H5L5P5T5X5\5`5d5h5l5p5t5x5|5
  189. 7 7$7(7,7074787<7@7D7H7L7P7T7X7\7`7d7h7l7p7t7x7|7
  190. :\<`<d<h<l<p<t<x<
  191. 8 8$8(8,8084888<8@8D8H8L8P8T8X8\8`8d8h8l8p8t8x8|8
  192. 5 5$5(5,5054585<5@5D5H5L5P5T5X5\5`5d5h5l5p5t5x5|5
  193. 6 6$6(6,6064686<6@6D6H6L6P6T6X6\6`6d6h6l6p6t6
  194. < <$<(<,<0<4<8<<<@<D<H<L<P<T<X<\<`<d<h<l<p<t<x<|<
  195. = =$=(=\?`?d?h?l?p?t?x?|?
  196. 0 0$0(0,0004080<0@0D0
  197. 1X4d4p4|4
  198. 5$505<5H5T5`5l5x5
  199. 6 6,686D6P6\6h6t6
  200. 7(747@7L7X7d7p7|7
  201. 8$808<8H8T8`8l8x8
  202. 9 9,989D9P9\9h9t9
  203. :(:4:@:L:X:d:p:|:
  204. ;$;0;<;H;T;`;l;x;
  205. < <,<8<D<P<\<h<t<
  206. =(=4=@=L=X=d=p=|=
  207. >$>0><>H>T>`>l>x>
  208. ? ?,?8?D?P?\?h?t?
  209. 0(040@0L0X0d0p0|0
  210. 1$101<1H1T1`1l1x1
  211. 2D:H:L:P:T:X:\:`:d:h:
  212. $1(1,1014181<1
  213. 4(44484<4@4D4H4L4P4T4X4\4`4d4h4l4p4t4x4|4
  214. 5 5$5(5,5054585<5@5D5H5L5P5T5X5\5`5d5h5l5p5t5x5
  215. 6$6(6,6064686<6@6D6H6L6P6T6X6\6`6d6h6l6p6t6x6|6
  216. 7 7$7(7,7074787<7@7D7H7L7P7T7X7\7`7d7h7l7p7|7
  217. 8 8$8(848@8D8P8T8X8\8`8d8h8l8p8t8x8|8
  218. 9 9$9(9,9094989<9@9D9H9L9P9T9X9\9`9d9p9t9x9|9
  219. Table1
  220. ColA1
  221. ColB1
  222. ColA2
  223. ColB2
  224. ColA3
  225. ColB3
  226. ColA4
  227. ColB4
  228. "DATA.APP
  229. HBWelcome to the Epoc port of Hugs98, an interpreter for the pure functional programming language Haskell
  230. This is something of a bare-bones port of Hugs that provides only the basic interpreter functionality; there is no special code to support Epoc functionality. This means that you can run Haskell programs that use the standard libraries supported by Hugs but not those that require special support (such as GUI programs). This is much the same as hugs on console platforms such as DOS or Unix without X11 (but see the bugs section of this document for some important differences)
  231. .CThis version of Hugs comes with a small application that appears on
  232. the extras bar and can be used to launch the main interpreter. This
  233. application allows you to set any of the options that can be set on
  234. the command line. These settings are stored in small files that can be
  235. used to store different Hugs configurations for each Haskell program
  236. you work on.
  237. The options for the hugs interpreter can be set via the menus of the launcher application and are discussed in detail in the next section.
  238. If you're the kind of person who would rather run the interpreter manually then you will need the command line environment for Epoc (available from the downloads section of the Symbian website, http://www.symbian.com/). You can run the interpreter as \System\Apps\Hugs\Hugs.exe on the drive you installed it to.
  239. DThe launcher application provides a number of menus that allow you to configure how the Hugs interpreter will be run. Most of these options are simple on-off toggles. Each option corresponds to a single command line argument to the Hugs interpreter. Some of the options will prompt for a value. Note that there is currently a limit of 255 characters in the command line arguments, and so some of the options (such as the path the the libraries and the main module) have had to be artificially shortened.
  240. File Menu    This menu allows you to run the Hugs interpreter, select the file used to store the configuration information and exit the launcher application.
  241. Stats menu    This menu allows you to select the kinds of informational messages Hugs prints about itself and your programs
  242. Errors menu    This menu allows you to select how Hugs behaves when it encounters errors
  243. Literacy    This menu allows you select how Hugs deals with literate programs
  244. General    This menu allows you set the Hugs options that are not covered by some more specific menu
  245. Options    This menu allows you to set the Hugs options that are not simple toggles.
  246. Help    This menu allows you to display information about this port of Hugs
  247. %CIn general using hte interpreter is similar to using Hugs on any other platform. There are only a few differences:
  248. Input editing is rudementary (at best) and is described in it's own section, below.
  249. The console has no scrollback, so when more than a screenful of data is displayed there is no way to recover it. The output of the ":h" command is reproduced below for reference purposes because of this.
  250. If you switch away from the interpreter then you will find it on the task list as "STDOUT" (it's not listed as "Hugs" - that's the launcher app). The reason for this name is arcane and has to do with the way Epoc supports console applications).
  251. The interrupt character (Control-C on may systems) is not supported in any way. In general this is not a serious problem, but see the Known Bugs section.
  252. FThe console provided by the Epoc libc is rather basic, so I have supplied a very simple sort of line editing to make the interpreter more usable. The editor has basic backspace handling and a simple command line history. The history is accessed by pressing the ESC key which will put Hugs into edit mode. The hugs prompt will change to "EDIT>" to indicate that normal keyboard input is suspended and instead the following keys are active:
  253. Esc    Print the history buffer. This will display the last ten lines typed to Hugs
  254. Any digit    Pressing a digit will select that element of the history buffer and copy it into the current command
  255. Space    Pressing the space bar will select the most recent line (this is usually history item number 9)
  256. q    Pressing q will quit out of edit mode and will revert the current line to whatever it was when edit mode was entered.
  257. h, l    Pressing h and l will move the current cursor position left or right one character.
  258. j, k    Pressing j and k will select the next and previous lines of the history
  259. ^, $    Pressing Caret or Dollar will move the cursor to the start or the end of the current line
  260. D    Pressing a capital D will delete everything from the current position to the end of the line
  261. r    Pressing r will allow you to replace the character currently under the cursor. If you press escape the replacement will be cancelled, otherwise the next character you type will take the place of the one under the cursor.
  262. This list of editing commands is hardly ideal, but it is enough to allow previous commands to be recalled and corrections to be made without having to retype the entire line. The choice of commands may seem a little odd if you are not in the know: many of these keystrokes are based on those in the vi editor.
  263. DShould you encounter a problem with this version of hugs the first thing to do is report it to me, ideally by sending email to Glenn.Strong@cs.tcd.ie. Despite what the Hugs startup banner says you should not report bugs directly to the hugs team. They are not responsible for this port and they probably wouldn't appreciate being bothered by bugs in a package they do not distribute. The most likely source of bugs is me breaking something during the porting process.
  264. It may be worth checking whether there is an updated release that solves your problem. Currently the latest version will be available on the WWW at the URL http://www.cs.tcd.ie/Glenn.Strong/epoc/hugs.html
  265. To help sort out your problem it would be best if you could give me as much information as possible, including the version of the port you have (check the About: dialog box of the launcher if you are not sure what version you are using), your machine type (e.g. Psion series 5) and a description of the problem (of course). I can't make any promises about fixing the problem, but I will certainly try. See the Known Bugs section for cases where I have tried and failed (or just not tried).
  266. BHugs is 
  267.  1994-99 Mark P Jones, Alastair Reid, the Yale Haskell Group, and the Oregon Graduate Institute of Science and Technology, 1994-1999, All rights reserved, and is distributed as free software under the terms of the license described in the LICENSE section of this document.
  268. The original source for Hugs98 is available from http://www.haskell.org/hugs
  269. This port by Glenn Strong <Glenn.Strong@cs.tcd.ie> is available from http://www.cs.tcd.ie/Glenn.Strong/epoc/
  270. I extended Keith Walker's CE32Base OPX to write the launcher application.
  271. Thanks to everyone who helped (and continue to help) beta test this application. Without your feedback this application probably wouldn't run on any machine but my own.
  272. I have had reports that the application doesn't work at all for some Revo users, claiming to be unable to find the libraries. I have been unable to reproduce the problem on a colleagues revo, and any more information would be appreciated. Apparently using an older version of the port (1.05, for instance) cures this, although it also removes the benefits of the later versions.
  273. The interrupt caracter (Control-C  on many systems) is not supported. This is more serious than it first appears, as you will find out if you enter "[1..]" at the interpreter prompt. The only thing you can do if the interpreter is caught in an infinte evaluation is shut down the interpreter from outside. While the system button doesn't work when the interpreter is evaluating (it isn't paying attention to input in the right way) you can still press Control-System to get a task list and then close the process called "STDOUT". In an emergency you can use the key Control-Fn-K which should kill the foreground process. This is something of a last resort, of course. The interrupt key is not supported (basically) because the Epoc standard library does not currently support signals. Hopefully, this bug is probably not too big a problem since people have a tendancy not to try to print infinte lists...
  274. Tab characters interact badly with backspace in the edit routines. At the interpreter prompt you can enter and leave edit mode to get the line to redisplay correctly. The problem is that the EPOC console I'm using doesn't support a proper backspace character, so I fake it by overprinting spaces, which doesn't work for tabs which display as more than one character.
  275. 1999/07/08: Version 1.00: Initial release (labelled Alpha)
  276. 1999/07/13: Version 1.01: Fixed a bug in the input routines related to lines over forty characters.
  277. 1999/07/20: Version 1.02: Fixed a bug in the getch() routine to allow Haskell programs to handle backspace better.
  278. 1999/07/30: Version 1.03: Completely rewrote the input routines to allow basic command line editing. Added "Pwd" command.
  279. 1999/08/07: Version 1.04: Fixed a couple of minor cosmetic bugs in line editing.
  280. 1999/11/02: Version 1.05: Updated to September 1999 Hugs, a new release of the core Hugs distribution. Minor documentation and code updates.
  281. 2000/03/05: Version 1.06: Updated to February 2000 Hugs. I also took the opportunity to make a few small changes to the input routines. The February 2000 release of Hugs fixes the following problems (text from the original hugs documentation):
  282. If you defined an instance which inherited a method via a superclass, hugs would go into an infinite loop.  Fortunately, most people weren't doing this (except Chris Okasaki...).
  283. There were a couple of holes in the implementation of implicit parameters (`with' wasn't always being scoped properly, sometimes capturing implicit parameters outside of its scope).
  284. Functional dependancies weren't being properly propogated in some cases with derived instances (`instance P ... => Q ...').
  285. 2000/09/22: Version 1.07: Included a new front end application to launch Hugs so that EShell is not required.
  286. The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
  287. Yale Haskell Group, and the Oregon Graduate Institute of Science and
  288. Technology, 1994-1999, All rights reserved, and is distributed as free
  289. software under the following license.
  290. Redistribution and use in source and binary forms, with or without
  291. modification, are permitted provided that the following conditions
  292. are met:
  293. - Redistributions of source code must retain the above copyright notice,
  294. this list of conditions and the following disclaimer.
  295. - Redistributions in binary form must reproduce the above copyright
  296. notice, this list of conditions and the following disclaimer in the
  297. documentation and/or other materials provided with the distribution.
  298. - Neither name of the copyright holders nor the names of its
  299. contributors may be used to endorse or promote products derived from
  300. this software without specific prior written permission.
  301. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS
  302. "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  303. LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
  304. A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
  305. HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
  306. INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
  307. BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
  308. OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
  309. ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
  310. TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
  311. USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  312. IntroductionR
  313. Hugs!
  314. Running HugsR
  315. Hugs!
  316. Menus and OptionsR
  317. Hugs!
  318. Using the InterpreterR
  319. Hugs!
  320. Input EditingR
  321. Hugs!
  322. The Hugs InterpreterR
  323. THIS SECTION MUST BE ADDED BY HAND (ALEPPO CAN'T HANDLE THE SPECIAL FONT REQUIREMENTS)
  324. Hugs!
  325. Reporting ProblemsR
  326. Hugs!
  327. Copyrights and CreditsR
  328. Hugs!
  329. Known BugsR
  330. Hugs!
  331. Version HistoryR
  332. Hugs!
  333. LicenseR
  334. Hugs!
  335. Table1
  336. title
  337. synonym
  338. The Hugs interpreter supports a number of commands at the prompt - a list may be obtained by typing ":?" to the hugs prompt. I have added one command to this list:
  339.     :Pwd    Print current directory (note the capital P to avoid a clash with the :project command).
  340. Although the commands can be listed using :?, the Epoc console usually does not have enough lines to display all of them. Note that not all of the commands work in this port - the :edit commands, for instance, do
  341.  nothing. The output of :? is reproduced here for ease of reference:
  342. Prelude> :?
  343. LIST OF COMMANDS:  Any command may be abbreviated to :c where
  344. c is the first character in the full name.
  345. :load <filenames>   load modules from specified files
  346. :load               clear all files except prelude
  347. :also <filenames>   read additional modules
  348. :reload             repeat last load command
  349. :project <filename> use project file
  350. :edit <filename>    edit file
  351. :edit               edit last module
  352. :module <module>    set module for evaluating expressions
  353. <expr>              evaluate expression
  354. :type <expr>        print type of expression
  355. :?                  display this list of commands
  356. :set <options>      set command line options
  357. :set                help on command line options
  358. :names [pat]        list names currently in scope
  359. :info <names>       describe named objects
  360. :browse <modules>   browse names defined in <modules>
  361. :xplain <context>   explain instance resolution for <context>
  362. :find <name>        edit module containing definition of name
  363. :!command           shell escape
  364. :cd dir             change directory
  365. :Pwd                print working directory
  366. :gc                 force garbage collection
  367. :quit               exit Hugs interpreter
  368. Prelude>
  369. There are two sets of things you can set with :set. The first are toggles (use a leading "-" to deactivate or a leading "+" to activate):
  370. s    Print no. reductions/cells after eval
  371. t    Print type after evaluation
  372. f    Terminate evaluation on first error
  373. g    Print no. cells recovered after gc
  374. l    Literate modules as default
  375. e    Warn about errors in literate modules
  376. .    Print dots to show progress
  377. q    Print nothing to show progress
  378. w    Always show which modules are loaded
  379. k    Show kind errors in full
  380. o    Allow overlapping instances
  381. u    use "show" to display results
  382. i    Chase imports while loading modus
  383. x    Explain instance resolution
  384. m    Use multi instance resolution
  385. 98    Set Haskell 98 compatibility
  386. Then there are the other options. A leading + or - makes no difference to these
  387. hnum    Set heap size (cannot be changed within Hugs)
  388. pstr    Set prompt string to str
  389. rstr    Set repeat last expression string to str
  390. Pstr    Set search path for modules to str
  391. Estr    Use editor setting given by str
  392. cnum    Set constraint cutoff limit
  393. dnum    Gather profiling statistics every <num> reductions
  394. Courier New
  395. Courier New
  396. Arial
  397. Times New Roman
  398. Courier New
  399. Times New Roman
  400. Arial
  401. Arial
  402. Times New Roman
  403. Arial
  404. Times New Roman
  405. Arial
  406. Times New Roman
  407. Courier New
  408. IntroductionR
  409. Hugs!
  410. Running HugsR
  411. Hugs!
  412. Menus and OptionsR
  413. Hugs!
  414. Using the InterpreterR
  415. Hugs!
  416. Input EditingR
  417. Hugs!
  418. The Hugs InterpreterR
  419. Hugs!
  420. Reporting ProblemsR
  421. Hugs!
  422. Copyrights and CreditsR
  423. Hugs!
  424. Known BugsR
  425. Hugs!
  426. Version HistoryR
  427. Hugs!
  428. LicenseR
  429. Hugs!
  430. C:\Programs\Frontends\Hugs.pre
  431. TBARLINK
  432. Z:\System\Opl\Toolbar.opo
  433. MainLoopO
  434. TOGGLES%
  435. TOGGLENAMES$
  436. TOGGLEKEYS%
  437. TOGGLECMD$
  438. NUMOPTS&
  439. NUMOPTNAMES$
  440. NUMOPTKEYS%
  441. NUMOPTCMD$
  442. NUMOPTMIN&
  443. NUMOPTMAX&
  444. STROPTS$
  445. STROPTLEN%
  446. STROPTNAMES$
  447. STROPTKEYS%
  448. STROPTCMD$
  449. DOCUMENTNAME$
  450. LASTUSEDFILE$
  451. DONE%
  452.     PROGNAME$
  453.     HELPFILE$
  454. HELPTHREAD&
  455. INITIALIZE
  456. LOADINI
  457. TBARINIT
  458. TBARBUTT
  459. SYSTEMEVENT
  460. TBARSHOW
  461. TBAROFFER%
  462.     SETUPMENU
  463.     SETNUMOPT
  464.     SETSTROPT
  465. SETMAINMODULE
  466. RUNHUGS
  467. OPENFILE
  468. NEWFILE
  469. CMDSL%
  470. SAVEOPTIONS
  471. SAVEINI
  472. TBWIDTH%
  473. :\System\Apps\Hugs\Hugs.exeK
  474. :\System\Apps\Hugs\Hugs.hlpK
  475. :\system\apps\hugs\bitmaps.mbmK
  476. Run HugsO
  477. +    Heap SizeO
  478. ModuleO
  479. HelpO
  480. gO    gP    O
  481. '{A`[{
  482. +    Open File
  483. File,Folder,DiskO
  484. Cancel(
  485. +    Open File
  486. File,Folder,DiskO
  487. Cancel(
  488. About...
  489. Hugs launcher+
  490.  2000
  491. +"http:\\www.cs.tcd.ie\Glenn.Strong\
  492. Glenn.Strong@cs.tcd.ie
  493. Version O
  494. TOGGLES%
  495. TOGGLENAMES$
  496. TOGGLEKEYS%
  497. TOGGLECMD$
  498. NUMOPTS&
  499. NUMOPTNAMES$
  500. NUMOPTKEYS%
  501. NUMOPTCMD$
  502. NUMOPTMIN&
  503. NUMOPTMAX&
  504. STROPTS$
  505. STROPTNAMES$
  506. STROPTKEYS%
  507. STROPTCMD$
  508. STROPTLEN%
  509. Print Reductions
  510. Print Type
  511. Stop on First Error
  512. Trace Garbage Collections
  513. Literate modules by default
  514. Warn about literate errors
  515. Print dots for progress
  516. Print nothing for progress
  517. Show loaded modules
  518. Show kind errors in full
  519. Use show for results
  520. Chase Imports
  521. Explain instance resolution
  522. Haskell 98
  523. +    Heap size
  524. Constraint cutoff
  525. Prompt
  526. Repeat string
  527. +*{Hugs}\lib;{Hugs}\lib\hugs;{Hugs}\lib\exts
  528. Main module
  529. Too many keyless options!+
  530. Bug in initialize!W8
  531.     MENUBOOL%
  532. TOGGLENAMES$
  533. TOGGLEKEYS%
  534. TOGGLES%
  535. NUMOPTNAMES$
  536. NUMOPTKEYS%
  537. STROPTNAMES$
  538. STROPTKEYS%
  539. File+
  540. Run HugsOR+
  541. Create new file...On+
  542. Open file...Oo+
  543. CloseOe
  544. StatsO
  545. ErrorsO
  546. LiteracyO
  547. GeneralO
  548. g" g# g$ +
  549. OptionsO
  550. Help+
  551. HelpOh+
  552. About...Oa
  553. ONFLAGS$
  554.     OFFFLAGS$
  555. OTHERFLAGS$
  556. TOGGLES%
  557. TOGGLECMD$
  558. TOGGLES%
  559. TOGGLECMD$
  560. NUMOPTCMD$
  561. NUMOPTS&
  562. TOGGLES%
  563. TOGGLECMD$
  564. STROPTS$
  565. STROPTCMD$
  566. g+$g,$
  567. gZ$g\$g]$
  568. GETOPTIONS$
  569.     PROGNAME$
  570. DONE%
  571. Problem!+
  572. Can't run Hugs+
  573. Errorcode 
  574. STROPTS$
  575. Set main module
  576. File,Folder,DiskO
  577. Cancel(
  578. No FileOn+
  579. NEWFILE
  580. OPENFILE
  581. RESUMEFILE
  582. DONE%
  583. SAVEOPTIONS
  584. TOOLBARSETTITLE
  585. DOCUMENTNAME$
  586. LASTUSEDFILE$
  587. TOOLBARSETTITLE
  588. LOADOPTIONS
  589. DOCUMENTNAME$
  590. LASTUSEDFILE$
  591. OPENFILE
  592. NEWFILE
  593. LASTUSEDFILE$
  594. go*gp*
  595. TBARSETTITLE
  596. DOCUMENTNAME$
  597. TOGGLES%
  598. NUMOPTS&
  599. STROPTS$
  600. ,+    Saving...
  601. TOGGLES%
  602. NUMOPTS&
  603. STROPTS$
  604. LOADING...
  605. LASTUSEDFILE$
  606. c:\system\apps\hugs\hugs.iniO
  607. C:\System\Apps\HugsW
  608. C:\System\Apps\Hugs
  609. 0vg)0+
  610. Loading...
  611. LASTUSEDFILE$
  612. c:\system\apps\hugs\hugs.iniO
  613. gO1+    Saving...
  614. RUNHUGS
  615.     SETNUMOPT
  616. SETMAINMODULE
  617. HELPTHREAD&
  618.     HELPFILE$
  619. NUMOPTNAMES$
  620. NUMOPTS&
  621. NUMOPTMIN&
  622. NUMOPTMAX&
  623. Cancel(
  624. gN4W7
  625. STROPTS$
  626. STROPTLEN%
  627. STROPTNAMES$
  628. CancelO
  629. 5W7['
  630. MAIN3
  631. MAINLOOP
  632. INITIALIZE[    
  633.     SETUPMENU
  634. GETOPTIONS$
  635. ONFLAGS$
  636.     OFFFLAGS$g
  637. OTHERFLAGS$
  638. RUNHUGS:
  639. SETMAINMODULE
  640. SYSTEMEVENT
  641. NEWFILEO
  642. OPENFILE
  643. RESUMEFILEi
  644. TOOLBARSETTITLE
  645. SAVEOPTIONSs
  646. LOADOPTIONS
  647. LOADINI
  648. SAVEINIi
  649. CMDSR%0
  650. CMDSH%S
  651. CMDSM%|
  652. CMDSL%
  653.     SETNUMOPT
  654.     SETSTROPT
  655.     MENUBOOL%
  656. RPROCESS
  657. SYSTEM\
  658. 53333S
  659. G3cff63t
  660. 09#www
  661. G3cff63t
  662. 53333S
  663. kE4    3
  664. 93sI3S
  665.  3C5!"
  666. 13C%!
  667. H433C
  668. kE4    3
  669. 9d9G8
  670. ZD3#2
  671. wwV3Cu
  672. This file contains a list of predicate definitions that will automatically
  673. be read into Mini Prolog at the beginning of a session.  Each clause in this
  674. file must be entered on a single line and lines containing syntax errors are
  675. always ignored.  This includes the first few lines of this file and provides
  676. a simple way to include comments.
  677. append(nil,X,X).
  678. append(cons(X,Y),Z,cons(X,W)):-append(Y,Z,W).
  679. equals(X,X).
  680. not(X):-X,!,false.
  681. not(X).
  682. or(X,Y):-X.
  683. or(X,Y):-Y.
  684. true.
  685. End of stdlib
  686. ______________________________________________________________________________
  687. Mini Prolog Version 1.5g             A simple Prolog interpreter, for Hugs 1.3
  688.      Mark P. Jones, 23rd July 1991, updated for Hugs 1.3, June 1996.
  689. ______________________________________________________________________________
  690. This document gives a brief introduction to Mini Prolog Version 1.5g, a simple
  691. Prolog interpreter that can be used with Hugs 1.3.  The original version of
  692. this program was written nearly two years ago as an Orwell program.  It has
  693. been through many minor changes since then, modified to run under Haskell B,
  694. then Gofer, and now Hugs.
  695. This document isn't going to explain a  lot  about  how  Prolog  programs  are
  696. written and work.  But there are plenty of other references for that.   Please
  697. feel free to contact me with any questions or suggestions.  I'd very much like
  698. to receive any comments.
  699. mpj@cs.nott.ac.uk
  700. ______________________________________________________________________________
  701.                            GETTING STARTED
  702. The  Mini Prolog interpreter  takes the form of a small  collection  of Hugs
  703. scripts.  The most important part of  any  implementation  of  Prolog  is  the
  704. inference engine  which  controls  the  search  for  goals  to  user  supplied
  705. queries.  Mini Prolog comes with a choice of two different inference  engines,
  706. the `pure' engine uses lazy evaluation to construct and  traverse  potentially
  707. infinite proof trees.  The `stack' engine uses an explicit stack  (implemented
  708. using a list) to provide a more concrete  description  of  backtracking.   The
  709. stack engine also implements  the  Prolog  cut  `!'  predicate,  used  in  the
  710. examples below.  Assuming that you've got everything set up  properly  to  use
  711. the Hugs interpreter, and that all of the Mini Prolog script files are in the
  712. current working directory, you should start Hugs with the command `hugs':
  713.   C:\HUGS\DEMOS\PROLOG>hugs
  714.         ___    ___   ___    ___   __________   __________
  715.        /  /   /  /  /  /   /  /  /  _______/  /  _______/   The Haskell User's
  716.       /  /___/  /  /  /   /  /  /  / _____   /  /______        Gofer System
  717.      /  ____   /  /  /   /  /  /  / /_   /  /______   /
  718.     /  /   /  /  /  /___/  /  /  /___/  /  _______/  /          Version 1.3
  719.    /__/   /__/  /_________/  /_________/  /_________/          Release alpha
  720.        Copyright (c) Mark P Jones, The University of Nottingham, 1994-1996.
  721.   Reading script file "\Hugs\Lib\hugs.prelude":
  722.   Hugs session for:
  723.   \Hugs\Lib\hugs.prelude
  724.   Type :? for help
  725. and then load the files for the Mini Prolog system:
  726.   ? :l Main
  727. Once the script files have been loaded,  start the Mini prolog interpreter by
  728. typing the expression `main' and pressing return.
  729.   ? main
  730.   Mini Prolog Version 1.5g (stack based)
  731.   Reading stdlib........done
  732. The `>' prompt indicates that the interpreter is running and waiting for  user
  733. input.
  734.                         STANDARD PREDICATES
  735. Before the `>' prompt appears, Mini Prolog reads a set of  standard  predicate
  736. definitions from the file `stdlib' in the current directory.  You are free  to
  737. modify this file to suit your own needs.  The only predicate that is built  in
  738. to Mini Prolog is the cut, written `!' whose use is demonstrated below.  There
  739. are no other  extralogical  predicates,  no  input/output  predicates  and  no
  740. arithmetic as found in full implementations of Prolog.  Some of these features
  741. could be added to the interpreter without too much  difficulty,  others  would
  742. require rather more work.
  743. At any time, you can ask the interpreter to display the list of rules that are
  744. being held in the database by typing "??" and pressing the  return  key.   Try
  745. this after you've started the  interpreter  and  you'll  get  a  list  of  the
  746. predicates defined in the file `stdlib'.  For example:
  747.   > ??
  748.   append(nil,X,X).
  749.   append(cons(X,Y),Z,cons(X,W)):-append(Y,Z,W).
  750.   equals(X,X).
  751.   not(X):-X,!,false.
  752.   not(X).
  753.   or(X,Y):-X.
  754.   or(X,Y):-Y.
  755.   true.
  756.                           THE APPEND PREDICATE
  757. The Mini Prolog interpreter does not support the standard  Prolog  syntax  for
  758. lists.    Instead,   you   have    to    write    the    list    [1,2,3]    as
  759. "cons(1,cons(2,cons(3,nil)))".  One of the first things I tried was  appending
  760. two simple lists:
  761.   > ?- append(cons(1,nil),cons(2,nil),X)
  762.   X = cons(1,cons(2,nil)) ;
  763.   no.
  764. Given a query, Mini Prolog attempts to find values for each of  the  variables
  765. (beginning with a capital letter) in the query.  Here Mini  Prolog  has  found
  766. that X = cons(1,cons(2,nil)) is a solution to the query.   When  I  press  the
  767. semicolon key, ";", it tries to find another solution, but fails and  displays
  768. the message "no.".
  769. What amazed me when I first started experimenting with Prolog was that I could
  770. actually ask Mini Prolog to work through the problem in reverse, asking  which
  771. lists could be appended to get the list cons(1,cons(2,nil)):
  772.   > ?- append(X,Y,cons(1,cons(2,nil)))
  773.   X = nil
  774.   Y = cons(1,cons(2,nil)) ;
  775.   X = cons(1,nil)
  776.   Y = cons(2,nil) ;
  777.   X = cons(1,cons(2,nil))
  778.   Y = nil ;
  779.   no.
  780. Note that the interpreter pauses after displaying each solution and waits  for
  781. a key to be  pressed.  Pressing `;' tells Mini Prolog  to continue looking for
  782. another solution, displaying `no' if no more solutions can be found.  Pressing
  783. any other key stops the execution of the query.  If there are no variables  in
  784. the original query, then the interpreter simply outputs `yes' if the query can
  785. be proved and otherwise prints `no':
  786.   > ?- append(cons(1,nil),cons(2,nil),cons(1,cons(2,nil)))
  787.   yes.
  788.   > ?- append(cons(1,nil),cons(2,nil),cons(1,cons(3,nil)))
  789.   no.
  790. Unfortunately, typing a control C to interrupt a query with an  infinite  loop
  791. will exit the Prolog interpreter completely -- sorry, but I don't know  a  way
  792. around this at the moment.
  793.                        RUNNING IN THE FAMILY
  794. You don't have to stick with the standard predicates that are already included
  795. in Mini Prolog.  Additional rules can be typed in at the ">" prompt.  Here are
  796. a couple of examples based around the idea of family trees:
  797.   > parent(Child,Parent):-father(Child,Parent).
  798.   > parent(Child,Parent):-mother(Child,Parent).
  799.   > grandparent(GChild,Gparent):-parent(GChild,Parent),parent(Parent,Gparent).
  800. Note that  Mini Prolog  expects  a maximum of one rule per line,  and will not
  801. allow predicate definitions to be spread out over a number of lines.
  802. All you have to do now is enter some details about your family  and  then  you
  803. can ask who your grandparents are ... let's take a typical family:
  804.   > father(charles,princePhilip).
  805.   > mother(charles,theQueen).
  806.   > father(anne,princePhilip).
  807.   > mother(anne,theQueen).
  808.   > father(andrew,princePhilip).
  809.   > mother(andrew,theQueen).
  810.   > father(edward,princePhilip).
  811.   > mother(edward,theQueen).
  812.   > mother(theQueen,theQueenMother).
  813.   > father(william,charles).
  814.   > mother(william,diana).
  815.   > father(harry,charles).
  816.   > mother(harry,diana).
  817. And  now  we  can  ask  some  questions;  like  who  are  the  Queen  mother's
  818. grandchildren ?
  819.   > ?- grandparent(X,theQueenMother)
  820.   X = charles ;
  821.   X = anne ;
  822.   X = andrew ;
  823.   X = edward ;
  824.   no.
  825. or, who are Harry's grandparents ?
  826.   > ?- grandparent(harry,Who)
  827.   Who = princePhilip ;
  828.   Who = theQueen ;
  829.   no.
  830. Note that Mini Prolog can only use the facts it has been  given.   Tell  it  a
  831. little more about Diana's parents and you'll find it knows more about  Harry's
  832. grandparents.
  833. Now suppose we define a sibling relation:
  834.   > sibling(One,Tother) :- parent(One,X),parent(Tother,X).
  835. Fine.  It all looks quite correct.  But when you try to find Harry's siblings,
  836. you get:
  837.   > ?- sibling(harry,Who)
  838.   Who = william ;
  839.   Who = harry ;
  840.   Who = william ;
  841.   Who = harry ;
  842.   no.
  843. Each of William and Harry  appears  twice  in  the  above.   Once  by  putting
  844. X=charles and once using X=diana in the definition of sibling above.   We  can
  845. use the cut predicate to make sure that we look for at most one parent:
  846.   > newsib(One,Tother) :- parent(One,X),!,parent(Tother,X).
  847.   > ?- newsib(harry,Who)
  848.   Who = william ;
  849.   Who = harry ;
  850.   no.
  851. Thats better, but we don't really want to list Harry as his  own  sibling,  so
  852. we'll add a further restriction:
  853.   > newsib1(O,T):-parent(O,X),!,parent(T,X),not(equals(O,T)).
  854.   > ?- newsib1(harry,Who)
  855.   Who = william ;
  856.   no.
  857. Thats just about perfect.  You might like to play with  some  other  examples,
  858. enlarge the family tree, work out suitable predicates for other relations (who
  859. are Harry's aunts ?) etc.  Initially, the answers that Mini Prolog gives  will
  860. all be pretty obvious to you.  Try getting involved in a  larger  family  tree
  861. and more complicated relations and you'll find it's not so easy.
  862.                                   GOODBYES
  863. I could go on with more examples, but I guess you've got the  picture  by  now
  864. ... at least I hope so !  I suppose I should just tell you how to get  out  of
  865. Mini Prolog (ok. ^C works but its not exactly elegant).  Just type  "bye"  (or
  866. "quit") and you're out.  Be warned though: when you leave Mini Prolog, it will
  867. not retain any new rules that you've entered, so  you'll  have  to  find  some
  868. other way to save them (I usually type  "??"  to  list  the  rules  that  I've
  869. entered and use the mouse to paste them into an editor in another window,  but
  870. that obviously requires you to be using a workstation at the time).
  871.   > bye
  872.   Thank you and goodbye
  873.   (12749 reductions, 1256 cells)
  874. The `?' prompt  tells you that you are now back in Hugs,  and you can restart
  875. Mini Prolog as before,  carry on with some other work in Hugs,  or use the :q
  876. command to exit Hugs and return to the operating system.
  877. I hope you have fun with Mini Prolog;  please tell me if you have any comments
  878. you'd like to make.
  879. ______________________________________________________________________________
  880. -- Substitutions and Unification of Prolog Terms
  881. -- Mark P. Jones November 1990, modified for Gofer 20th July 1991,
  882. -- and for Hugs 1.3 June 1996.
  883. -- Suitable for use with Hugs 98.
  884. module Subst where
  885. import Prolog
  886. infixr 3 @@
  887. infix  4 ->-
  888. --- Substitutions:
  889. type Subst = Id -> Term
  890. -- substitutions are represented by functions mapping identifiers to terms.
  891. -- app s     extends the substitution s to a function mapping terms to terms
  892. -- nullSubst is the empty substitution which maps every identifier to the
  893. --           same identifier (as a term).
  894. -- i ->- t   is the substitution which maps the identifier i to the term t,
  895. --           but otherwise behaves like nullSubst.
  896. -- s1@@ s2  is the composition of substitutions s1 and s2
  897. --           N.B.  app is a monoid homomorphism from (Subst,nullSubst,(@@))
  898. --           to (Term -> Term, id, (.)) in the sense that:
  899. --                  app (s1 @@ s2) = app s1 . app s2
  900. --                 s @@ nullSubst = s = nullSubst @@ s
  901. app                     :: Subst -> Term -> Term
  902. app s (Var i)            = s i
  903. app s (Struct a ts)      = Struct a (map (app s) ts)
  904. nullSubst               :: Subst
  905. nullSubst i              = Var i
  906. (->-)                   :: Id -> Term -> Subst
  907. (i ->- t) j | j==i       = t
  908.             | otherwise  = Var j
  909. (@@)                    :: Subst -> Subst -> Subst
  910. s1 @@ s2                 = app s1 . s2 
  911. --- Unification:
  912. -- unify t1 t2 returns a list containing a single substitution s which is
  913. --             the most general unifier of terms t1 t2.  If no unifier
  914. --             exists, the list returned is empty.
  915. unify :: Term -> Term -> [Subst]
  916. unify (Var x)       (Var y)       = if x==y then [nullSubst] else [x->-Var y]
  917. unify (Var x)       t2            = [ x ->- t2 | x `notElem` varsIn t2 ]
  918. unify t1            (Var y)       = [ y ->- t1 | y `notElem` varsIn t1 ]
  919. unify (Struct a ts) (Struct b ss) = [ u | a==b, u<-listUnify ts ss ]
  920. listUnify :: [Term] -> [Term] -> [Subst]
  921. listUnify []     []     = [nullSubst]
  922. listUnify []     (r:rs) = []
  923. listUnify (t:ts) []     = []
  924. listUnify (t:ts) (r:rs) = [ u2 @@ u1 | u1<-unify t r,
  925.                                        u2<-listUnify (map (app u1) ts)
  926.                                                      (map (app u1) rs) ]
  927. --- End of Subst.hs
  928. -- Stack based Prolog inference engine
  929. -- Mark P. Jones November 1990, modified for Gofer 20th July 1991,
  930. -- and for Hugs 1.3 June 1996.
  931. -- Suitable for use with Hugs 98.
  932. module StackEngine( version, prove ) where
  933. import Prolog
  934. import Subst
  935. version = "stack based"
  936. --- Calculation of solutions:
  937. -- the stack based engine maintains a stack of triples (s,goal,alts)
  938. -- corresponding to backtrack points, where s is the substitution at that
  939. -- point, goal is the outstanding goal and alts is a list of possible ways
  940. -- of extending the current proof to find a solution.  Each member of alts
  941. -- is a pair (tp,u) where tp is a new subgoal that must be proved and u is
  942. -- a unifying substitution that must be combined with the substitution s.
  943. -- the list of relevant clauses at each step in the execution is produced
  944. -- by attempting to unify the head of the current goal with a suitably
  945. -- renamed clause from the database.
  946. type Stack = [ (Subst, [Term], [Alt]) ]
  947. type Alt   = ([Term], Subst)
  948. alts       :: Database -> Int -> Term -> [Alt]
  949. alts db n g = [ (tp,u) | (tm:-tp) <- renClauses db n g, u <- unify g tm ]
  950.       
  951. -- The use of a stack enables backtracking to be described explicitly,
  952. -- in the following `state-based' definition of prove:
  953. prove      :: Database -> [Term] -> [Subst]
  954. prove db gl = solve 1 nullSubst gl []
  955.  where
  956.    solve :: Int -> Subst -> [Term] -> Stack -> [Subst]
  957.    solve n s []     ow          = s : backtrack n ow
  958.    solve n s (g:gs) ow
  959.                     | g==theCut = solve n s gs (cut ow)
  960.                     | otherwise = choose n s gs (alts db n (app s g)) ow
  961.    choose :: Int -> Subst -> [Term] -> [Alt] -> Stack -> [Subst]
  962.    choose n s gs []          ow = backtrack n ow
  963.    choose n s gs ((tp,u):rs) ow = solve (n+1) (u@@s) (tp++gs) ((s,gs,rs):ow)
  964.    backtrack                   :: Int -> Stack -> [Subst]
  965.    backtrack n []               = []
  966.    backtrack n ((s,gs,rs):ow)   = choose (n-1) s gs rs ow
  967. --- Special definitions for the cut predicate:
  968. theCut    :: Term
  969. theCut     = Struct "!" []
  970. cut                  :: Stack -> Stack
  971. cut (top:(s,gl,_):ss) = top:(s,gl,[]):ss
  972. cut ss                = ss
  973. --- End of Engine.hs
  974. -- The Pure Prolog inference engine (using explicit prooftrees)
  975. -- Mark P. Jones November 1990, modified for Gofer 20th July 1991,
  976. -- and for Hugs 1.3 June 1996.
  977. -- Suitable for use with Hugs 98.
  978. module PureEngine( version, prove ) where
  979. import Prolog
  980. import Subst
  981. version = "tree based" 
  982. --- Calculation of solutions:
  983. -- Each node in a prooftree corresponds to:
  984. -- either: a solution to the current goal, represented by Done s, where s
  985. --         is the required substitution
  986. -- or:     a choice between a number of subtrees ts, each corresponding to a
  987. --         proof of a subgoal of the current goal, represented by Choice ts.
  988. --         The proof tree corresponding to an unsolvable goal is Choice [] 
  989. data Prooftree = Done Subst  |  Choice [Prooftree]
  990. -- prooftree uses the rules of Prolog to construct a suitable proof tree for
  991. --           a specified goal
  992. prooftree   :: Database -> Int -> Subst -> [Term] -> Prooftree
  993. prooftree db = pt
  994.  where pt           :: Int -> Subst -> [Term] -> Prooftree
  995.        pt n s []     = Done s
  996.        pt n s (g:gs) = Choice [ pt (n+1) (u@@s) (map (app u) (tp++gs))
  997.                               | (tm:-tp)<-renClauses db n g, u<-unify g tm ]
  998. -- search performs a depth-first search of a proof tree, producing the list
  999. --        of solution substitutions as they are encountered.
  1000. search              :: Prooftree -> [Subst]
  1001. search (Done s)      = [s]
  1002. search (Choice pts)  = [ s | pt <- pts, s <- search pt ]
  1003. prove    :: Database -> [Term] -> [Subst]
  1004. prove db  = search . prooftree db 1 nullSubst
  1005. --- End of PureEngine.hs
  1006. -- Representation of Prolog Terms, Clauses and Databases
  1007. -- Mark P. Jones November 1990, modified for Gofer 20th July 1991,
  1008. -- and for Hugs 1.3 June 1996.
  1009. -- Suitable for use with Hugs 98.
  1010. module Prolog
  1011.     ( Id, Term(..), Clause(..), Database
  1012.     , varsIn, renClauses, addClause, emptyDb, termlist, clause
  1013.     ) where
  1014. import List
  1015. import CombParse
  1016. infix 6 :-
  1017. --- Prolog Terms:
  1018. type Id       = (Int,String)
  1019. type Atom     = String
  1020. data Term     = Var Id | Struct Atom [Term]
  1021. data Clause   = Term :- [Term]
  1022. data Database = Db [(Atom,[Clause])]
  1023. instance Eq Term where
  1024.     Var v       == Var w       =  v==w
  1025.     Struct a ts == Struct b ss =  a==b && ts==ss
  1026.     _           == _           =  False
  1027. --- Determine the list of variables in a term:
  1028. varsIn              :: Term -> [Id]
  1029. varsIn (Var i)       = [i]
  1030. varsIn (Struct i ts) = (nub . concat . map varsIn) ts
  1031. renameVars                  :: Int -> Term -> Term
  1032. renameVars lev (Var (n,s))   = Var (lev,s)
  1033. renameVars lev (Struct s ts) = Struct s (map (renameVars lev) ts)
  1034. --- Functions for manipulating databases (as an abstract datatype)
  1035. emptyDb      :: Database
  1036. emptyDb       = Db []
  1037. renClauses                  :: Database -> Int -> Term -> [Clause]
  1038. renClauses db n (Var _)      = []
  1039. renClauses db n (Struct a _) = [ r tm:-map r tp | (tm:-tp)<-clausesFor a db ]
  1040.                                where r = renameVars n
  1041. clausesFor           :: Atom -> Database -> [Clause]
  1042. clausesFor a (Db rss) = case dropWhile (\(n,rs) -> n<a) rss of
  1043.                          []         -> []
  1044.                          ((n,rs):_) -> if a==n then rs else []
  1045. addClause :: Database -> Clause -> Database
  1046. addClause (Db rss) r@(Struct a _ :- _)
  1047.            = Db (update rss)
  1048.              where update []            = [(a,[r])]
  1049.                    update (h@(n,rs):rss')
  1050.                           | n==a        = (n,rs++[r]) : rss'
  1051.                   | n<a         = h : update rss'
  1052.                           | otherwise   = (a,[r]) : h : rss'
  1053. --- Output functions (defined as instances of Show):
  1054. instance Show Term where
  1055.   showsPrec p (Var (n,s))
  1056.               | n==0        = showString s
  1057.               | otherwise   = showString s . showChar '_' . shows n
  1058.   showsPrec p (Struct a []) = showString a
  1059.   showsPrec p (Struct a ts) = showString a . showChar '('
  1060.                                            . showWithSep "," ts
  1061.                                            . showChar ')'
  1062. instance Show Clause where
  1063.    showsPrec p (t:-[]) = shows t . showChar '.'
  1064.    showsPrec p (t:-gs) = shows t . showString ":-"
  1065.                                  . showWithSep "," gs
  1066.                                  . showChar '.'
  1067. instance Show Database where
  1068.     showsPrec p (Db [])  = showString "-- Empty Database --\n"
  1069.     showsPrec p (Db rss) = foldr1 (\u v-> u . showChar '\n' . v)
  1070.                                   [ showWithTerm "\n" rs | (i,rs)<-rss ]
  1071. --- Local functions for use in defining instances of Show:
  1072. showWithSep          :: Show a => String -> [a] -> ShowS
  1073. showWithSep s [x]     = shows x
  1074. showWithSep s (x:xs)  = shows x . showString s . showWithSep s xs
  1075. showWithTerm         :: Show a => String -> [a] -> ShowS
  1076. showWithTerm s xs     = foldr1 (.) [shows x . showString s | x<-xs]
  1077. --- String parsing functions for Terms and Clauses:
  1078. --- Local definitions:
  1079. letter       :: Parser Char
  1080. letter        = sat (\c->isAlpha c || isDigit c || c `elem` ":;+=-*&%$#@?/.~!")
  1081. variable     :: Parser Term
  1082. variable      = sat isUpper `pseq` many letter `pam` makeVar
  1083.                 where makeVar (initial,rest) = Var (0,(initial:rest))
  1084. struct       :: Parser Term
  1085. struct        = many letter `pseq` (sptok "(" `pseq` termlist `pseq` sptok ")"
  1086.                                        `pam` (\(o,(ts,c))->ts)
  1087.                                   `orelse`
  1088.                                    okay [])
  1089.                 `pam` (\(name,terms)->Struct name terms)
  1090. --- Exports:
  1091. term         :: Parser Term
  1092. term          = sp (variable `orelse` struct)
  1093. termlist     :: Parser [Term]
  1094. termlist      = listOf term (sptok ",")
  1095. clause       :: Parser Clause
  1096. clause        = sp struct `pseq` (sptok ":-" `pseq` listOf term (sptok ",")
  1097.                                  `pam` (\(from,body)->body)
  1098.                                 `orelse` okay [])
  1099.                           `pseq` sptok "."
  1100.                      `pam` (\(head,(goals,dot))->head:-goals)
  1101. --- End of Prolog.hs
  1102. -- Prolog interpreter top level module
  1103. -- Mark P. Jones November 1990, modified for Gofer 20th July 1991,
  1104. -- and for Hugs 1.3 June 1996.
  1105. -- Suitable for use with Hugs 98.
  1106. module Main where
  1107. import CombParse
  1108. import Prolog
  1109. import Interact
  1110. import Subst
  1111. import StackEngine
  1112. import List(nub)
  1113. --- Command structure and parsing:
  1114. data Command = Fact Clause | Query [Term] | Show | Error | Quit | NoChange
  1115. command :: Parser Command
  1116. command  = just (sptok "bye" `orelse` sptok "quit") `pam` (\quit->Quit)
  1117.                `orelse`
  1118.            just (okay NoChange)
  1119.                `orelse`
  1120.            just (sptok "??") `pam` (\show->Show)
  1121.                `orelse`
  1122.            just clause `pam` Fact
  1123.                `orelse`
  1124.            just (sptok "?-" `pseq` termlist) `pam` (\(q,ts)->Query ts)
  1125.                `orelse`
  1126.            okay Error
  1127. --- Main program read-solve-print loop:
  1128. signOn           :: String
  1129. signOn            = "Mini Prolog Version 1.5g (" ++ version ++ ")\n\n"
  1130. main             :: IO ()
  1131. main              = do putStr signOn
  1132.                        putStr ("Reading " ++ stdlib)
  1133.                clauses <- readLibrary stdlib
  1134.                        interpreter clauses
  1135. readLibrary lib   = do is <- readFile lib
  1136.                        let parse   = map clause (lines is)
  1137.                            clauses = [ r | ((r,""):_) <- parse ]
  1138.                            reading = ['.'| c <- clauses] ++ "done\n"
  1139.                        putStr reading
  1140.                return clauses
  1141.             `catch` \err ->
  1142.                     do putStr "...not found\n"
  1143.                        return []
  1144. stdlib           :: String
  1145. stdlib            = "stdlib"
  1146. interpreter      :: [Clause] -> IO ()
  1147. interpreter lib   = do is <- getContents
  1148.                        putStr (loop startDb is)
  1149.                     where startDb = foldl addClause emptyDb lib
  1150. loop             :: Database -> String -> String
  1151. loop db           = readLine "> " (exec db . fst . head . command)
  1152. exec             :: Database -> Command -> String -> String
  1153. exec db (Fact r)  = loop (addClause db r)
  1154. exec db (Query q) = demonstrate db q
  1155. exec db Show      = writeStr (show db)                 (loop db)
  1156. exec db Error     = writeStr "I don't understand\n"    (loop db)
  1157. exec db Quit      = writeStr "Thank you and goodbye\n" end
  1158. exec db NoChange  = loop db
  1159. --- Handle printing of solutions etc...
  1160. solution      :: [Id] -> Subst -> [String]
  1161. solution vs s  = [ show (Var i) ++ " = " ++ show v
  1162.                                 | (i,v) <- [ (i,s i) | i<-vs ], v /= Var i ]
  1163. demonstrate     :: Database -> [Term] -> Interact
  1164. demonstrate db q = printOut (map (solution vs) (prove db q))
  1165.  where vs               = (nub . concat . map varsIn) q
  1166.        printOut []      = writeStr "no.\n"     (loop db)
  1167.        printOut ([]:bs) = writeStr "yes.\n"    (loop db)
  1168.        printOut (b:bs)  = writeStr (doLines b) (nextReqd bs)
  1169.        doLines          = foldr1 (\xs ys -> xs ++ "\n" ++ ys)
  1170.        nextReqd bs      = writeStr " "
  1171.                           (readChar end
  1172.                            (\c-> if c==';' then writeStr ";\n" (printOut bs)
  1173.                                            else writeStr "\n"  (loop db)))
  1174. --- End of Main.hs
  1175. -----------------------------------------------------------------------------
  1176. -- Combinator parsing library:
  1177. -- The original Gofer version of this file was based on Richard Bird's
  1178. -- parselib.orw for Orwell (with a number of extensions).
  1179. -- Not recommended for new work.
  1180. -- Suitable for use with Hugs 98.
  1181. -----------------------------------------------------------------------------
  1182. module CombParse where
  1183. infixr 6 `pseq`
  1184. infixl 5 `pam`
  1185. infixr 4 `orelse`
  1186. --- Type definition:
  1187. type Parser a = [Char] -> [(a,[Char])]
  1188. -- A parser is a function which maps an input stream of characters into
  1189. -- a list of pairs each containing a parsed value and the remainder of the
  1190. -- unused input stream.  This approach allows us to use the list of
  1191. -- successes technique to detect errors (i.e. empty list ==> syntax error).
  1192. -- it also permits the use of ambiguous grammars in which there may be more
  1193. -- than one valid parse of an input string.
  1194. --- Primitive parsers:
  1195. -- pfail    is a parser which always fails.
  1196. -- okay v   is a parser which always succeeds without consuming any characters
  1197. --          from the input string, with parsed value v.
  1198. -- tok w    is a parser which succeeds if the input stream begins with the
  1199. --          string (token) w, returning the matching string and the following
  1200. --          input.  If the input does not begin with w then the parser fails.
  1201. -- sat p    is a parser which succeeds with value c if c is the first input
  1202. --          character and c satisfies the predicate p.
  1203. pfail       :: Parser a 
  1204. pfail is     = []
  1205. okay        :: a -> Parser a  
  1206. okay v is    = [(v,is)]
  1207. tok         :: [Char] -> Parser [Char]
  1208. tok w is     = [(w, drop n is) | w == take n is]
  1209.                where n = length w
  1210. sat         :: (Char -> Bool) -> Parser Char 
  1211. sat p []     = []
  1212. sat p (c:is) = [ (c,is) | p c ]
  1213. --- Parser combinators:
  1214. -- p1 `orelse` p2 is a parser which returns all possible parses of the input
  1215. --                string, first using the parser p1, then using parser p2.
  1216. -- p1 `seq` p2    is a parser which returns pairs of values (v1,v2) where
  1217. --                v1 is the result of parsing the input string using p1 and
  1218. --                v2 is the result of parsing the remaining input using p2.
  1219. -- p `pam` f      is a parser which behaves like the parser p, but returns
  1220. --                the value f v wherever p would have returned the value v.
  1221. -- just p         is a parser which behaves like the parser p, but rejects any
  1222. --                parses in which the remaining input string is not blank.
  1223. -- sp p           behaves like the parser p, but ignores leading spaces.
  1224. -- sptok w        behaves like the parser tok w, but ignores leading spaces.
  1225. -- many p         returns a list of values, each parsed using the parser p.
  1226. -- many1 p        parses a non-empty list of values, each parsed using p.
  1227. -- listOf p s     parses a list of input values using the parser p, with
  1228. --                separators parsed using the parser s.
  1229. orelse             :: Parser a -> Parser a -> Parser a 
  1230. (p1 `orelse` p2) is = p1 is ++ p2 is
  1231. pseq               :: Parser a -> Parser b -> Parser (a,b)
  1232. (p1 `pseq` p2) is   = [((v1,v2),is2) | (v1,is1) <- p1 is, (v2,is2) <- p2 is1]
  1233. pam                :: Parser a -> (a -> b) -> Parser b 
  1234. (p `pam` f) is      = [(f v, is1) | (v,is1) <- p is]
  1235. just               :: Parser a -> Parser a
  1236. just p is           = [ (v,"") | (v,is')<- p is, dropWhile (' '==) is' == "" ]
  1237. sp                 :: Parser a -> Parser a
  1238. sp p                = p . dropWhile (' '==)
  1239. sptok              :: [Char] -> Parser [Char]
  1240. sptok               =  sp . tok
  1241. many               :: Parser a  -> Parser [a]
  1242. many p              = q
  1243.                       where q = ((p `pseq` q) `pam` makeList) `orelse` (okay [])
  1244. many1              :: Parser a -> Parser [a]
  1245. many1 p             = p `pseq` many p `pam` makeList
  1246. listOf             :: Parser a -> Parser b -> Parser [a]
  1247. listOf p s          = p `pseq` many (s `pseq` p) `pam` nonempty
  1248.                       `orelse` okay []
  1249.                       where nonempty (x,xs) = x:(map snd xs)
  1250. --- Internals:
  1251. makeList       :: (a,[a]) -> [a]
  1252. makeList (x,xs) = x:xs
  1253. -----------------------------------------------------------------------------
  1254. By Donald A. Smith, December 22, 1994, based on Mark Jones' PureEngine.
  1255. This inference engine implements a variation of the Andorra Principle for
  1256. logic programming. (See references at the end of this file.) The basic
  1257. idea is that instead of always selecting the first goal in the current
  1258. list of goals, select a relatively deterministic goal.
  1259. For each goal g in the list of goals, calculate the resolvents that would
  1260. result from selecting g.  Then choose a g which results in the lowest
  1261. number of resolvents.  If some g results in 0 resolvents then fail.
  1262. (This would occur for a goal like:  ?- append(A,B,[1,2,3]),equals(1,2).)
  1263. Prolog would not perform this optimization and would instead search
  1264. and backtrack wastefully.  If some g results in a single resolvent
  1265. (i.e., only a single clause matches) then that g will get selected;
  1266. by selecting and resolving g, bindings are propagated sooner, and useless
  1267. search can be avoided, since these bindings may prune away choices for
  1268. other clauses.  For example: ?- append(A,B,[1,2,3]),B=[].
  1269. module AndorraEngine( version, prove ) where
  1270. import Prolog
  1271. import Subst
  1272. version = "Andorra Principle Interpreter (select deterministic goals first)"
  1273. solve   :: Database -> Int -> Subst -> [Term] -> [Subst]
  1274. solve db = slv where
  1275.    slv           :: Int -> Subst -> [Term] -> [Subst]
  1276.    slv n s [] = [s]
  1277.    slv n s goals =
  1278.     let allResolvents = resolve_selecting_each_goal goals db n in
  1279.       let (gs,gres) =  findMostDeterministic allResolvents in
  1280.           concat [slv (n+1) (u@@s) (map (app u) (tp++gs)) | (u,tp) <- gres]
  1281. resolve_selecting_each_goal::
  1282.     [Term] -> Database -> Int -> [([Term],[(Subst,[Term])])]
  1283. --  For each pair in the list that we return, the first element of the
  1284. --  pair is the list of unresolved goals; the second element is the list
  1285. --  of resolvents of the selected goal, where a resolvent is a pair
  1286. --  consisting of a substitution and a list of new goals.
  1287. resolve_selecting_each_goal goals db n = [(gs, gResolvents) |
  1288.       (g,gs) <- delete goals, let gResolvents = resolve db g n]
  1289. -- The unselected goals from above are not passed in.
  1290. resolve :: Database -> Term -> Int -> [(Subst,[Term])]
  1291. resolve db g n = [(u,tp) | (tm:-tp)<-renClauses db n g, u<-unify g tm]
  1292. -- u is not yet applied to tp, since it is possible that g won't be selected.
  1293. -- Note that unify could be nondeterministic.
  1294. findMostDeterministic:: [([Term],[(Subst,[Term])])] -> ([Term],[(Subst,[Term])])
  1295. findMostDeterministic  allResolvents = minF comp allResolvents where
  1296.    comp:: (a,[b]) -> (a,[b]) -> Bool
  1297.    comp (_,gs1) (_,gs2) = (length gs1) < (length gs2)
  1298. -- It seems to me that there is an opportunity for a clever compiler to
  1299. -- optimize this code a lot. In particular, there should be no need to
  1300. -- determine the total length of a goal list if it is known that
  1301. -- there is a shorter goal list in allResolvents ... ?
  1302. delete ::  [a] -> [(a,[a])]
  1303. delete l = d l [] where
  1304.    d :: [a] -> [a] ->  [(a,[a])]
  1305.    d [g] sofar = [ (g,sofar) ]
  1306.    d (g:gs) sofar = (g,sofar++gs) : (d gs (g:sofar))
  1307. minF               :: (a -> a -> Bool) -> [a] -> a
  1308. minF f (h:t) = m h t where
  1309. --   m :: a -> [a] -> a
  1310.      m sofar [] = sofar
  1311.      m sofar (h:t) = if (f h sofar) then m h t else m sofar t
  1312. prove    :: Database -> [Term] -> [Subst]
  1313. prove db  = solve db 1 nullSubst
  1314. {- An optimized, incremental version of the above interpreter would use
  1315.   a data representation in which for each goal in "goals" we carry around
  1316.   the list of resolvents.  After each resolution step we update the lists.
  1317. {- References
  1318.    Seif Haridi & Per Brand, "Andorra Prolog, an integration of Prolog
  1319.    and committed choice languages" in Proceedings of FGCS 1988, ICOT,
  1320.    Tokyo, 1988.
  1321.    Vitor Santos Costa, David H. D. Warren, and Rong Yang, "Two papers on
  1322.    the Andorra-I engine and preprocessor", in Proceedings of the 8th
  1323.    ICLP. MIT Press, 1991.
  1324.    Steve Gregory and Rong Yang, "Parallel Constraint Solving in
  1325.    Andorra-I", in Proceedings of FGCS'92. ICOT, Tokyo, 1992.
  1326.    Sverker Janson and Seif Haridi, "Programming Paradigms of the Andorra
  1327.    Kernel Language", in Proceedings of ILPS'91. MIT Press, 1991.
  1328.    Torkel Franzen, Seif Haridi, and Sverker Janson, "An Overview of the
  1329.    Andorra Kernel Language", In LNAI (LNCS) 596, Springer-Verlag, 1992.
  1330. module Tree where
  1331. import Gofer
  1332. -- Here are a collection of fairly standard functions for manipulating
  1333. -- one form of binary trees
  1334. data Tree a = Lf a | Tree a :^: Tree a
  1335. reflect t@(Lf x)  = t
  1336. reflect (l:^:r)   = r :^: l
  1337. mapTree f (Lf x)  = Lf (f x)
  1338. mapTree f (l:^:r) = mapTree f l :^: mapTree f r
  1339. -- Functions to calculate the list of leaves on a tree:
  1340. leaves, leaves'  :: Tree a -> [a]
  1341. leaves (Lf l)     = [l]                     -- direct version
  1342. leaves (l:^:r)    = leaves l ++ leaves r
  1343. leaves' t         = leavesAcc t []          -- using an accumulating parameter
  1344.                     where leavesAcc (Lf l)  = (l:)
  1345.                           leavesAcc (l:^:r) = leavesAcc l . leavesAcc r
  1346. -- Picturing a tree:
  1347. drawTree :: Show a => Tree a -> IO ()
  1348. drawTree  = putStr . unlines . thd3 . pic
  1349.  where pic (Lf a)  = (1,1,["-- "++show a])
  1350.        pic (l:^:r) = (hl+hr+1, hl+1, top pl ++ mid ++ bot pr)
  1351.                      where (hl,bl,pl) = pic l
  1352.                            (hr,br,pr) = pic r
  1353.                            top        = zipWith (++) (replicate (bl-1) "   " ++
  1354.                                                       [" ,-"] ++
  1355.                                                       replicate (hl-bl) " | ")
  1356.                            mid        = ["-| "]
  1357.                            bot        = zipWith (++) (replicate (br-1) " | " ++
  1358.                                                       [" `-"] ++
  1359.                                                       replicate (hr-br) "   ")
  1360. -- Finally, here is an example due to Richard Bird, which uses lazy evaluation
  1361. -- and recursion to create a `cyclic' program which avoids multiple traversals
  1362. -- over a data structure:
  1363. replaceAndMin m (Lf n)  =  (Lf m, n)
  1364. replaceAndMin m (l:^:r) =  (rl :^: rr, ml `min` mr)
  1365.                            where (rl,ml) = replaceAndMin m l
  1366.                                  (rr,mr) = replaceAndMin m r
  1367. replaceWithMin t = mt where (mt,m) = replaceAndMin m t
  1368. sample, sample2, sample4 :: Num a => Tree a
  1369. sample  = (Lf 12 :^: (Lf 23 :^: Lf 13)) :^: Lf 10
  1370. sample2 = sample  :^: sample
  1371. sample4 = sample2 :^: sample2
  1372. -- Stacks: using restricted type synonyms
  1373. module Stack where
  1374. type Stack a = [a] in emptyStack, push, pop, topOf, isEmpty
  1375. emptyStack :: Stack a
  1376. emptyStack  = []
  1377. push       :: a -> Stack a -> Stack a
  1378. push        = (:)
  1379. pop        :: Stack a -> Stack a
  1380. pop []      = error "pop: empty stack"
  1381. pop (_:xs)  = xs
  1382. topOf      :: Stack a -> a
  1383. topOf []    = error "topOf: empty stack"
  1384. topOf (x:_) = x
  1385. isEmpty    :: Stack a -> Bool
  1386. isEmpty     = null
  1387. instance Eq a => Eq (Stack a) where
  1388.     s1 == s2 | isEmpty s1 = isEmpty s2
  1389.              | isEmpty s2 = isEmpty s1
  1390.              | otherwise  = topOf s1 == topOf s2 && pop s1 == pop s2
  1391. -- A slightly different presentation:
  1392. type Stack' a = [a] in
  1393.    emptyStack' :: Stack' a,
  1394.    push'       :: a -> Stack' a -> Stack' a,
  1395.    pop'        :: Stack' a -> Stack' a,
  1396.    topOf'      :: Stack' a -> a,
  1397.    isEmpty'    :: Stack' a -> Bool
  1398. emptyStack'  = []
  1399. push'        = (:)
  1400. pop' []      = error "pop': empty stack"
  1401. pop' (_:xs)  = xs
  1402. topOf' []    = error "topOf': empty stack"
  1403. topOf' (x:_) = x
  1404. isEmpty'     = null
  1405. instance Eq a => Eq (Stack' a) where
  1406.     s1 == s2 | isEmpty' s1 = isEmpty' s2
  1407.              | isEmpty' s2 = isEmpty' s1
  1408.              | otherwise   = topOf' s1 == topOf' s2 && pop' s1 == pop' s2
  1409. ------------------------------------------------------------------------------
  1410. -- A simple banner program:                             Mark P Jones, 1992
  1411. -- Many years ago, I was helping out on a stand at a computer show.
  1412. -- Or at least, I would have been if anyone had been interested in
  1413. -- what we had on the stand.  So instead, I sat down to see if I
  1414. -- could write a banner program -- something to print messages out
  1415. -- in large letters.
  1416. -- The original program was in Basic, but here is a version in Hugs.
  1417. -- The program itself is only two lines long and that is rather pleasing,
  1418. -- but the raw data for the letters (and the function mapping characters
  1419. -- to letters) take up rather more space.  I don't have that Basic version
  1420. -- anymore.  I wonder whether the complete Hugs code is that much shorter?
  1421. -- One of the nice things about this program is that the main program is
  1422. -- completely independent of the size of characters.  You could easily add
  1423. -- a new font, perhaps with higher resolution (bigger letters), or even
  1424. -- variable width characters, and the program would take it all in its
  1425. -- stride.
  1426. -- If you have a wide screen (>80 cols), you might like to try evaluating:
  1427. --            (putStr . concat . map say . lines . say) "Hi"
  1428. -- and contemplating how easy it might have been to get my original
  1429. -- Basic version to perform this trick...
  1430. -- Enjoy!
  1431. ------------------------------------------------------------------------------
  1432. module Say where
  1433. import Char( ord, chr )
  1434. import List( transpose )
  1435. sayit :: String -> IO ()
  1436. sayit  = putStr . say
  1437. say    = ('\n':) . unlines . map join . transpose . map picChar
  1438.          where join  = foldr1 (\xs ys -> xs ++ "  " ++ ys)
  1439. -- mapping characters to letters: --------------------------------------------
  1440. picChar c  | isUpper c  = alphas !! (ord c - ord 'A')
  1441.            | isLower c  = alphas !! (ord c - ord 'a')
  1442.            | isSpace c  = blank
  1443.            | isDigit c  = digits !! (ord c - ord '0')
  1444.            | c=='/'     = slant
  1445.            | c=='\\'    = reverse slant
  1446.            | otherwise  = head ([ letter | (c',letter) <- punct, c'==c ]
  1447.                                 ++ [nothing])
  1448. -- letters data: -------------------------------------------------------------
  1449. blank  =  ["     ", "     ", "     ", "     ", "     "]
  1450. slant  =  ["    ",  "   ",   "  ",    " ",     ""     ]
  1451. nothing=  repeat ""
  1452. punct  =  [('.',  ["     ", "     ", "     ", "  .. ", "  .. "]),
  1453.            ('?',  [" ??? ", "?   ?", "   ? ", "  ?  ", "  .  "]),
  1454.            ('!',  ["  !  ", "  !  ", "  !  ", "  !  ", "  .  "]),
  1455.            ('-',  ["     ", "     ", "-----", "     ", "     "]),
  1456.            ('+',  ["  +  ", "  +  ", "+++++", "  +  ", "  +  "]),
  1457.            (':',  ["     ", "  :: ", "     ", "  :: ", "     "]),
  1458.            (';',  ["     ", "  ;; ", "     ", "  ;; ", " ;;  "])
  1459.           ]
  1460. digits = [[" OOO ", "0  00", "0 0 0", "00  0", " 000 "],
  1461.           ["  1  ", " 11  ", "  1  ", "  1  ", "11111"],
  1462.           [" 222 ", "2   2", "   2 ", "  2  ", "22222"],
  1463.           ["3333 ", "    3", " 333 ", "    3", "3333 "],
  1464.           ["   4 ", "  44 ", " 4 4 ", "44444", "   4 "],
  1465.           ["55555", "5    ", "5555 ", "    5", "5555 "],
  1466.           ["   66", "  6  ", " 666 ", "6   6", " 666 "],
  1467.           ["77777", "    7", "   7 ", "   7 ", "  7  "],
  1468.           [" 888 ", "8   8", " 888 ", "8   8", " 888 "],
  1469.           [" 999 ", "9   9", " 999 ", "  9  ", "99   "]]
  1470. alphas = [["  A  ", " A A ", "AAAAA", "A   A", "A   A"],
  1471.           ["BBBB ", "B   B", "BBBB ", "B   B", "BBBB "],
  1472.           [" CCCC", "C    ", "C    ", "C    ", " CCCC"],
  1473.           ["DDDD ", "D   D", "D   D", "D   D", "DDDD "],
  1474.           ["EEEEE", "E    ", "EEEEE", "E    ", "EEEEE"],
  1475.           ["FFFFF", "F    ", "FFFF ", "F    ", "F    "],
  1476.           [" GGGG", "G    ", "G  GG", "G   G", " GGG "],
  1477.           ["H   H", "H   H", "HHHHH", "H   H", "H   H"],
  1478.           ["IIIII", "  I  ", "  I  ", "  I  ", "IIIII"],
  1479.           ["JJJJJ", "   J ", "   J ", "J  J ", " JJ  "],
  1480.           ["K   K", "K  K ", "KKK  ", "K  K ", "K   K"],
  1481.           ["L    ", "L    ", "L    ", "L    ", "LLLLL"],
  1482.           ["M   M", "MM MM", "M M M", "M   M", "M   M"],
  1483.           ["N   N", "NN  N", "N N N", "N  NN", "N   N"],
  1484.           [" OOO ", "O   O", "O   O", "O   O", " OOO "],
  1485.           ["PPPP ", "P   P", "PPPP ", "P    ", "P    "],
  1486.           [" QQQ ", "Q   Q", "Q Q Q", "Q  Q ", " QQ Q"],
  1487.           ["RRRR ", "R   R", "RRRR ", "R  R ", "R   R"],
  1488.           [" SSSS", "S    ", " SSS ", "    S", "SSSS "],
  1489.           ["TTTTT", "  T  ", "  T  ", "  T  ", "  T  "],
  1490.           ["U   U", "U   U", "U   U", "U   U", " UUU "],
  1491.           ["V   V", "V   V", "V   V", " V V ", "  V  "],
  1492.           ["W   W", "W   W", "W   W", "W W W", " W W "],
  1493.           ["X   X", " X X ", "  X  ", " X X ", "X   X"],
  1494.           ["Y   Y", " Y Y ", "  Y  ", "  Y  ", "  Y  "],
  1495.           ["ZZZZZ", "   Z ", "  Z  ", " Z   ", "ZZZZZ"]
  1496.          ]
  1497. -- end of banner program -----------------------------------------------------
  1498. -- This N-Queens program is based on a small variation of the 8-queens
  1499. -- program from Bird and Wadler's book.
  1500. -- Be warned: printing out the complete list of solutions (all 92 of them)
  1501. -- by evaluating "q 8" takes well over 1 million reductions and uses nearly
  1502. -- 2.5 million cells... it may take some time to execute on slower systems! :-)
  1503. module Queens where
  1504. import Gofer
  1505. queens number_of_queens  = qu number_of_queens where
  1506.     qu 0          = [[]]
  1507.     qu (m+1)      = [ p++[n] | p<-qu m, n<-[1..number_of_queens], safe p n ]
  1508. safe p n          = all not [ check (i,j) (m,n) | (i,j) <- zip [1..] p ]
  1509.                     where m = 1 + length p
  1510. check (i,j) (m,n) = j==n || (i+j==m+n) || (i-j==m-n)
  1511. -- Use q 5 to see the list of solutions for 5 queens.
  1512. -- Use q 8 to see the list of solutions for 8 queens ....
  1513. q = putStr . layn . map show . queens
  1514. -------------------------------------------------------------------------------
  1515. -- The following random number generator is an implementation of the
  1516. -- Minimum Standard generator recommended in
  1517. --    Random Number Generators: Good ones are hard to find
  1518. --       Stephen K Park & Keith W Miller
  1519. --       Communications of the ACM, Oct 88, Vol 31 No 10 1192 - 1201
  1520. -- Seeds must be in the range 1..2147483646, that is (1..(2**31)-2)
  1521. -- Output will also be in that range. The generator is full period so that
  1522. -- all 2147483646 values will be generated before the initial seed repeats.
  1523. -- Dividing by 2147483647 (real) as in the Pascal code below will map it
  1524. -- into the range (0..1) if required.
  1525. -- [This program assumes that you are working on a machine with (at least)
  1526. -- 32 bit integers.  Folks using Hugs on a PC will have to stick with the
  1527. -- less sophisticated random number generator in the file `randoms'.]
  1528. -------------------------------------------------------------------------------
  1529. module Minsrand where
  1530. min_stand_test  :: Int -> Int
  1531. min_stand_test n = if test > 0 then test else test + 2147483647
  1532.            where test = 16807 * lo - 2836 * hi
  1533.                  hi   = n `div` 127773
  1534.                  lo   = n `rem` 127773
  1535. min_stand_randoms :: Int -> [Int]
  1536. min_stand_randoms  = iterate min_stand_test
  1537. -- The article produced below also gives a test to check that the
  1538. -- random number generator is working.  We can duplicate this test
  1539. -- as follows:
  1540. --   ? strictIterate min_stand_test 1 !! 10000
  1541. --   1043618065
  1542. --   (149758 reductions, 240096 cells, 2 garbage collections)
  1543. -- Happily, this is the result that we expect to obtain.
  1544. -- The function strictIterate is defined below.  It is similar to the
  1545. -- standard iterate function except that it forces the evaluation of
  1546. -- each element in the list produced (except possibly the first).
  1547. -- Had we instead tried to evaluate:
  1548. --   iterate min_stand_test 1 !! 10000
  1549. -- Hugs would have first constructed the expression graph:
  1550. --   min_stand_test (min_stand_test (... (min_stand_test 1) ...))
  1551. -- in which the min_stand_test function is applied 10000 times to 1
  1552. -- and then attempted to evaluate this.  In either case, you'd need a
  1553. -- large heap to represent the complete expression and a large stack so
  1554. -- that you could handle 10000 levels of function calling.  Most standard
  1555. -- configurations of Hugs aren't set up with sufficiently large defaults
  1556. -- to make this possible, so the most likely outcome would be a runtime
  1557. -- error of one kind or another!
  1558. strictIterate    :: (a -> a) -> a -> [a]
  1559. strictIterate f x = x : (strictIterate f $! f x)
  1560. -------------------------------------------------------------------------------
  1561. -- Some comments and code from:
  1562. -- Random Number Generators: Good ones are hard to find
  1563. --    Stephen K Park & Keith W Miller
  1564. --    Communications of the ACM, Oct 88, Vol 31 No 10 1192 - 1201
  1565. -- Minimum standard random number generator implementations
  1566. -- This version of Random will be correct if reals are represented
  1567. -- with a 46-bit or larger mantissa (excluding the sign bit).
  1568. -- For example, this version will be correct on all systems that support
  1569. -- the IEEE 64-bit real arithmetic standard since the mantissa in that case
  1570. -- is 53-bits.
  1571. -- ... from page 1195 upper right quadrant
  1572. -- var seed : real;
  1573. -- ...
  1574. -- function Random : real;
  1575. --     (* Real Version 1 *)
  1576. -- const
  1577. --    a = 16807.0;
  1578. --    m = 2147483647.0;
  1579. -- var
  1580. --    temp : real;
  1581. -- begin
  1582. --    temp := a * seed;
  1583. --    seed :=
  1584. --       temp - m * Trunc(temp / m);
  1585. --    Random := seed / m;
  1586. -- end;
  1587. -- ... from page 1195 lower right quadrant, variant by L. Schrage, 1979, 1983
  1588. -- var seed : integer;
  1589. -- ...
  1590. -- function Random : real;
  1591. --     (* Integer Version 2 *)
  1592. -- const
  1593. --    a = 16807;
  1594. --    m = 2147483647;
  1595. --    q = 127773;    (* m div a *)
  1596. --    r = 2836;    (* m mod a *)
  1597. -- var
  1598. --    lo, hi, test : integer;
  1599. -- begin
  1600. --    hi := seed div q;
  1601. --    lo := seed mod q;
  1602. --    test := a * lo - r * hi;
  1603. --    if test > 0 then
  1604. --       seed := test
  1605. --    else
  1606. --       seed := test + m;
  1607. --    Random := seed / m;
  1608. -- end;
  1609. -- From page 1195 lower left quadrant
  1610. -- seed := 1;
  1611. -- for n := 1 to 10000 do
  1612. --    u := Random;
  1613. -- Writeln('The current value of seed is : ', seed);
  1614. -- (* Expect 1043618065 *)
  1615. -------------------------------------------------------------------------------
  1616. -----------------------------------------------------------------------------
  1617. -- Mersenne.hs                                                 Mark P. Jones
  1618. --                                                          February 7, 1995
  1619. -- Here is a Hugs program to calculate the 30th Mersenne prime using the
  1620. -- builtin bignum arithmetic.
  1621. -- For those who don't know, a Mersenne prime is a prime number of the form:
  1622. --                               n
  1623. --                              2  - 1
  1624. -- The first few Mersenne primes are for:
  1625. --   n = 2, 3, 5, 7, 13, 17, 19, 31, 61, 89, 107, 127, 521, 607, 1279, 2203,
  1626. --       2281, 3217, 4253, 4423, ...
  1627. -- The thirtieth Mersenne prime occurs for n = 216,091.  In decimal
  1628. -- notation, this number has 65050 digits.
  1629. -- A little story about me and this number:
  1630. -- As I recall, this fact was discovered nearly ten years ago.  I
  1631. -- wrote an Intel 8080 assembly language program to calculate this
  1632. -- number.  Running on a Z80A based machine, it used a 32K array --
  1633. -- more than half of the total memory available -- with each byte
  1634. -- containing two binary coded decimal digits.   The array was
  1635. -- initialized to contain the number 1 and a loop was used to double
  1636. -- the value in the array a total of 216091 times, before the final 1
  1637. -- was subtracted.  Using the timings for individual Z80A
  1638. -- instructions, I estimated the running time for the program and,
  1639. -- when it finished on Thursday April 17, 1986, after running for a
  1640. -- little under 18 hours, I was delighted that my predictions were
  1641. -- within 10 seconds of the actual running time.  Of course, now I
  1642. -- understand a little more about error bounds and tolerances, I realize
  1643. -- that this was more by luck than judgement, but at the time, I was
  1644. -- delighted!  I don't remember if I knew the O(log n) algorithm for
  1645. -- exponentials at the time, but it wouldn't have been easy to apply
  1646. -- with the limited amount of memory at my disposal back then.  (Of
  1647. -- course, it wouldn't have been O(log n) in practice either because
  1648. -- the individual multiplications can hardly be considered O(1)!)
  1649. -- Now I can run this program, written in Hugs (or to be accurate,
  1650. -- written using calls to Hugs primitive functions), on the machine
  1651. -- on my desk while I'm editing files and reading mail in other
  1652. -- windows, and it still finishes in under 7 minutes.  Of course,
  1653. -- it did use 6M of heap (though not all at the same time), but
  1654. -- who's counting?  :-)
  1655. module Mersenne where
  1656. import List( genericLength )
  1657. p         :: Integer
  1658. p          = 2 ^ 216091 - 1
  1659. digitsInP :: Integer
  1660. digitsInP  = genericLength (show p)
  1661. -- Here are the smaller Mersenne primes listed above:
  1662. smallMPindices :: [Int]
  1663. smallMPindices  = [2, 3, 5, 7, 13, 17, 19, 31, 61, 89, 107, 127,
  1664.                    521, 607, 1279, 2203, 2281, 3217, 4253, 4423 ]
  1665. smallMP  :: [Integer]
  1666. smallMP   = [ 2 ^ n - 1 | n <- smallMPindices ]
  1667. -- Does an incremental algorithm buy us anything?  Not much, it would seem!
  1668. smallMP' :: [Integer]
  1669. smallMP'  = map (subtract 1) (scanl (\x i -> x * 2^i) (2^n) ns)
  1670.             where (n:ns) = zipWith (-) smallMPindices (0:smallMPindices)
  1671. -----------------------------------------------------------------------------
  1672. -- Some simple Hugs programs for manipulating matrices.
  1673. module Matrix where
  1674. import List
  1675. type Matrix k = [Row k]          -- matrix represented by a list of its rows
  1676. type Row k    = [k]              -- a row represented by a list of literals
  1677. -- General utility functions:
  1678. shapeMat    :: Matrix k -> (Int, Int)
  1679. shapeMat mat = (rows mat, cols mat)
  1680. rows        :: Matrix k -> Int
  1681. rows mat     = length mat
  1682. cols        :: Matrix k -> Int
  1683. cols mat     = length (head mat)
  1684. idMat       :: Int -> Matrix Int
  1685. idMat 0      = []
  1686. idMat (n+1)  = [1:replicate n 0] ++ map (0:) (idMat n)
  1687. -- Matrix multiplication:
  1688. multiplyMat                     :: Matrix Int -> Matrix Int -> Matrix Int
  1689. multiplyMat a b | cols a==rows b = [[row `dot` col | col<-b'] | row<-a]
  1690.                 | otherwise      = error "incompatible matrices"
  1691.                  where v `dot` w = sum (zipWith (*) v w)
  1692.                        b'        = transpose b
  1693. -- An attempt to implement the standard algorithm for converting a matrix
  1694. -- to echelon form...
  1695. echelon   :: Matrix Int -> Matrix Int
  1696. echelon rs
  1697.     | null rs || null (head rs) = rs
  1698.     | null rs2                  = map (0:) (echelon (map tail rs))
  1699.     | otherwise                 = piv : map (0:) (echelon rs')
  1700.       where rs'            = map (adjust piv) (rs1++rs3)
  1701.             (rs1,rs2)      = span leadZero rs
  1702.             leadZero (n:_) = n==0
  1703.             (piv:rs3)      = rs2
  1704. -- To find the echelon form of a matrix represented by a list of rows rs:
  1705. -- {first line in definition of echelon}:
  1706. --  If either the number of rows or the number of columns in the matrix
  1707. --  is zero (i.e. if null rs || null (head rs)), then the matrix is
  1708. --  already in echelon form.
  1709. -- {definition of rs1, rs2, leadZero in where clause}:
  1710. --  Otherwise, split the matrix into two submatrices rs1 and rs2 such that
  1711. --  rs1 ++ rs2 == rs  and all of the rows in rs1 begin with a zero.
  1712. -- {second line in definition of echelon}:
  1713. --  If rs2 is empty (i.e. if null rs2) then every row begins with a zero
  1714. --  and the echelon form of rs can be found by adding a zero on to the
  1715. --  front of each row in the echelon form of (map tail rs).
  1716. -- {Third line in definition of echelon, and definition of piv, rs3}:
  1717. --  Otherwise, the first row of rs2 (denoted piv) contains a non-zero
  1718. --  leading coefficient.  After moving this row to the top of the matrix
  1719. --  the original matrix becomes  piv:(rs1++rs3).
  1720. --  By subtracting suitable multiples of piv from (suitable multiples of)
  1721. --  each row in (rs1++rs3) {see definition of adjust below}, we obtain a
  1722. --  matrix of the form:
  1723. --          <----- piv ------>
  1724. --          __________________
  1725. --          0  |
  1726. --          .  |
  1727. --          .  |      rs'        where rs' = map (adjust piv) (rs1++rs3)
  1728. --          .  |
  1729. --          0  |
  1730. --  whose echelon form is  piv : map (0:) (echelon rs').
  1731. adjust              :: Num a => Row a -> Row a -> Row a
  1732. adjust (m:ms) (n:ns) = zipWith (-) (map (n*) ms) (map (m*) ns)
  1733. -- A more specialised version of this, for matrices of integers, uses the
  1734. -- greatest common divisor function gcd in an attempt to try and avoid
  1735. -- result matrices with very large coefficients:
  1736. -- (I'm not sure this is really worth the trouble!)
  1737. adjust'              :: Row Int -> Row Int -> Row Int
  1738. adjust' (m:ms) (n:ns) = if g==0 then ns
  1739.                                 else zipWith (\x y -> b*y - a*x) ms ns
  1740.                         where g = gcd m n
  1741.                               a = n `div` g
  1742.                               b = m `div` g
  1743. -- end!!
  1744. Literate comments
  1745. -----------------
  1746. [This file contains an executable version of a program for processing
  1747. literate scripts.  The original version of this program appeared in
  1748. Appendix C of the Haskell report, version 1.2.  This version has been
  1749. updated for Haskell 1.3.]
  1750. > module Literate where
  1751. > import System(getArgs)
  1752. Many Haskell implementations support the ``literate comment''
  1753. convention, first developed by Richard Bird and Philip Wadler for
  1754. Orwell, and inspired in turn by Donald Knuth's ``literate programming''.
  1755. The convention is not part of the Haskell language, but it is
  1756. supported by the implementations known to us (Chalmers, Glasgow,
  1757. and Yale).
  1758. The literate style encourages comments by making them the default.
  1759. A line in which ">" is the first character is treated as part of
  1760. the program; all other lines are comment.  Within the program part,
  1761. the usual "--" and "{- -}" comment conventions may still be used.
  1762. To capture some cases where one omits an ">" by mistake, it is an
  1763. error for a program line to appear adjacent to a non-blank comment
  1764. line, where a line is taken as blank if it consists only of
  1765. whitespace.
  1766. By convention, the style of comment is indicated by the file
  1767. extension, with ".hs" indicating a usual Haskell file, and ".lhs"
  1768. indicating a literate Haskell file.
  1769. To make this precise, we present a literate Haskell program to
  1770. convert literate programs.  The program expects a single name "file"
  1771. on the command line, reads "file.lhs", and either writes the
  1772. corresponding program to "file.hs" or prints error messages to
  1773. "stderr".
  1774. Each of the lines in a literate script is a program line, a blank
  1775. line, or a comment line.  In the first case, the text is kept with
  1776. the line.
  1777. > data Classified  =  Program String | Blank | Comment
  1778. In a literate program, program lines begins with a `>' character,
  1779. blank lines contain only whitespace, and all other lines are comment
  1780. lines.
  1781. > classify                           ::  String -> Classified
  1782. > classify ('>':s)            =   Program s
  1783. > classify s  |  all isSpace s        =   Blank
  1784. > classify s  |  otherwise        =   Comment
  1785. In the corresponding program, program lines have the leading `>'
  1786. replaced by a leading space, to preserve tab alignments.
  1787. > unclassify                        ::  Classified -> String
  1788. > unclassify (Program s)        =   " " ++ s
  1789. > unclassify Blank            =   ""
  1790. > unclassify Comment            =   ""
  1791. Process a literate program into error messages (if any) and the
  1792. corresponding non-literate program.
  1793. > process       ::  String -> (String, String)
  1794. > process lhs    =   (es, hs)
  1795. >        where    cs  =  map classify (lines lhs)
  1796. >            es  =  unlines (errors cs)
  1797. >            hs  =  unlines (map unclassify cs)
  1798. Check that each program line is not adjacent to a comment line.
  1799. > errors    ::  [Classified] -> [String]
  1800. > errors cs    =   concat (zipWith3 adjacent [1..] cs (tail cs))
  1801. Given a line number and a pair of adjacent lines, generate a list
  1802. of error messages, which will contain either one entry or none.
  1803. > adjacent    ::  Int -> Classified -> Classified -> [String]
  1804. > adjacent n (Program _) Comment  =  [message n "program" "comment"]
  1805. > adjacent n Comment (Program _)  =  [message n "comment" "program"]
  1806. > adjacent n this           next  =  []
  1807. > message n p c = "Line "++show n++": "++p++" line before "++c++" line."
  1808. The main program gets name "file", reads "file.lhs", and either
  1809. writes the corresponding program to "file.hs" or prints error
  1810. messages on "stdout".
  1811. > main    :: IO ()
  1812. > main     = do strs <- getArgs
  1813. >               case strs of
  1814. >                 [str] -> delit str
  1815. >                 _     -> ioError (userError "Too many or too few arguments")
  1816. > delit f  = do lhs <- readFile (f ++ ".lhs")
  1817. >               case (process lhs) of
  1818. >              ([],hs) -> writeFile (f ++ ".hs") hs
  1819. >              (es,_)  -> putStr es
  1820. ------------------------------------------------------------------------------
  1821. -- A version of the graph algorithms described in:
  1822. -- ``Lazy Depth-First Search and Linear Graph Algorithms in Haskell''
  1823. --   by David King and John Launchbury
  1824. -- Also included is some additional code for printing tree structures ...
  1825. -- Suitable for use with Hugs 98.
  1826. ------------------------------------------------------------------------------
  1827. module Ldfs
  1828.     ( figure4, figure5, figure7
  1829.     ) where
  1830. import Array
  1831. import List
  1832. import LazyST
  1833. type Vertex  = Char
  1834. -- Representing graphs:
  1835. type Table a = Array Vertex a
  1836. type Graph   = Table [Vertex]
  1837. vertices :: Graph -> [Vertex]
  1838. vertices  = indices
  1839. type Edge = (Vertex, Vertex)
  1840. edges    :: Graph -> [Edge]
  1841. edges g   = [ (v, w) | v <- vertices g, w <- g!v ]
  1842. mapT    :: (Vertex -> a -> b) -> Table a -> Table b
  1843. mapT f t = array (bounds t) [ (v, f v (t!v)) | v <- indices t ]
  1844. type Bounds = (Vertex, Vertex)
  1845. outdegree :: Graph -> Table Int
  1846. outdegree  = mapT numEdges
  1847.              where numEdges v ws = length ws
  1848. buildG :: Bounds -> [Edge] -> Graph
  1849. buildG  = accumArray (flip (:)) []
  1850. graph = buildG ('a','j')
  1851.          (reverse
  1852.           [ ('a', 'b'),  ('a', 'f'),  ('b', 'c'),
  1853.             ('b', 'e'),  ('c', 'a'),  ('c', 'd'),
  1854.             ('e', 'd'),  ('g', 'h'),  ('g', 'j'),
  1855.             ('h', 'f'),  ('h', 'i'),  ('h', 'j') ]
  1856.          )
  1857. transposeG  :: Graph -> Graph
  1858. transposeG g = buildG (bounds g) (reverseE g)
  1859. reverseE    :: Graph -> [Edge]
  1860. reverseE g   = [ (w, v) | (v, w) <- edges g ]
  1861. indegree :: Graph -> Table Int
  1862. indegree  = outdegree . transposeG
  1863. -- Depth-first search
  1864. -- Specification and implementation of depth-first search:
  1865. data Tree a   = Node a (Forest a) deriving Show
  1866. type Forest a = [Tree a]
  1867. dff          :: Graph -> Forest Vertex
  1868. dff g         = dfs g (vertices g)
  1869. dfs          :: Graph -> [Vertex] -> Forest Vertex
  1870. dfs g vs      = prune (bounds g) (map (generate g) vs)
  1871. generate     :: Graph -> Vertex -> Tree Vertex
  1872. generate g v  = Node v (map (generate g) (g!v))
  1873. type Set s    = STArray s Vertex Bool
  1874. mkEmpty      :: Bounds -> ST s (Set s)
  1875. mkEmpty bnds  = newSTArray bnds False
  1876. contains     :: Set s -> Vertex -> ST s Bool
  1877. contains m v  = readSTArray m v
  1878. include      :: Set s -> Vertex -> ST s ()
  1879. include m v   = writeSTArray m v True
  1880. prune        :: Bounds -> Forest Vertex -> Forest Vertex
  1881. prune bnds ts = runST (mkEmpty bnds >>= \m ->
  1882.                        chop m ts)
  1883. chop         :: Set s -> Forest Vertex -> ST s (Forest Vertex)
  1884. chop m []     = return []
  1885. chop m (Node v ts : us)
  1886.               = contains m v >>= \visited ->
  1887.                 if visited then
  1888.                   chop m us
  1889.                 else
  1890.                   include m v >>= \_  ->
  1891.                   chop m ts   >>= \as ->
  1892.                   chop m us   >>= \bs ->
  1893.                   return (Node v as : bs)
  1894. -- Depth-first search algorithms
  1895. -- Algorithm 1: depth first search numbering
  1896. preorder            :: Tree a -> [a]
  1897. preorder (Node a ts) = [a] ++ preorderF ts
  1898. preorderF           :: Forest a -> [a]
  1899. preorderF ts         = concat (map preorder ts)
  1900. preOrd :: Graph -> [Vertex]
  1901. preOrd  = preorderF . dff
  1902. tabulate        :: Bounds -> [Vertex] -> Table Int
  1903. tabulate bnds vs = array bnds (zip vs [1..])
  1904. preArr          :: Bounds -> Forest Vertex -> Table Int
  1905. preArr bnds      = tabulate bnds . preorderF
  1906. -- Algorithm 2: topological sorting
  1907. postorder :: Tree a -> [a]
  1908. postorder (Node a ts) = postorderF ts ++ [a]
  1909. postorderF   :: Forest a -> [a]
  1910. postorderF ts = concat (map postorder ts)
  1911. postOrd      :: Graph -> [Vertex]
  1912. postOrd       = postorderF . dff
  1913. topSort      :: Graph -> [Vertex]
  1914. topSort       = reverse . postOrd
  1915. -- Algorithm 3: connected components
  1916. components   :: Graph -> Forest Vertex
  1917. components    = dff . undirected
  1918. undirected   :: Graph -> Graph
  1919. undirected g  = buildG (bounds g) (edges g ++ reverseE g)
  1920. -- Algorithm 4: strongly connected components
  1921. scc          :: Graph -> Forest Vertex
  1922. scc g         = dfs (transposeG g) (reverse (postOrd g))
  1923. scc'         :: Graph -> Forest Vertex
  1924. scc' g        = dfs g (reverse (postOrd (transposeG g)))
  1925. -- Algorithm 5: Classifying edges
  1926. tree              :: Bounds -> Forest Vertex -> Graph
  1927. tree bnds ts       = buildG bnds (concat (map flat ts))
  1928.  where flat (Node v rs) = [ (v, w) | Node w us <- ts ] ++
  1929.                           concat (map flat ts)
  1930. back              :: Graph -> Table Int -> Graph
  1931. back g post        = mapT select g
  1932.  where select v ws = [ w | w <- ws, post!v < post!w ]
  1933. cross             :: Graph -> Table Int -> Table Int -> Graph
  1934. cross g pre post   = mapT select g
  1935.  where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
  1936. forward           :: Graph -> Graph -> Table Int -> Graph
  1937. forward g tree pre = mapT select g
  1938.  where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
  1939. -- Algorithm 6: Finding reachable vertices
  1940. reachable    :: Graph -> Vertex -> [Vertex]
  1941. reachable g v = preorderF (dfs g [v])
  1942. path         :: Graph -> Vertex -> Vertex -> Bool
  1943. path g v w    = w `elem` (reachable g v)
  1944. -- Algorithm 7: Biconnected components
  1945. bcc :: Graph -> Forest [Vertex]
  1946. bcc g = (concat . map bicomps . map (label g dnum)) forest
  1947.  where forest = dff g
  1948.        dnum   = preArr (bounds g) forest
  1949. label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
  1950. label g dnum (Node v ts) = Node (v,dnum!v,lv) us
  1951.  where us = map (label g dnum) ts
  1952.        lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
  1953.                      ++ [lu | Node (u,du,lu) xs <- us])
  1954. bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
  1955. bicomps (Node (v,dv,lv) ts)
  1956.       = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
  1957. collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
  1958. collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
  1959.  where collected = map collect ts
  1960.        vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
  1961.        cs = concat [ if lw<dv then us else [Node (v:ws) us]
  1962.                         | (lw, Node ws us) <- collected ]
  1963. figure4 = buildG ('a','i') (vs ++ reverse [ (v, w) | (w, v) <- vs ])
  1964.           where vs = [ ('b', 'a'), ('e', 'a'), ('c', 'b'),
  1965.                        ('d', 'c'), ('b', 'd'), ('f', 'e'),
  1966.                        ('h', 'e'), ('g', 'f'), ('e', 'g'),
  1967.                        ('i', 'h'), ('a', 'i'), ('h', 'a') ]
  1968. figure5 = showForest (map (label figure4 dnum) f)
  1969.           where f    = dff figure4
  1970.                 dnum = preArr (bounds figure4) f
  1971. figure7 = showForest (bcc figure4)
  1972. -- Utility functions for drawing trees and forests:
  1973. showTree :: Show a => Tree a -> String
  1974. showTree  = drawTree . mapTree show
  1975. showForest :: Show a => Forest a -> String
  1976. showForest  = unlines . map showTree
  1977. mapTree              :: (a -> b) -> (Tree a -> Tree b)
  1978. mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
  1979. drawTree        :: Tree String -> String
  1980. drawTree         = unlines . draw
  1981. draw (Node x ts) = grp this (space (length this)) (stLoop ts)
  1982.  where this          = s1 ++ x ++ " "
  1983.        space n       = take n (repeat ' ')
  1984.        stLoop []     = [""]
  1985.        stLoop [t]    = grp s2 "  " (draw t)
  1986.        stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
  1987.        rsLoop [t]    = grp s5 "  " (draw t)
  1988.        rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
  1989.        grp fst rst   = zipWith (++) (fst:repeat rst)
  1990.        [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
  1991. ------------------------------------------------------------------------------
  1992. -- This file contains a Hugs implementation of the programs described in:
  1993. -- Mark P. Jones, Computing with lattices: An application of type classes,
  1994. -- Journal of Functional Programming, Volume 2, Number 4, Oct 1992.
  1995. module Lattice where
  1996. class Eq a => Lattice a where           -- A type class representing lattices
  1997.     bottom, top :: a
  1998.     meet, join  :: a -> a -> a
  1999.     lt          :: a -> a -> Bool
  2000.     x `lt` y     = (x `join` y) == y
  2001. instance Lattice Bool where             -- Simple instances of Lattice
  2002.     bottom = False
  2003.     top    = True
  2004.     meet   = (&&)
  2005.     join   = (||)
  2006. instance (Lattice a, Lattice b) => Lattice (a,b) where
  2007.     bottom             = (bottom,bottom)
  2008.     top                = (top,top)
  2009.     (x,y) `meet` (u,v) = (x `meet` u, y `meet` v)
  2010.     (x,y) `join` (u,v) = (x `join` u, y `join` v)
  2011. -- Defining the least fixed point operator:
  2012. fix f          = firstRepeat (iterate f bottom)
  2013. firstRepeat xs = head [ x | (x,y) <- zip xs (tail xs), x==y ]
  2014. -- Maximum and minimum frontiers:
  2015. data Minf a = Minf [a]
  2016. data Maxf a = Maxf [a]
  2017. instance Eq a => Eq (Minf a) where                -- Equality on Frontiers
  2018.     (Minf xs) == (Minf ys)  = setEquals xs ys
  2019. instance Eq a => Eq (Maxf a) where
  2020.     (Maxf xs) == (Maxf ys)  = setEquals xs ys
  2021. xs `subset` ys  = all (`elem` ys) xs
  2022. setEquals xs ys =  xs `subset` ys  &&  ys `subset` xs
  2023. instance Lattice a => Lattice (Minf a) where      -- Lattice structure
  2024.     bottom                     = Minf []
  2025.     top                        = Minf [bottom]
  2026.     (Minf xs) `meet` (Minf ys) = minimal [ x`join`y | x<-xs, y<-ys ]
  2027.     (Minf xs) `join` (Minf ys) = minimal (xs++ys)
  2028. instance Lattice a => Lattice (Maxf a) where
  2029.     bottom                     = Maxf []
  2030.     top                        = Maxf [top]
  2031.     (Maxf xs) `meet` (Maxf ys) = maximal [ x`meet`y | x<-xs, y<-ys ]
  2032.     (Maxf xs) `join` (Maxf ys) = maximal (xs++ys)
  2033. -- Find maximal elements of a list xs with respect to partial order po:
  2034. maximalWrt po = loop []
  2035.  where loop xs []                 = xs
  2036.        loop xs (y:ys)
  2037.             | any (po y) (xs++ys) = loop xs ys
  2038.             | otherwise           = loop (y:xs) ys
  2039. minimal :: Lattice a => [a] -> Minf a       -- list to minimum frontier
  2040. minimal  = Minf . maximalWrt (flip lt)
  2041. maximal :: Lattice a => [a] -> Maxf a       -- list to maximum frontier
  2042. maximal  = Maxf . maximalWrt lt
  2043. -- A representation for functions of type Lattice a => a -> Bool:
  2044. data Fn a = Fn (Minf a) (Maxf a)
  2045. instance Eq a => Eq (Fn a) where
  2046.     Fn f1 f0 == Fn g1 g0  =  f1==g1 -- && f0==g0
  2047. instance Lattice a => Lattice (Fn a) where
  2048.     bottom               = Fn bottom top
  2049.     top                  = Fn top bottom
  2050.     Fn u l `meet` Fn v m = Fn (u `meet` v) (l `join` m)
  2051.     Fn u l `join` Fn v m = Fn (u `join` v) (l `meet` m)
  2052. -- Navigable lattices:
  2053. class Lattice a => Navigable a where
  2054.     succs :: a -> Minf a
  2055.     preds :: a -> Maxf a
  2056. maxComp :: Navigable a => [a] -> Maxf a   -- implementation of complement
  2057. maxComp  = foldr meet top . map preds
  2058. minComp :: Navigable a => [a] -> Minf a
  2059. minComp  = foldr meet top . map succs
  2060. instance Navigable Bool where             -- instances of Navigable
  2061.     succs False = Minf [True]
  2062.     succs True  = Minf []
  2063.     preds False = Maxf []
  2064.     preds True  = Maxf [False]
  2065. minfOf (Minf xs) = xs
  2066. maxfOf (Maxf xs) = xs
  2067. instance (Navigable a, Navigable b) => Navigable (a,b) where
  2068.     succs (x,y) = Minf ([(sx,bottom) | sx <- minfOf (succs x)] ++
  2069.                         [(bottom,sy) | sy <- minfOf (succs y)])
  2070.     preds (x,y) = Maxf ([(px,top)    | px <- maxfOf (preds x)] ++
  2071.                         [(top,py)    | py <- maxfOf (preds y)])
  2072. instance Navigable a => Navigable (Fn a) where
  2073.     succs (Fn f1 f0) = Minf [Fn (Minf [y]) (preds y) | y <- maxfOf f0]
  2074.     preds (Fn f1 f0) = Maxf [Fn (succs x) (Maxf [x]) | x <- minfOf f1]
  2075. -- Upwards and downwards closure operators:
  2076. upwards (Minf [])         = []
  2077. upwards ts@(Minf (t:_))   = t : upwards (ts `meet` succs t)
  2078. downwards (Maxf [])       = []
  2079. downwards ts@(Maxf (t:_)) = t : downwards (ts `meet` preds t)
  2080. elements :: Navigable a => [a]    -- enumerate all elements in lattice
  2081. elements  = upwards top
  2082. -----------------------------------------------------------------------------
  2083. -- Utility functions, for compatibility with Gofer prelude & Bird and Wadler:
  2084. -- Suitable for use with Hugs 98.
  2085. -----------------------------------------------------------------------------
  2086. module Gofer where
  2087. -- String formatting: -------------------------------------------------------
  2088. ljustify, rjustify, cjustify :: Int -> String -> String
  2089. ljustify n s                  = s ++ space (n - length s)
  2090. rjustify n s                  = space (n - length s) ++ s
  2091. cjustify n s                  = space halfm ++ s ++ space (m - halfm)
  2092.                                 where m     = n - length s
  2093.                                       halfm = m `div` 2
  2094. space                        :: Int -> String
  2095. space n                       = copy n ' '
  2096. layn        :: [String] -> String
  2097. layn         = lay 1 where lay _ []     = []
  2098.                            lay n (x:xs) = rjustify 4 (show n) ++ ") "
  2099.                                            ++ x ++ "\n" ++ lay (n+1) xs
  2100. -- Misc. list utilities: ----------------------------------------------------
  2101. copy                :: Int -> a -> [a]
  2102. copy n x             = take n (repeat x)
  2103. merge               :: Ord a => [a] -> [a] -> [a]
  2104. merge []     ys      = ys
  2105. merge xs     []      = xs
  2106. merge (x:xs) (y:ys)
  2107.         | x <= y     = x : merge xs (y:ys)
  2108.         | otherwise  = y : merge (x:xs) ys
  2109. sort                :: Ord a => [a] -> [a]
  2110. sort                 = foldr insert []
  2111. insert              :: Ord a => a -> [a] -> [a]
  2112. insert x []          = [x]
  2113. insert x (y:ys)
  2114.         | x <= y     = x:y:ys
  2115.         | otherwise  = y:insert x ys
  2116. -- Other functions: ---------------------------------------------------------
  2117. fst3                :: (a,b,c) -> a
  2118. fst3 (x,_,_)         = x
  2119. snd3                :: (a,b,c) -> b
  2120. snd3 (_,x,_)         = x
  2121. thd3                :: (a,b,c) -> c
  2122. thd3 (_,_,x)         = x
  2123. -----------------------------------------------------------------------------
  2124. module FastSort where
  2125. import Gofer
  2126. {- list sorting: see L.C.Paulson, ML for the working programmer, Cambidge, p100
  2127. -- The list is split into ascending chunks which are then merged in pairs.
  2128. samsort l = sorting [] 0 l
  2129.   where    sorting ls k []        = head(mergepairs ls 0)
  2130.     sorting    ls k (x:xs)    = sorting (mergepairs (run:ls) kinc) kinc tl
  2131.       where    (run, tl)    = nextrun [x] xs
  2132.         kinc        = k+1
  2133.     nextrun run []        = (reverse run, [])
  2134.     nextrun    rs@(r:_) xl@(x:xs)
  2135.         | x<r        = (reverse rs, xl)
  2136.         | otherwise    = nextrun (x:rs) xs
  2137.     mergepairs [l] _ = [l]
  2138.     mergepairs lx@(l1:l2:ls) k
  2139.         | k`mod`2 == 1    = lx
  2140.         | otherwise    = mergepairs((merge l1 l2):ls) (k/2)
  2141. -- this mergesort uses a partioning mechanism like quicksort to build
  2142. -- longer initial sequences. It also uses a non-counting mergePairs.
  2143. -- Bob Buckley 30-MAR-93 (Bob.Buckley@levels.unisa.edu.au)
  2144. msort xs = mergePhase (runPhase xs)
  2145.   where    mergePhase [x]        = x
  2146.     mergePhase [x,y]    = merge x y    -- redundant case
  2147.     mergePhase l        = mergePhase (mergePairs l)
  2148.     mergePairs [x1,x2]    = [merge x1 x2]    -- redundant case
  2149.     mergePairs (x1:x2:xs)    = merge x1 x2 : mergePairs xs
  2150.     mergePairs l        = l        -- note: l=[] or l=[_]
  2151.     runPhase []    = [[]]
  2152.     runPhase (e:es) = takeAsc [e] es
  2153.     takeAsc asc []    = [reverse asc]
  2154.     takeAsc xs@(x:_) zs@(z:zr)
  2155.         | x<=z        = takeAsc (z:xs) zr
  2156.         | otherwise    = takeDec xs [z] zr
  2157.     takeDec asc dec []    = [merge (reverse asc) dec]
  2158.     takeDec xs@(x:_) ys@(y:_) zs@(z:zr)
  2159.         | z<y        = takeDec xs (z:ys) zr
  2160.         | x<=z        = takeDec (z:xs) ys zr
  2161.         | otherwise    = merge (reverse xs) ys : runPhase zs
  2162. -----------------------------------------------------------------------------
  2163. -- Parsing simple arithmetic expressions using combinators
  2164. -- Mark P. Jones, April 4, 1993
  2165. module Expr where
  2166. import Char( digitToInt )
  2167. infixr 6 &&&
  2168. infixl 5 >>>
  2169. infixr 4 |||
  2170. type Parser a = String -> [(a,String)]
  2171. result       :: a -> Parser a
  2172. result x s    = [(x,s)]
  2173. (|||)        :: Parser a -> Parser a -> Parser a
  2174. (p ||| q) s   = p s ++ q s
  2175. (&&&)        :: Parser a -> Parser b -> Parser (a,b)
  2176. (p &&& q) s   = [ ((x,y),s1) | (x,s0) <- p s, (y,s1) <- q s0 ]
  2177. (>>>)        :: Parser a -> (a -> b) -> Parser b
  2178. (p >>> f) s   = [ (f x, s0) | (x,s0) <- p s ]
  2179. many         :: Parser a -> Parser [a]
  2180. many p        = q where q = p &&& q >>> (\(x,xs) -> x:xs)
  2181.                             |||
  2182.                             result []
  2183. many1        :: Parser a -> Parser [a]
  2184. many1 p       = p &&& many p >>> (\(x,xs) -> x:xs)
  2185. sat          :: (Char -> Bool) -> Parser Char
  2186. sat p (c:cs)
  2187.         | p c = [ (c,cs) ]
  2188. sat p cs      = []
  2189. tok          :: String -> Parser String
  2190. tok s cs      = loop s cs
  2191.                 where loop ""     cs            = [(s,cs)]
  2192.                       loop (s:ss) (c:cs) | s==c = loop ss cs
  2193.                       loop _      _             = []
  2194. digit        :: Parser Int
  2195. digit         = sat isDigit >>> digitToInt
  2196. number       :: Parser Int
  2197. number        = many1 digit >>> foldl (\a x -> 10*a+x) 0
  2198. -- Original version:
  2199. -- eval "1"          (540 reductions, 933 cells)
  2200. -- eval "(1)"        (5555 reductions, 8832 cells)
  2201. -- eval "((1))"      (50587 reductions, 80354 cells, 1 garbage collection)
  2202. -- eval "(((1)))"    (455907 reductions, 724061 cells, 7 garbage collections)
  2203. -- eval "1+2+3+4+5"  (1296 reductions, 2185 cells)
  2204. -- eval "1+"         (828 reductions, 1227 cells)
  2205. expr   = term &&& tok "+" &&& expr >>> (\(x,(p,y)) -> x + y)  |||
  2206.          term &&& tok "-" &&& expr >>> (\(x,(m,y)) -> x - y)  |||
  2207.          term
  2208. term   = atom &&& tok "*" &&& term >>> (\(x,(t,y)) -> x * y)  |||
  2209.          atom &&& tok "/" &&& term >>> (\(x,(d,y)) -> x / y)  |||
  2210.          atom
  2211. atom   = tok "-" &&& number >>> (\(u,n) -> -n)                |||
  2212.          number                                               |||
  2213.          tok "(" &&& expr &&& tok ")" >>> (\(o,(n,c)) -> n)
  2214. -- Putting the initial prefix parser first:
  2215. -- eval "1"           (96 reductions, 168 cells)
  2216. -- eval "(1)"         (191 reductions, 335 cells)
  2217. -- eval "((1))"       (283 reductions, 498 cells)
  2218. -- eval "(((1)))"     (375 reductions, 661 cells)
  2219. -- eval "1+2+3+4+5"   (472 reductions, 905 cells)
  2220. -- eval "1+"          (124 reductions, 251 cells)
  2221. expr   = term &&& (tok "+" &&& expr >>> (\(p,y) -> (+y))       |||
  2222.                    tok "-" &&& expr >>> (\(m,y) -> subtract y) |||
  2223.                    result id) >>> \(n,f) -> f n
  2224. term   = atom &&& (tok "*" &&& term >>> (\(t,y) -> (*y))       |||
  2225.                    tok "/" &&& term >>> (\(d,y) -> (`div` y))  |||
  2226.                    result id) >>> \(n,f) -> f n
  2227. eval s = case expr s of ((x,""):_) -> x
  2228.                         _          -> error "Syntax error in input"
  2229. -- Some examples of functional programming for Hugs
  2230. module Examples where
  2231. import Gofer
  2232. -- Factorials:
  2233. fact n = product [1..n]                     -- a simple definition
  2234. fac n  = if n==0 then 1 else n * fac (n-1)  -- a recursive definition
  2235. fac' 0 = 1                                  -- using two equations
  2236. fac' n = n * fac (n-1)
  2237. facts, facts' :: (Enum a, Num a) => [a]
  2238. facts          = scanl (*) 1 [1..]            -- infinite list of factorials
  2239. facts'         = 1 : zipWith (*) facts' [1..] -- another way of doing it
  2240. facFix :: Num a => a -> a
  2241. facFix = fixedPt f                          -- using a fixed point combinator
  2242.          where  f g 0       = 1             -- overlapping patterns
  2243.                 f g n       = n * g (n-1)
  2244.                 fixedPt f = g where g = f g -- fixed point combinator
  2245. facCase :: Integral a => a -> a
  2246. facCase  = \n -> case n of
  2247.                    0     ->  1
  2248.                    (m+1) -> (m+1) * facCase m
  2249. -- Fibonacci numbers:
  2250. fib 0     = 0                               -- using pattern matching:
  2251. fib 1     = 1                               -- base cases...
  2252. fib (n+2) = fib n + fib (n+1)               -- recursive case
  2253. fastFib n = fibs !! n                       -- using an infinite stream
  2254.             where fibs = 0 : 1 : zipWith (+) fibs (tail fibs)
  2255. -- Perfect numbers:
  2256. factors n    = [ i | i<-[1..n-1], n `mod` i == 0 ]
  2257. perfect n    = sum (factors n) == n
  2258. firstperfect = head perfects
  2259. perfects     = filter perfect [(1::Int)..]
  2260. -- Prime numbers:
  2261. primes      :: Integral a => [a]
  2262. primes       = map head (iterate sieve [2..])
  2263. sieve (p:xs) = [ x | x<-xs, x `rem` p /= 0 ]
  2264. -- Pythagorean triads:
  2265. triads n     = [ (x,y,z) | let ns=[1..n], x<-ns, y<-ns, z<-ns, x*x+y*y==z*z ]
  2266. -- The Hamming problem:
  2267. hamming     :: [Integer]
  2268. hamming      = 1 : (map (2*) hamming || map (3*) hamming || map (5*) hamming)
  2269.                where (x:xs) || (y:ys)  | x==y  =  x : (xs || ys)
  2270.                                        | x<y   =  x : (xs || (y:ys))
  2271.                                        | y<x   =  y : (ys || (x:xs))
  2272. -- Digits of e:
  2273. eFactBase ::  [Int]
  2274. eFactBase  =  map head (iterate scale (2:repeat 1))
  2275. scale     ::  Integral a => [a] -> [a]
  2276. scale      =  renorm . map (10*) . tail
  2277. renorm ds  =  foldr step [0] (zip ds [2..])
  2278. step (d,n) bs | (d `mod` n + 9) < n  = (d `div` n) : b : tail bs
  2279.               | otherwise            = c           : b : tail bs
  2280.               where b' = head bs
  2281.                     b  = (d+b') `mod` n
  2282.                     c  = (d+b') `div` n
  2283. -- Pascal's triangle
  2284. pascal :: [[Int]]
  2285. pascal  = iterate (\row -> zipWith (+) ([0]++row) (row++[0])) [1]
  2286. showPascal = putStr ((layn . map show . take 14) pascal)
  2287. -- This program can be used to solve exercise 1.2.1 in Bird & Wadler's
  2288. -- ``Introduction to functional programming'' ....
  2289. -- Write down the ways to reduce sqr (sqr (3+7)) to normal form
  2290. -- (without assuming shared evaluation of function arguments).
  2291. module EvalRed where
  2292. data  Term  = Square Term      -- The square of a term
  2293.             | Plus Term Term   -- The sum of two terms
  2294.             | Times Term Term  -- The product of two terms
  2295.             | Num Int          -- A numeric constant
  2296. instance Show Term where
  2297.     showsPrec p (Square t)  = showString "sqr " . shows t
  2298.     showsPrec p (Plus n m)  = showChar '(' . shows n . showChar '+'
  2299.                                            . shows m . showChar ')'
  2300.     showsPrec p (Times n m) = showChar '(' . shows m . showChar '*'
  2301.                                            . shows n . showChar ')'
  2302.     showsPrec p (Num i)     = shows i
  2303. -- What are the subterms of a given term?
  2304. type Subterm                     = (Term,           -- The subterm expression
  2305.                                     Term->Term)     -- A function which embeds
  2306.                                                     -- it back in the original
  2307.                                                     -- term
  2308. rebuild                         :: Subterm -> Term
  2309. rebuild (t, embed)               = embed t
  2310. subterms                        :: Term -> [Subterm]
  2311. subterms t                       = [ (t,id) ] ++ properSubterms t
  2312. properSubterms                  :: Term -> [Subterm]
  2313. properSubterms (Square t)        = down Square (subterms t)
  2314. properSubterms (Plus t1 t2)      = down (flip Plus t2)  (subterms t1) ++
  2315.                                    down (Plus t1)       (subterms t2)
  2316. properSubterms (Times t1 t2)     = down (flip Times t2) (subterms t1) ++
  2317.                                    down (Times t1)      (subterms t2)
  2318. properSubterms (Num n)           = []
  2319. down                            :: (Term -> Term) -> [Subterm] -> [Subterm]
  2320. down f                           = map (\(t, e) -> (t, f.e))
  2321. -- Some (semi-)general variations on standard themes:
  2322. filter'                         :: (a -> Bool) -> [(a, b)] -> [(a, b)]
  2323. filter' p                        = filter (p.fst)
  2324. map'                            :: (a -> b) -> [(a, c)] -> [(b, c)]
  2325. map' f                           = map (\(a, c) -> (f a, c))
  2326. -- Reductions:
  2327. isRedex                         :: Term -> Bool
  2328. isRedex (Square _)               = True
  2329. isRedex (Plus (Num _) (Num _))   = True
  2330. isRedex (Times (Num _) (Num _))  = True
  2331. isRedex _                        = False
  2332. contract                        :: Term -> Term
  2333. contract (Square t)              = Times t t
  2334. contract (Plus (Num n) (Num m))  = Num (n+m)
  2335. contract (Times (Num n) (Num m)) = Num (n*m)
  2336. contract _                       = error "Not a redex!"
  2337. singleStep        :: Term -> [Term]
  2338. singleStep         = map rebuild . map' contract . filter' isRedex . subterms
  2339. normalForms       :: Term -> [Term]
  2340. normalForms t 
  2341.        | null ts   = [ t ]
  2342.        | otherwise = [ n | t'<-ts, n<-normalForms t' ]
  2343.                      where ts = singleStep t
  2344. redSequences      :: Term -> [[Term]]
  2345. redSequences t
  2346.        | null ts   = [ [t] ]
  2347.        | otherwise = [ t:rs | t'<-ts, rs<-redSequences t' ]
  2348.                      where ts = singleStep t
  2349. -- Particular example:
  2350. term0 = Square (Square (Plus (Num 3) (Num 7)))
  2351. nfs0  = normalForms term0
  2352. rsq0  = redSequences term0
  2353. -- Using Hugs:
  2354. -- ? length nfs0
  2355. -- 547
  2356. -- Eliza: an implementation of the classic pseudo-psychoanalyst ---------------
  2357. -- Gofer version by Mark P. Jones, January 12 1992.
  2358. -- Modified for Hugs 1.3, August 1996.
  2359. -- Adapted from a pascal implementation provided as part of an experimental
  2360. -- package from James Risner (risner@ms.uky.edu), Univ. of KY. with original
  2361. -- pascal code apparently provided by Robert Migliaccio (mig@ms.uky.edu).
  2362. -------------------------------------------------------------------------------
  2363. module Eliza where
  2364. import Interact
  2365. eliza = interact (writeStr hi $ session initial [])
  2366.  where hi = "\n\
  2367.              \Hi! I'm Eliza. I am your personal therapy computer.\n\
  2368.              \Please tell me your problem.\n\
  2369.              \\n" 
  2370. -- Read a line at a time, and produce some kind of response -------------------
  2371. session rs prev
  2372.        = readLine "> " (\l ->
  2373.          let ws             = words (trim l)
  2374.              (response,rs') = if prev==ws then repeated rs else answer rs ws
  2375.          in  writeStr (response ++ "\n\n") $ session rs' ws)
  2376. trim  :: String -> String                     -- strip punctuation characters
  2377. trim   = foldr cons "" . dropWhile (`elem` punct)
  2378.          where x `cons` xs | x `elem` punct && null xs = []
  2379.                            | otherwise                 = x : xs
  2380.                punct = [' ', '.', '!', '?', ',']
  2381. answer                :: State -> Words -> (String, State)
  2382. answer st l            = (response, newKeyTab kt st)
  2383.  where (response, kt)         = ans (keyTabOf st)
  2384.        e `cons` (r, es)       = (r, e:es)
  2385.        ans (e:es) | null rs   = e `cons` ans es
  2386.                   | otherwise = (makeResponse a (head rs), (key,as):es)
  2387.                          where rs           = replies key l
  2388.                                (key,(a:as)) = e
  2389. -- Find all possible replies (without leading string for given key ------------
  2390. replies                 :: Words -> Words -> [String]
  2391. replies key l            = ( map (conjug l . drop (length key))
  2392.                            . filter (prefix key . map ucase)
  2393.                            . netails) l
  2394. prefix                  :: Eq a => [a] -> [a] -> Bool
  2395. []     `prefix` xs       = True
  2396. (x:xs) `prefix` []       = False
  2397. (x:xs) `prefix` (y:ys)   = x==y && (xs `prefix` ys)
  2398. netails                 :: [a] -> [[a]]          -- non-empty tails of list
  2399. netails []               = []
  2400. netails xs               = xs : netails (tail xs)
  2401. ucase                   :: String -> String      -- map string to upper case
  2402. ucase                    = map toUpper
  2403. -- Replace keywords in a list of words with appropriate conjugations ----------
  2404. conjug     :: Words -> Words -> String
  2405. conjug d    = unwords . trailingI . map conj . maybe d  -- d is default input
  2406.               where maybe d xs = if null xs then d else xs
  2407.                     conj  w    = head ([m | (w',m)<-conjugates, uw==w'] ++ [w])
  2408.                                  where uw = ucase w
  2409.                     trailingI  = foldr cons []
  2410.                                  where x `cons` xs | x=="I" && null xs = ["me"]
  2411.                                                    | otherwise         = x:xs
  2412. conjugates :: [(Word, Word)]
  2413. conjugates  = prepare (oneways ++ concat [[(x,y), (y,x)] | (x,y) <- bothways])
  2414.               where oneways  = [ ("me",   "you") ]
  2415.                     bothways = [ ("are",  "am"),     ("we're", "was"),
  2416.                 ("you",  "I"),      ("your",  "my"),
  2417.                 ("I've", "you've"), ("I'm",   "you're") ]
  2418.                     prepare  = map (\(w,r) -> (ucase w, r))
  2419. -- Response data --------------------------------------------------------------
  2420. type Word     = String
  2421. type Words    = [Word]
  2422. type KeyTable = [(Key, Replies)]
  2423. type Replies  = [String]
  2424. type State    = (KeyTable, Replies)
  2425. type Key      = Words
  2426. repeated          :: State -> (String, State)
  2427. repeated (kt, (r:rp))      = (r, (kt, rp))
  2428. newKeyTab                 :: KeyTable -> State -> State
  2429. newKeyTab kt' (kt, rp)     = (kt', rp)
  2430. keyTabOf                  :: State -> KeyTable
  2431. keyTabOf (kt, rp)          = kt
  2432. makeResponse             :: String -> String -> String
  2433. makeResponse ('?':cs) us  = cs ++ " " ++ us ++ "?"
  2434. makeResponse ('.':cs) us  = cs ++ " " ++ us ++ "."
  2435. makeResponse cs       us  = cs
  2436. initial     :: State
  2437. initial      = ([(words k, cycle rs) | (k,rs) <-respMsgs], cycle repeatMsgs)
  2438. repeatMsgs   = [ "Why did you repeat yourself?",
  2439.          "Do you expect a different answer by repeating yourself?",
  2440.          "Come, come, elucidate your thoughts.",
  2441.          "Please don't repeat yourself!" ]
  2442. respMsgs     = [ ("CAN YOU",        canYou),
  2443.          ("CAN I",        canI),
  2444.          ("YOU ARE",        youAre),
  2445.          ("YOU'RE",        youAre),
  2446.          ("I DON'T",        iDont),
  2447.          ("I FEEL",        iFeel),
  2448.          ("WHY DON'T YOU",    whyDont),
  2449.          ("WHY CAN'T I",    whyCant),
  2450.          ("ARE YOU",        areYou), 
  2451.          ("I CAN'T",        iCant),
  2452.          ("I AM",        iAm),
  2453.          ("I'M",        iAm),
  2454.          ("YOU",         you),
  2455.          ("YES",        yes),
  2456.          ("NO",            no),
  2457.          ("COMPUTER",        computer),
  2458.          ("COMPUTERS",        computer),
  2459.          ("I WANT",        iWant),
  2460.          ("WHAT",        question),
  2461.          ("HOW",        question),
  2462.          ("WHO",        question),
  2463.          ("WHERE",        question),
  2464.          ("WHEN",        question),
  2465.          ("WHY",        question),
  2466.          ("NAME",        name),
  2467.          ("BECAUSE",        because),
  2468.          ("CAUSE",        because),
  2469.          ("SORRY",        sorry),
  2470.          ("DREAM",        dream),
  2471.          ("DREAMS",        dream),
  2472.          ("HI",            hello),
  2473.          ("HELLO",        hello),
  2474.          ("MAYBE",        maybe),
  2475.          ("YOUR",        your),
  2476.          ("ALWAYS",        always),
  2477.          ("THINK",        think),
  2478.          ("ALIKE",        alike),
  2479.          ("FRIEND",        friend),
  2480.          ("FRIENDS",        friend),
  2481.          ("",            nokeyMsgs) ]
  2482.  where
  2483.   canYou     = [ "?Don't you believe that I can",
  2484.          "?Perhaps you would like to be able to",
  2485.          "?You want me to be able to" ]
  2486.   canI         = [ "?Perhaps you don't want to",
  2487.          "?Do you want to be able to" ]
  2488.   youAre     = [ "?What makes you think I am",
  2489.          "?Does it please you to believe I am",
  2490.          "?Perhaps you would like to be",
  2491.          "?Do you sometimes wish you were" ]
  2492.   iDont         = [ "?Don't you really",
  2493.          "?Why don't you",
  2494.          "?Do you wish to be able to",
  2495.          "Does that trouble you?" ]
  2496.   iFeel         = [ "Tell me more about such feelings.",
  2497.          "?Do you often feel",
  2498.          "?Do you enjoy feeling" ]
  2499.   whyDont    = [ "?Do you really believe I don't",
  2500.          ".Perhaps in good time I will",
  2501.          "?Do you want me to" ]
  2502.   whyCant    = [ "?Do you think you should be able to",
  2503.          "?Why can't you" ]
  2504.   areYou     = [ "?Why are you interested in whether or not I am",
  2505.          "?Would you prefer if I were not",
  2506.          "?Perhaps in your fantasies I am" ]
  2507.   iCant         = [ "?How do you know you can't",
  2508.          "Have you tried?",
  2509.          "?Perhaps you can now" ]
  2510.   iAm         = [ "?Did you come to me because you are",
  2511.          "?How long have you been",
  2512.          "?Do you believe it is normal to be",
  2513.          "?Do you enjoy being" ]
  2514.   you         = [ "We were discussing you --not me.",
  2515.          "?Oh,",
  2516.          "You're not really talking about me, are you?" ]
  2517.   yes         = [ "You seem quite positive.",
  2518.          "Are you Sure?",
  2519.          "I see.",
  2520.          "I understand." ]
  2521.   no         = [ "Are you saying no just to be negative?",
  2522.          "You are being a bit negative.",
  2523.          "Why not?",
  2524.          "Are you sure?",
  2525.          "Why no?" ]
  2526.   computer   = [ "Do computers worry you?",
  2527.          "Are you talking about me in particular?",
  2528.          "Are you frightened by machines?",
  2529.          "Why do you mention computers?",
  2530.          "What do you think machines have to do with your problems?",
  2531.          "Don't you think computers can help people?",
  2532.          "What is it about machines that worries you?" ]
  2533.   iWant         = [ "?Why do you want",
  2534.          "?What would it mean to you if you got",
  2535.          "?Suppose you got",
  2536.          "?What if you never got",
  2537.          ".I sometimes also want" ]
  2538.   question   = [ "Why do you ask?",
  2539.          "Does that question interest you?",
  2540.          "What answer would please you the most?",
  2541.          "What do you think?",
  2542.          "Are such questions on your mind often?",
  2543.          "What is it that you really want to know?",
  2544.          "Have you asked anyone else?",
  2545.          "Have you asked such questions before?",
  2546.          "What else comes to mind when you ask that?" ]
  2547.   name         = [ "Names don't interest me.",
  2548.          "I don't care about names --please go on." ]
  2549.   because    = [ "Is that the real reason?",
  2550.          "Don't any other reasons come to mind?",
  2551.          "Does that reason explain anything else?",
  2552.          "What other reasons might there be?" ]
  2553.   sorry         = [ "Please don't apologise!",
  2554.          "Apologies are not necessary.",
  2555.          "What feelings do you have when you apologise?",
  2556.          "Don't be so defensive!" ]
  2557.   dream         = [ "What does that dream suggest to you?",
  2558.          "Do you dream often?",
  2559.          "What persons appear in your dreams?",
  2560.          "Are you disturbed by your dreams?" ]
  2561.   hello         = [ "How do you...please state your problem." ]
  2562.   maybe         = [ "You don't seem quite certain.",
  2563.          "Why the uncertain tone?",
  2564.          "Can't you be more positive?",
  2565.          "You aren't sure?",
  2566.          "Don't you know?" ]
  2567.   your         = [ "?Why are you concerned about my",
  2568.          "?What about your own" ]
  2569.   always     = [ "Can you think of a specific example?",
  2570.          "When?",
  2571.          "What are you thinking of?",
  2572.          "Really, always?" ]
  2573.   think         = [ "Do you really think so?",
  2574.          "?But you are not sure you",
  2575.          "?Do you doubt you" ]
  2576.   alike         = [ "In what way?",
  2577.          "What resemblence do you see?",
  2578.          "What does the similarity suggest to you?",
  2579.          "What other connections do you see?",
  2580.          "Cound there really be some connection?",
  2581.          "How?" ]
  2582.   friend     = [ "Why do you bring up the topic of friends?",
  2583.          "Do your friends worry you?",
  2584.          "Do your friends pick on you?",
  2585.          "Are you sure you have any friends?",
  2586.          "Do you impose on your friends?",
  2587.          "Perhaps your love for friends worries you." ]
  2588.   nokeyMsgs    = [ "I'm not sure I understand you fully.",
  2589.          "What does that suggest to you?",
  2590.          "I see.",
  2591.          "Can you elaborate on that?",
  2592.          "Say, do you have any psychological problems?" ]
  2593. -------------------------------------------------------------------------------
  2594. -- With import chasing enabled, this module can be used to
  2595. -- load the majority of the demos into a Hugs session.
  2596. module Demos where
  2597. import AnsiDemo
  2598. import Examples
  2599. import Say
  2600. import Calendar
  2601. import CommaInt
  2602. import Tree
  2603. import Queens
  2604. import Mersenne
  2605. import Gofer
  2606. import Stack
  2607. import Lattice
  2608. import EvalRed
  2609. import ArrayEx
  2610. import FastSort
  2611. import Expr
  2612. import Literate
  2613. import Eliza
  2614. import Minsrand
  2615. import Ldfs
  2616. import Matrix
  2617. This file contains the definition of commaint, a function which takes a
  2618. single string argument containing a sequence of digits, and outputs the
  2619. same sequence with commas inserted after every group of three digits,
  2620. reading from the right hand end of the string.
  2621. > module CommaInt where
  2622. >  commaint = reverse . foldr1 (\x y->x++","++y) . group 3 . reverse
  2623. >     where group n = takeWhile (not.null) . map (take n) . iterate (drop n)
  2624. This definition uses the following library functions:
  2625.   reverse, (.), foldr1, (++), takeWhile, not, null, map, take, iterate, drop.
  2626. Example: evaluation of commaint "1234567"
  2627.            "1234567"
  2628.                |
  2629.                | reverse
  2630.                V
  2631.            "7654321" _______________________________
  2632.                |                                    \
  2633.                | iterate (drop 3)                    |
  2634.                V                                     |
  2635.            ["7654321", "4321", "1", "", "", ...]     |
  2636.                |                                     |
  2637.                | map (take 3)                        V  group 3
  2638.                V                                     |
  2639.            ["765", "432", "1", "", "", ...]          |
  2640.                |                                     |
  2641.                | takeWhile (not.null)                |
  2642.                V     _______________________________/
  2643.            ["765", "432", "1"]
  2644.                |
  2645.                | foldr1 (\x y->x++","++y)
  2646.                V
  2647.            "765,432,1"
  2648.                |
  2649.                | reverse
  2650.                V
  2651.            "1,234,567"
  2652. In a Hugs session:
  2653.     ? commaint "1234567"
  2654.     1,234,567
  2655.     ?
  2656. -- This is a modification of the calendar program described in section 4.5
  2657. -- of Bird and Wadler's ``Introduction to functional programming'', with
  2658. -- two ways of printing the calendar ... as in B+W, or like UNIX `cal':
  2659. -- Run using:  calFor "1996"
  2660. --        or:  putStr (calendar 1996)
  2661. --        or:  putStr (cal 1996)
  2662. module Calendar( calendar, cal, calFor, calProg ) where
  2663. import Gofer
  2664. import List(zip4)
  2665. import IO(hPutStr,stderr)
  2666. import System( getArgs, getProgName, exitWith, ExitCode(..) )
  2667. -- Picture handling:
  2668. infixr 5 `above`, `beside`
  2669. type Picture   =  [[Char]]
  2670. height, width :: Picture -> Int
  2671. height p       = length p
  2672. width  p       = length (head p)
  2673. above, beside :: Picture -> Picture -> Picture
  2674. above          = (++)
  2675. beside         = zipWith (++)
  2676. stack, spread :: [Picture] -> Picture
  2677. stack          = foldr1 above
  2678. spread         = foldr1 beside
  2679. empty         :: (Int,Int) -> Picture
  2680. empty (h,w)    = replicate h (replicate w ' ')
  2681. block, blockT :: Int -> [Picture] -> Picture
  2682. block n        = stack . map spread . groupsOf n
  2683. blockT n       = spread . map stack . groupsOf n
  2684. groupsOf      :: Int -> [a] -> [[a]]
  2685. groupsOf n []  = []
  2686. groupsOf n xs  = take n xs : groupsOf n (drop n xs)
  2687. lframe        :: (Int,Int) -> Picture -> Picture
  2688. lframe (m,n) p = (p `beside` empty (h,n-w)) `above` empty (m-h,n)
  2689.          where h = height p
  2690.                        w = width p
  2691. -- Information about the months in a year:
  2692. monthLengths year = [31,feb,31,30,31,30,31,31,30,31,30,31]
  2693.                     where feb | leap year = 29
  2694.                               | otherwise = 28
  2695. leap year         = if year`mod`100 == 0 then year`mod`400 == 0
  2696.                                          else year`mod`4   == 0
  2697. monthNames        = ["January","February","March","April",
  2698.              "May","June","July","August",
  2699.              "September","October","November","December"]
  2700. jan1st year       = (year + last`div`4 - last`div`100 + last`div`400) `mod` 7
  2701.                     where last = year - 1
  2702. firstDays year    = take 12
  2703.                          (map (`mod`7)
  2704.                               (scanl (+) (jan1st year) (monthLengths year)))
  2705. -- Producing the information necessary for one month:
  2706. dates fd ml = map (date ml) [1-fd..42-fd]
  2707.               where date ml d | d<1 || ml<d  = ["   "]
  2708.                               | otherwise    = [rjustify 3 (show d)]
  2709. -- The original B+W calendar:
  2710. calendar :: Int -> String
  2711. calendar  = unlines . block 3 . map picture . months
  2712.             where picture (mn,yr,fd,ml)  = title mn yr `above` table fd ml
  2713.                   title mn yr    = lframe (2,25) [mn ++ " " ++ show yr]
  2714.                   table fd ml    = lframe (8,25)
  2715.                                           (daynames `beside` entries fd ml)
  2716.                   daynames       = ["Sun","Mon","Tue","Wed","Thu","Fri","Sat"]
  2717.                   entries fd ml  = blockT 7 (dates fd ml)
  2718.                   months year    = zip4 monthNames
  2719.                                         (replicate 12 year)
  2720.                                         (firstDays year)
  2721.                                         (monthLengths year)
  2722. -- In a format somewhat closer to UNIX cal:
  2723. cal year = unlines (banner year `above` body year)
  2724.            where banner yr      = [cjustify 75 (show yr)] `above` empty (1,75)
  2725.                  body           = block 3 . map (pad . pic) . months
  2726.                  pic (mn,fd,ml) = title mn `above` table fd ml
  2727.                  pad p          = (side`beside`p`beside`side)`above`end
  2728.                  side           = empty (8,2)
  2729.                  end            = empty (1,25)
  2730.                  title mn       = [cjustify 21 mn]
  2731.                  table fd ml    = daynames `above` entries fd ml
  2732.                  daynames       = [" Su Mo Tu We Th Fr Sa"]
  2733.                  entries fd ml  = block 7 (dates fd ml)
  2734.                  months year    = zip3 monthNames
  2735.                                        (firstDays year)
  2736.                                        (monthLengths year)
  2737. -- For a standalone calendar program:
  2738. -- To use this with "runhugs" on Unix:
  2739. --   cat >cal
  2740. --   #! /usr/local/bin/runhugs
  2741. --   
  2742. --   > module Main( main ) where
  2743. --   > import Calendar
  2744. --   > main = calProg
  2745. --   <ctrl-D>
  2746. --   chmod 755 cal
  2747. --   ./cal 1997
  2748. calProg = do
  2749.          args <- getArgs
  2750.          case args of 
  2751.          [year] -> calFor year
  2752.          _      -> do
  2753.                      putStr "Usage: "
  2754.                      getProgName >>= putStr
  2755.                      putStrLn " year" 
  2756.                      exitWith (ExitFailure 1)
  2757. calFor year | illFormed = hPutStr stderr "Bad argument" >>
  2758.                           exitWith (ExitFailure 1)
  2759.             | otherwise = putStr (cal yr)
  2760.               where illFormed = null ds || not (null rs)
  2761.                     (ds,rs)   = span isDigit year
  2762.                     yr        = atoi ds
  2763.                     atoi s    = foldl (\a d -> 10*a+d) 0 (map digitToInt s)
  2764.        
  2765. -- End of calendar program
  2766. -- Some simple examples using arrays:
  2767. module ArrayEx where
  2768. import Array
  2769. -- Some applications, most taken from the Gentle Introduction ... -------------
  2770. timesTable :: Array (Int,Int) Int
  2771. timesTable  = array ((1,1),(10,10)) [ ((i,j), i*j) | i<-[1..10], j<-[1..10] ]
  2772. fibs n = a where a = array (0,n) ([ (0,1), (1,1) ] ++
  2773.                                   [ (i, a!(i-2) + a!(i-1)) | i <- [2..n] ])
  2774. wavefront n = a where a = array ((1,1),(n,n))
  2775.                              ([ ((1,j), 1) | j <- [1..n] ] ++
  2776.                               [ ((i,1), 1) | i <- [2..n] ] ++
  2777.                               [ ((i,j), a!(i,j-1) + a!(i-1,j-1) + a!(i-1,j))
  2778.                                            | i <- [2..n], j <- [2..n] ])
  2779. listwave n = [ [wf!(i,j) | j <- [1..n]] | i <- [1..n] ]
  2780.              where wf = wavefront n
  2781. eg1 :: Array Integer Integer
  2782. eg1  = array (1,100) ((1, 1) : [ (i, i * eg1!(i-1)) | i <- [2..100] ])
  2783. -------------------------------------------------------------------------------
  2784. -- This program is a simple example of the kind of thing that you can do with
  2785. -- ANSI escape character sequences.  But, of course, it will only work on
  2786. -- machines that support those character sequences (xterms and PCs with
  2787. -- ansi.sys installed, for example).
  2788. -- Type `interact program' to run the program.
  2789. module AnsiDemo( program ) where
  2790. import AnsiInteract
  2791. writes  = writeStr . concat
  2792. program = writes [ cls,
  2793.                    at (17,5)  (highlight "Demonstration program"),
  2794.                    at (48,5)  "Version 1.0",
  2795.                    at (17,7)  "This program illustrates a simple approach",
  2796.                    at (17,8)  "to screen-based interactive programs using",
  2797.                    at (17,9)  "the Hugs functional programming system.",
  2798.                    at (17,11) "Please press any key to continue ..."
  2799.                  ]
  2800.           (pressAnyKey
  2801.           (promptReadAt (17,15) 18 "Please enter your name: " (\name ->
  2802.           (let reply = "Hello " ++ name ++ "!" in
  2803.            writeAt (40-(length reply`div` 2),18) reply
  2804.           (moveTo (1,23)
  2805.           (writeStr "I'm waiting...\n"
  2806.           (pressAnyKey
  2807.           end)))))))
  2808. -----------------------------------------------------------------------------
  2809. -- Trex utilities:  Functions to compare and show record values
  2810. -- Warning: This file is an integral part of the TREX implementation, and
  2811. -- should not be modified without corresponding changes in the interpreter.
  2812. -- Suitable for use with Hugs 98, if compiled with TREX support.
  2813. -----------------------------------------------------------------------------
  2814. module Trex( module Prelude, ShowRecRow(..), EqRecRow(..), insertField ) where
  2815. -- Code for equalities:
  2816. instance EqRecRow r => Eq (Rec r) where
  2817.   r == s = eqFields (eqRecRow r s)
  2818.            where eqFields = and . map snd
  2819. class EqRecRow r where
  2820.   eqRecRow :: Rec r -> Rec r -> [(String,Bool)]
  2821. instance EqRecRow EmptyRow where
  2822.   eqRecRow _ _ = []
  2823. -- Code for showing values:
  2824. instance ShowRecRow r => Show (Rec r) where
  2825.   showsPrec d = showFields . showRecRow
  2826.    where
  2827.     showFields   :: [(String, ShowS)] -> ShowS
  2828.     showFields [] = showString "EmptyRec"
  2829.     showFields xs = showChar '(' . foldr1 comma (map fld xs) . showChar ')'
  2830.      where comma a b = a . showString ", " . b
  2831.            fld (s,v) = showString s . showChar '=' . v
  2832. class ShowRecRow r where
  2833.   showRecRow :: Rec r -> [(String, ShowS)]
  2834. instance ShowRecRow EmptyRow where
  2835.   showRecRow _ = []
  2836. -- General utility:
  2837. insertField       :: String -> v -> [(String, v)] -> [(String, v)]
  2838. insertField n v fs = {- case fs of
  2839.                        []     -> [(n,v)]
  2840.                        (r:rs) -> if n <= fst r
  2841.                                    then (n,v):fs
  2842.                                    else r : insertField n v rs -}
  2843.                      bef ++ [(n,v)] ++ aft
  2844.  where (bef,aft) = span (\r -> n > fst r) fs
  2845. -----------------------------------------------------------------------------
  2846. -----------------------------------------------------------------------------
  2847. -- Trace primitive: import this library as a simple way to access the
  2848. -- impure trace primitive.  This is sometimes useful for debugging,
  2849. -- although understanding the output that it produces can sometimes be
  2850. -- a major challenge unless you are familiar with the intimate details
  2851. -- of how programs are executed.
  2852. -- Suitable for use with Hugs 98
  2853. -----------------------------------------------------------------------------
  2854. module Trace( trace, traceShow ) where
  2855. primitive trace :: String -> a -> a
  2856. traceShow :: Show a => String -> a -> a
  2857. traceShow msg x = trace (msg ++ show x) x
  2858. -----------------------------------------------------------------------------
  2859. -----------------------------------------------------------------------------
  2860. -- Dummy module to import all of the standard libraries; programmers should
  2861. -- normally be more selective than this when it comes to specifying the
  2862. -- modules that a particular program depends on.
  2863. -- Suitable for use with Hugs 98
  2864. -----------------------------------------------------------------------------
  2865. module StdLibs where
  2866. import Array
  2867. import Char
  2868. import Complex
  2869. import IO
  2870. import Ix
  2871. import List
  2872. import Maybe
  2873. import Monad
  2874. import Ratio
  2875. import System
  2876. import Random
  2877. -----------------------------------------------------------------------------
  2878. module Sequence(
  2879.     Sequence( fromList, toList ),
  2880.     -- instances for [], Maybe and List
  2881.     List -- same instances as for []
  2882.     ) where
  2883. import Maybe(maybeToList, listToMaybe)
  2884. import Monad
  2885. class (Functor m, MonadPlus m) => Sequence m where
  2886.   fromList :: [a] -> m a
  2887.   toList   :: m a -> [a]
  2888.   fromList = msum . fmap return
  2889. ----------------------------------------------------------------
  2890. -- []: fast access to head but slow append
  2891. ----------------------------------------------------------------
  2892. instance Sequence [] where
  2893.   fromList = id
  2894.   toList   = id
  2895. ----------------------------------------------------------------
  2896. -- Maybe: single element lists - sort of
  2897. ----------------------------------------------------------------
  2898. instance Sequence Maybe where
  2899.   toList   = maybeToList
  2900.   fromList = listToMaybe
  2901. ----------------------------------------------------------------
  2902. -- List: lists with fast append (but slower indexing!)
  2903. ----------------------------------------------------------------
  2904. -- Instead of providing Cons as a constructor, we provide Append.
  2905. data List a = Empty
  2906.              | Singleton a
  2907.              | Append (List a) (List a)
  2908. -- We define all the same instances that are defined for [].
  2909. -- The following definitions are independent of the choice of
  2910. -- representation since there's very little benefit in writing
  2911. -- representation-dependent versions.
  2912. instance Eq a => Eq (List a) where
  2913.   xs == ys = toList xs == toList ys
  2914. instance Ord a => Ord (List a) where
  2915.   compare xs ys = compare (toList xs) (toList ys)
  2916. instance Read a => Read (List a) where
  2917.   readsPrec p s = [ (fromList xs, r)      | (xs,  r) <- readsPrec p s ]
  2918.   readList    s = [ (map fromList xss, r) | (xss, r) <- readList    s ] 
  2919. instance Show a => Show (List a) where
  2920.   showsPrec p xs  = showsPrec p (toList xs)
  2921.   showList    xss = showList    (map toList xss)
  2922. -- The following operations are representation dependent and ought
  2923. -- to go much faster than any alternative way of writing them.
  2924. -- For example, the monadic operators preserve the structure of their
  2925. -- input.
  2926. instance Functor List where
  2927.   fmap f Empty          = Empty
  2928.   fmap f (Singleton x)  = Singleton (f x)
  2929.   fmap f (Append xs ys) = Append (fmap f xs) (fmap f ys)
  2930. instance Monad List where
  2931.   Empty        >>= k = Empty
  2932.   Singleton x  >>= k = k x
  2933.   Append xs ys >>= k = Append (xs >>= k) (ys >>= k)
  2934.   return = Singleton
  2935. instance MonadPlus List where
  2936.   mzero = Empty
  2937.   mplus = Append
  2938. instance Sequence List where
  2939.   fromList = foldr (\ x xs -> Singleton x `Append` xs) Empty
  2940.   toList xs = flatten xs []
  2941.    where
  2942.     -- flatten uses the standard technique of a "work list" yss
  2943.     -- flatten xs yss = xs ++ concatMap toList yss
  2944.     -- flatten :: List a -> [List a] -> [a]
  2945.     flatten Empty          []       = []
  2946.     flatten Empty          (ys:yss) = flatten ys yss
  2947.     flatten (Singleton x)  []       = [x]
  2948.     flatten (Singleton x)  (ys:yss) = x : flatten ys yss
  2949.     -- special cases for extra speed
  2950.     flatten (Append (Singleton x) ys) yss = x:flatten ys yss
  2951.     flatten (Append xs Empty) yss   = flatten xs yss
  2952.     flatten (Append Empty ys) yss   = flatten ys yss
  2953.     flatten (Append xs ys) yss      = flatten xs (ys:yss)
  2954. {-----------------------------------------------------------------------------
  2955.                  A LIBRARY OF MONADIC PARSER COMBINATORS
  2956.                               29th July 1996
  2957.                            Revised, October 1996
  2958.                        Revised again, November 1998
  2959.                  Graham Hutton               Erik Meijer
  2960.             University of Nottingham    University of Utrecht
  2961. This Haskell 98 script defines a library of parser combinators, and is taken
  2962. from sections 1-6 of our article "Monadic Parser Combinators".  Some changes
  2963. to the library have been made in the move from Gofer to Haskell:
  2964.    * Do notation is used in place of monad comprehension notation;
  2965.    * The parser datatype is defined using "newtype", to avoid the overhead
  2966.      of tagging and untagging parsers with the P constructor.
  2967. -----------------------------------------------------------------------------}
  2968. module ParseLib
  2969.    (Parser, item, papply, (+++), sat, many, many1, sepby, sepby1, chainl,
  2970.     chainl1, chainr, chainr1, ops, bracket, char, digit, lower, upper,
  2971.     letter, alphanum, string, ident, nat, int, spaces, comment, junk,
  2972.     parse, token, natural, integer, symbol, identifier, module Monad) where
  2973. import Char
  2974. import Monad
  2975. infixr 5 +++
  2976. --- The parser monad ---------------------------------------------------------
  2977. newtype Parser a   = P (String -> [(a,String)])
  2978. instance Functor Parser where
  2979.    -- map         :: (a -> b) -> (Parser a -> Parser b)
  2980.    fmap f (P p)    = P (\inp -> [(f v, out) | (v,out) <- p inp])
  2981. instance Monad Parser where
  2982.    -- return      :: a -> Parser a
  2983.    return v        = P (\inp -> [(v,inp)])
  2984.    -- >>=         :: Parser a -> (a -> Parser b) -> Parser b
  2985.    (P p) >>= f     = P (\inp -> concat [papply (f v) out | (v,out) <- p inp])
  2986. instance MonadPlus Parser where
  2987.    -- mzero            :: Parser a
  2988.    mzero                = P (\inp -> [])
  2989.    -- mplus            :: Parser a -> Parser a -> Parser a
  2990.    (P p) `mplus` (P q)  = P (\inp -> (p inp ++ q inp))
  2991. --- Other primitive parser combinators ---------------------------------------
  2992. item              :: Parser Char
  2993. item               = P (\inp -> case inp of
  2994.                                    []     -> []
  2995.                                    (x:xs) -> [(x,xs)])
  2996. force             :: Parser a -> Parser a
  2997. force (P p)        = P (\inp -> let x = p inp in
  2998.                                 (fst (head x), snd (head x)) : tail x)
  2999. first             :: Parser a -> Parser a
  3000. first (P p)        = P (\inp -> case p inp of
  3001.                                    []     -> []
  3002.                                    (x:xs) -> [x])
  3003. papply            :: Parser a -> String -> [(a,String)]
  3004. papply (P p) inp   = p inp
  3005. --- Derived combinators ------------------------------------------------------
  3006. (+++)             :: Parser a -> Parser a -> Parser a
  3007. p +++ q            = first (p `mplus` q)
  3008. sat               :: (Char -> Bool) -> Parser Char
  3009. sat p              = do {x <- item; if p x then return x else mzero}
  3010. many              :: Parser a -> Parser [a]
  3011. many p             = force (many1 p +++ return [])
  3012. many1             :: Parser a -> Parser [a]
  3013. many1 p            = do {x <- p; xs <- many p; return (x:xs)}
  3014. sepby             :: Parser a -> Parser b -> Parser [a]
  3015. p `sepby` sep      = (p `sepby1` sep) +++ return []
  3016. sepby1            :: Parser a -> Parser b -> Parser [a]
  3017. p `sepby1` sep     = do {x <- p; xs <- many (do {sep; p}); return (x:xs)}
  3018. chainl            :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
  3019. chainl p op v      = (p `chainl1` op) +++ return v
  3020. chainl1           :: Parser a -> Parser (a -> a -> a) -> Parser a
  3021. p `chainl1` op     = do {x <- p; rest x}
  3022.                      where
  3023.                         rest x = do {f <- op; y <- p; rest (f x y)}
  3024.                                  +++ return x
  3025. chainr            :: Parser a -> Parser (a -> a -> a) -> a -> Parser a
  3026. chainr p op v      = (p `chainr1` op) +++ return v
  3027. chainr1           :: Parser a -> Parser (a -> a -> a) -> Parser a
  3028. p `chainr1` op     = do {x <- p; rest x}
  3029.                      where
  3030.                         rest x = do {f <- op; y <- p `chainr1` op; return (f x y)}
  3031.                                  +++ return x
  3032. ops               :: [(Parser a, b)] -> Parser b
  3033. ops xs             = foldr1 (+++) [do {p; return op} | (p,op) <- xs]
  3034. bracket           :: Parser a -> Parser b -> Parser c -> Parser b
  3035. bracket open p close = do {open; x <- p; close; return x}
  3036. --- Useful parsers -----------------------------------------------------------
  3037. char              :: Char -> Parser Char
  3038. char x             = sat (\y -> x == y)
  3039. digit             :: Parser Char
  3040. digit              = sat isDigit
  3041. lower             :: Parser Char
  3042. lower              = sat isLower
  3043. upper             :: Parser Char
  3044. upper              = sat isUpper
  3045. letter            :: Parser Char
  3046. letter             = sat isAlpha
  3047. alphanum          :: Parser Char
  3048. alphanum           = sat isAlphaNum
  3049. string            :: String -> Parser String
  3050. string ""          = return ""
  3051. string (x:xs)      = do {char x; string xs; return (x:xs)}
  3052. ident             :: Parser String
  3053. ident              = do {x <- lower; xs <- many alphanum; return (x:xs)}
  3054. nat               :: Parser Int
  3055. nat                = do {x <- digit; return (digitToInt x)} `chainl1` return op
  3056.                      where
  3057.                         m `op` n = 10*m + n
  3058. int               :: Parser Int
  3059. int                = do {char '-'; n <- nat; return (-n)} +++ nat
  3060. --- Lexical combinators ------------------------------------------------------
  3061. spaces            :: Parser ()
  3062. spaces             = do {many1 (sat isSpace); return ()}
  3063. comment           :: Parser ()
  3064. comment            = do {string "--"; many (sat (\x -> x /= '\n')); return ()}
  3065. junk              :: Parser ()
  3066. junk               = do {many (spaces +++ comment); return ()}
  3067. parse             :: Parser a -> Parser a
  3068. parse p            = do {junk; p}
  3069. token             :: Parser a -> Parser a
  3070. token p            = do {v <- p; junk; return v}
  3071. --- Token parsers ------------------------------------------------------------
  3072. natural           :: Parser Int
  3073. natural            = token nat
  3074. integer           :: Parser Int
  3075. integer            = token int
  3076. symbol            :: String -> Parser String
  3077. symbol xs          = token (string xs)
  3078. identifier        :: [String] -> Parser String
  3079. identifier ks      = token (do {x <- ident; if not (elem x ks) then return x
  3080.                                                                else mzero})
  3081. ------------------------------------------------------------------------------
  3082. -----------------------------------------------------------------------------
  3083. -- Weak.hs:    Weak Pointers
  3084. -- This library provides support for weak pointers.
  3085. -- Suitable for use with Hugs 98
  3086. -----------------------------------------------------------------------------
  3087. module Weak(Weak, makeWeakPtr, derefWeakPtr) where
  3088. data Weak a
  3089. primitive makeWeakPtr  :: a -> IO (Weak a)
  3090. primitive derefWeakPtr :: Weak a -> IO (Maybe a)
  3091. -- for testing purposes 
  3092. primitive gc "primGC" :: IO ()
  3093. -- not a CAF!
  3094. test z = do
  3095.   { let x = [z]  -- use a list so we're sure it's heap allocated
  3096.   ; print x -- this makes sure x is in whnf
  3097.   ; w <- makeWeakPtr x
  3098.   ; showWeakPtr w
  3099.   ; gc
  3100.   ; print x -- this makes sure x is still alive after the GC
  3101.   ; showWeakPtr w  -- so it's probably still alive here
  3102.   ; gc
  3103.   ; showWeakPtr w  -- but ought to be dead by here
  3104. showWeakPtr :: Show a => Weak a -> IO ()
  3105. showWeakPtr w = do
  3106.   { x <- derefWeakPtr w
  3107.   ; print x
  3108. -----------------------------------------------------------------------------
  3109. -----------------------------------------------------------------------------
  3110. -- Number.hs:    Fixed width integers with overflow detection
  3111. -- This library defines a numeric datatype of fixed width integers
  3112. -- (whatever Int supplies).  But, unlike Int, overflows are detected and
  3113. -- cause a run-time error.  Covers all classes upto and including Bounded
  3114. -- and Ix.  A fairly messy hack, but it works (most of the time :-) ...
  3115. -- Suitable for use with Hugs 98
  3116. -----------------------------------------------------------------------------
  3117. module Number( 
  3118.     Number,
  3119.     -- instance Eq       Number,
  3120.     -- instance Ord      Number,
  3121.     -- instance Show     Number,
  3122.     -- instance Enum     Number,
  3123.     -- instance Num      Number,
  3124.     -- instance Bounded  Number,
  3125.     -- instance Real     Number,
  3126.     -- instance Ix       Number,
  3127.     -- instance Integral Number,
  3128.     ) where
  3129. import Ix(Ix(..))
  3130. default (Number,Int,Float)
  3131. type Number = Int
  3132.   in numEq           :: Number -> Number -> Bool,
  3133.      numCmp          :: Number -> Number -> Ordering,
  3134.      numShowsPrec    :: Int -> Number -> ShowS,
  3135.      numEnumFrom     :: Number -> [Number],
  3136.      numEnumFromThen :: Number -> Number -> [Number],
  3137.      numAdd          :: Number -> Number -> Number,
  3138.      numSub          :: Number -> Number -> Number,
  3139.      numMul          :: Number -> Number -> Number,
  3140.      numNeg          :: Number -> Number,
  3141.      numFromInt      :: Int -> Number,
  3142.      numToInt        :: Number -> Int,
  3143.      numFromInteger  :: Integer -> Number,
  3144.      numToInteger    :: Number -> Integer,
  3145.      numMax          :: Number,
  3146.      numMin          :: Number,
  3147.      numSignum       :: Number -> Number,
  3148.      numToRat        :: Number -> Rational,
  3149.      numQrm          :: Number -> Number -> (Number, Number),
  3150.      numRange        :: (Number, Number) -> [Number],
  3151.      numIndex        :: (Number, Number) -> Number -> Int,
  3152.      numInRange      :: (Number, Number) -> Number -> Bool
  3153. numEq           = (==)
  3154. numCmp          = compare
  3155. numShowsPrec    = showsPrec
  3156. numEnumFrom     = enumFrom
  3157. numEnumFromThen = enumFromThen
  3158. numFromInt x    = x
  3159. numToInt x      = x
  3160. numFromInteger  = fromInteger
  3161. numToInteger    = toInteger
  3162. numMax          = maxBound
  3163. numMin          = minBound
  3164. numSignum       = signum
  3165. numToRat        = toRational
  3166. numQrm          = quotRem
  3167. numRange        = range
  3168. numIndex        = index
  3169. numInRange      = inRange
  3170. numAdd x y = if xsgn/=ysgn || xsgn==rsgn then r else error "add overflow!"
  3171.              where xsgn = x>=0
  3172.                    ysgn = y>=0
  3173.                    rsgn = r>=0
  3174.                    r    = x + y
  3175. numSub x y = if xsgn==ysgn || ysgn/=rsgn then r else error "sub overflow!"
  3176.              where xsgn = x>=0
  3177.                    ysgn = y>=0
  3178.                    rsgn = r>=0
  3179.                    r    = x - y
  3180. numMul x y = if y==0 || (r `div` y == x) then r else error "mult overflow!"
  3181.              where r = x * y
  3182. numNeg x   = if x>=0 || r>=0 then r else error "negate overflow!"
  3183.              where r = negate x
  3184. instance Eq Number where
  3185.   (==)   = numEq
  3186. instance Ord Number where
  3187.   compare = numCmp
  3188. instance Show Number where
  3189.   showsPrec = numShowsPrec
  3190. instance Enum Number where
  3191.   toEnum       = numFromInt
  3192.   fromEnum     = numToInt
  3193.   enumFrom     = numEnumFrom
  3194.   enumFromThen = numEnumFromThen
  3195. instance Num Number where
  3196.   (+)         = numAdd
  3197.   (-)         = numSub
  3198.   (*)         = numMul
  3199.   negate      = numNeg
  3200.   fromInt     = numFromInt
  3201.   fromInteger = numFromInteger
  3202.   abs x       = if x<0 then negate x else x
  3203.   signum      = numSignum
  3204. instance Bounded Number where
  3205.   minBound    = numMin
  3206.   maxBound    = numMax
  3207. instance Real Number where
  3208.   toRational  = numToRat
  3209. instance Ix Number where
  3210.   range   = numRange
  3211.   index   = numIndex
  3212.   inRange = numInRange
  3213. instance Integral Number where
  3214.   quotRem   = numQrm
  3215.   toInteger = numToInteger
  3216. -----------------------------------------------------------------------------
  3217. module ListUtils(
  3218.     sums, products,
  3219.     subsequences,
  3220.     permutations
  3221.     ) where
  3222. sums, products     :: Num a => [a] -> [a]
  3223. sums                = scanl (+) 0
  3224. products            = scanl (*) 1
  3225. -- subsequences xs returns the list of all subsequences of xs.
  3226. -- e.g., subsequences "abc" == ["","c","b","bc","a","ac","ab","abc"]
  3227. subsequences           :: [a] -> [[a]]
  3228. subsequences []         = [[]]
  3229. subsequences (x:xs)     = subsequences xs ++ map (x:) (subsequences xs)
  3230. -- permutations xs returns the list of all permutations of xs.
  3231. -- e.g., permutations "abc" == ["abc","bac","bca","acb","cab","cba"]
  3232. permutations           :: [a] -> [[a]]
  3233. permutations []         = [[]]
  3234. permutations (x:xs)     = [zs | ys <- permutations xs, zs <- interleave x ys ]
  3235.   where interleave         :: a -> [a] -> [[a]]
  3236.         interleave x []     = [[x]]
  3237.         interleave x (y:ys) = [x:y:ys] ++ map (y:) (interleave x ys)
  3238. -----------------------------------------------------------------------------
  3239. -- Non-standard extensions to IO monad.
  3240. -- Binary file extensions:
  3241. --   readBinaryFile         : versions of readFile, writeFile, appendFile,
  3242. --   writeBinaryFile        : and openFile for use on binary files
  3243. --   appendBinaryFile       : (These don't do LF <-> CR-LF translation on
  3244. --   openBinaryFile         :  DOS/Windows systems.)
  3245. -- Miscellaneous extensions:
  3246. --   getCh                  : like getChar but doesn't echo to screen
  3247. --   argv                   : value returned by getArgv     
  3248. -- None of these operations can be implemented in standard Haskell using the
  3249. -- standard Haskell prelude.
  3250. -- Suitable for use with Hugs 98
  3251. -----------------------------------------------------------------------------
  3252. module IOExtensions(
  3253.     readBinaryFile, writeBinaryFile, appendBinaryFile,
  3254.     openBinaryFile, 
  3255.         getCh,
  3256.     argv
  3257.     ) where
  3258. import System( getArgs )
  3259. import IO( Handle, IOMode )
  3260. import IOExts( unsafePerformIO )
  3261. argv :: [String]
  3262. argv = unsafePerformIO getArgs
  3263. primitive writeBinaryFile        :: FilePath -> String -> IO ()
  3264. primitive appendBinaryFile       :: FilePath -> String -> IO ()
  3265. primitive readBinaryFile         :: FilePath -> IO String
  3266. primitive openBinaryFile         :: FilePath -> IOMode -> IO Handle
  3267. primitive getCh                  :: IO Char -- non-echoing getchar
  3268. -----------------------------------------------------------------------------
  3269. -- Library for simple interactive programs:
  3270. -- Suitable for use with Hugs 98
  3271. -----------------------------------------------------------------------------
  3272. module Interact(
  3273.     Interact(..),
  3274.     end,
  3275.     readChar, peekChar, unreadChar, pressAnyKey,
  3276.     writeChar, writeStr,
  3277.     readLine,
  3278.     ringBell
  3279.     ) where
  3280. --- Interactive program combining forms:
  3281. type Interact = String -> String
  3282. end                      :: Interact
  3283. readChar, peekChar       :: Interact -> (Char -> Interact) -> Interact
  3284. pressAnyKey              :: Interact -> Interact
  3285. unreadChar               :: Char -> Interact -> Interact
  3286. writeChar                :: Char -> Interact -> Interact
  3287. writeStr                 :: String -> Interact -> Interact
  3288. ringBell                 :: Interact -> Interact
  3289. readLine                 :: String -> (String -> Interact) -> Interact
  3290. end cs                    = ""
  3291. readChar eof use []       = eof []
  3292. readChar eof use (c:cs)   = use c cs
  3293. peekChar eof use []       = eof []     -- like readChar, but character is
  3294. peekChar eof use cs@(c:_) = use c cs   -- not removed from input stream
  3295. pressAnyKey prog          = readChar prog (\c -> prog)
  3296. unreadChar c prog cs      = prog (c:cs)
  3297. writeChar c prog cs       = c : prog cs
  3298. writeStr s prog cs        = s ++ prog cs
  3299. ringBell                  = writeChar '\BEL'
  3300. readLine prompt g is  = prompt ++ lineOut 0 line ++ "\n"
  3301.                                ++ g (noBackSpaces line) input'
  3302.  where line     = before '\n' is
  3303.        input'   = after  '\n' is
  3304.        after x  = tail . dropWhile (x/=)
  3305.        before x = takeWhile (x/=)
  3306.        rubout  :: Char -> Bool
  3307.        rubout c = (c=='\DEL' || c=='\BS')
  3308.        lineOut                      :: Int -> String -> String
  3309.        lineOut n ""                  = ""
  3310.        lineOut n (c:cs)
  3311.                  | n>0  && rubout c  = "\BS \BS" ++ lineOut (n-1) cs
  3312.                  | n==0 && rubout c  = lineOut 0 cs
  3313.                  | otherwise         = c:lineOut (n+1) cs
  3314.        noBackSpaces :: String -> String
  3315.        noBackSpaces  = reverse . delete 0 . reverse
  3316.                        where delete n ""          = ""
  3317.                              delete n (c:cs)
  3318.                                       | rubout c  = delete (n+1) cs
  3319.                                       | n>0       = delete (n-1) cs
  3320.                                       | otherwise = c:delete 0 cs
  3321. -----------------------------------------------------------------------------
  3322. -----------------------------------------------------------------------------
  3323. -- Dummy module to import all of the Hugs libraries; programmers should
  3324. -- normally be more selective than this when it comes to specifying the
  3325. -- modules that a particular program depends on.
  3326. -- Suitable for use with Hugs 98
  3327. -----------------------------------------------------------------------------
  3328. module HugsLibs where
  3329. import StdLibs
  3330. import Trace
  3331. import Number
  3332. import ParseLib
  3333. import Interact
  3334. import AnsiScreen
  3335. import AnsiInteract
  3336. import IOExtensions
  3337. import Sequence
  3338. import ListUtils
  3339. import Dynamic
  3340. -----------------------------------------------------------------------------
  3341. ----------------------------------------------------------------
  3342. -- Primitives for accessing Hugs internals.
  3343. -- NB These primitives are an _experimental_ feature which may be
  3344. --    removed in future versions of Hugs.
  3345. --    They can only be used if hugs was configured with the
  3346. --    "--enable-internal-prims" flag.
  3347. -- The primitives defined in this module provide the means with
  3348. -- which to implement simple error-recovery and debugging facilities
  3349. -- in Haskell.  
  3350. -- The error catching primitive only works if the "failOnError" flag 
  3351. -- is FALSE - ie Hugs was invoked with the "-f" flag.
  3352. -- Despite appearances, these primitives are referentially transparent
  3353. -- (with the exception of the rarely used pointer equality operations)
  3354. -- (The proof is really neat - but there just isn't enough space in the margin)
  3355. ----------------------------------------------------------------
  3356. module HugsInternals(
  3357.     ptrEq,
  3358.     Name,
  3359.       nameString,
  3360.       nameInfo,
  3361.       nameEq,
  3362.     Cell,
  3363.       getCell,
  3364.       cellPtrEq,
  3365.     CellKind(..),
  3366.       classifyCell,
  3367.     catchError,
  3368.     Addr,
  3369.           nameCode,
  3370.     Instr(..),
  3371.       instrAt, instrsAt,
  3372.     ) where
  3373. import Prelude hiding ( Addr )
  3374. ----------------------------------------------------------------
  3375. -- pointer equality
  3376. ----------------------------------------------------------------
  3377. -- breaks referential transparency - use with care
  3378. primitive ptrEq "unsafePtrEq" :: a -> a -> Bool
  3379. ----------------------------------------------------------------
  3380. -- Name
  3381. ----------------------------------------------------------------
  3382. data Name
  3383. -- newtype Name = Name Int
  3384. -- returns (arity, precedence, associativity)
  3385. primitive nameInfo       :: Name -> (Int, Int, Char)
  3386. primitive nameString     :: Name -> String
  3387. primitive nameEq         :: Name -> Name -> Bool
  3388. instance Show Name where
  3389.   showsPrec _ nm = showString (nameString nm)
  3390. instance Eq Name where
  3391.   (==) = nameEq
  3392. ----------------------------------------------------------------
  3393. -- Cell
  3394. -- Note: cellPtrEq breaks referential transparency - use with care
  3395. ----------------------------------------------------------------
  3396. data Cell
  3397. primitive getCell                  :: a -> Cell
  3398. primitive cellPtrEq                :: Cell -> Cell -> Bool
  3399. primitive catchError "catchError2" :: a -> Either Cell a
  3400. instance Show Cell where 
  3401.   showsPrec _ _ = showString "{Cell}"
  3402. ----------------------------------------------------------------
  3403. -- CellType
  3404. ----------------------------------------------------------------
  3405. data CellKind       
  3406.   = Apply   Cell [Cell]
  3407.   | Fun     Name    
  3408.   | Con     Name    
  3409.   | Tuple   Int         
  3410.   | Int     Int         
  3411.   | Integer Integer   
  3412.   | Float   Float       
  3413.   | Char    Char        
  3414.   | Prim    String      
  3415.   | Error   Cell  
  3416.   deriving (Show)
  3417. primitive classifyCell :: Bool -> Cell -> IO CellKind
  3418. ----------------------------------------------------------------
  3419. -- Addr
  3420. ----------------------------------------------------------------
  3421. newtype Addr  = Addr  Int deriving (Eq, Show)
  3422. s :: Addr -> Addr
  3423. s (Addr a) = Addr (a+1)
  3424. primitive nameCode    :: Name -> Addr
  3425. primitive intAt       :: Addr -> Int
  3426. primitive floatAt     :: Addr -> Float
  3427. primitive cellAt      :: Addr -> Cell
  3428. primitive nameAt      :: Addr -> Name
  3429. primitive textAt      :: Addr -> String
  3430. primitive addrAt      :: Addr -> Addr
  3431. primitive bytecodeAt :: Addr -> Bytecode
  3432. ----------------------------------------------------------------
  3433. -- Bytecode
  3434. ----------------------------------------------------------------
  3435. newtype Bytecode = Bytecode Int deriving (Eq, Show)
  3436. iLOAD    = Bytecode 0
  3437. iCELL     = Bytecode 1
  3438. iCHAR     = Bytecode 2
  3439. iINT     = Bytecode 3
  3440. iFLOAT     = Bytecode 4
  3441. iSTRING     = Bytecode 5
  3442. iMKAP     = Bytecode 6
  3443. iUPDATE     = Bytecode 7
  3444. iUPDAP     = Bytecode 8
  3445. iEVAL     = Bytecode 9
  3446. iRETURN     = Bytecode 10
  3447. iTEST     = Bytecode 11
  3448. iGOTO     = Bytecode 12
  3449. iSETSTK     = Bytecode 13
  3450. iROOT     = Bytecode 14
  3451. iDICT     = Bytecode 15
  3452. iFAIL     = Bytecode 16
  3453. iALLOC     = Bytecode 17
  3454. iSLIDE     = Bytecode 18
  3455. iSTAP     = Bytecode 19
  3456. iTABLE     = Bytecode 20
  3457. iLEVAL     = Bytecode 21
  3458. iRUPDAP     = Bytecode 22
  3459. iRUPDATE = Bytecode 23
  3460. data Instr 
  3461.   = LOAD    Int
  3462.   | CELL    Cell
  3463.   | CHAR    Char
  3464.   | INT        Int    
  3465.   | FLOAT   Float         
  3466.   | STRING  String        
  3467.   | MKAP    Int   
  3468.   | UPDATE  Int        
  3469.   | UPDAP   Int        
  3470.   | EVAL           
  3471.   | RETURN         
  3472.   | TEST    Name Addr
  3473.   | GOTO    Addr        
  3474.   | SETSTK  Int        
  3475.   | ROOT    Int        
  3476.   | DICT    Int
  3477.   | FAIL           
  3478.   | ALLOC   Int
  3479.   | SLIDE   Int       
  3480.   | STAP           
  3481.   | TABLE          
  3482.   | LEVAL   Int       
  3483.   | RUPDAP         
  3484.   | RUPDATE 
  3485.   deriving (Show)
  3486. instrAt :: Addr -> (Instr, Addr)
  3487. instrAt pc = case bytecodeAt pc of 
  3488.   i | i == iLOAD    -> (LOAD    (intAt   (s pc)), s (s pc))
  3489.   i | i == iCELL    -> (CELL    (cellAt  (s pc)), s (s pc))
  3490.   i | i == iCHAR    -> (CHAR    (toEnum (intAt (s pc))), s (s pc))
  3491.   i | i == iINT     -> (INT     (intAt   (s pc)), s (s pc))
  3492.   i | i == iFLOAT   -> (FLOAT   (floatAt (s pc)), s (s pc))
  3493.   i | i == iSTRING  -> (STRING  (textAt  (s pc)), s (s pc))
  3494.   i | i == iMKAP    -> (MKAP    (intAt   (s pc)), s (s pc))
  3495.   i | i == iUPDATE  -> (UPDATE  (intAt   (s pc)), s (s pc))
  3496.   i | i == iUPDAP   -> (UPDAP   (intAt   (s pc)), s (s pc))
  3497.   i | i == iEVAL    -> (EVAL                    , s pc)
  3498.   i | i == iRETURN  -> (RETURN                  , s pc)
  3499.   i | i == iTEST    -> (TEST    (nameAt  (s pc)) (addrAt (s (s (pc)))), s (s (s pc)))
  3500.   i | i == iGOTO    -> (GOTO    (addrAt  (s pc)), s (s pc))
  3501.   i | i == iSETSTK  -> (SETSTK  (intAt   (s pc)), s (s pc))
  3502.   i | i == iROOT    -> (ROOT    (intAt   (s pc)), s (s pc))
  3503.   i | i == iDICT    -> (DICT    (intAt   (s pc)), s (s pc))
  3504.   i | i == iFAIL    -> (FAIL                    , s pc)
  3505.   i | i == iALLOC   -> (ALLOC   (intAt   (s pc)), s (s pc))
  3506.   i | i == iSLIDE   -> (SLIDE   (intAt   (s pc)), s (s pc))
  3507.   i | i == iSTAP    -> (STAP                    , s pc)
  3508.   i | i == iTABLE   -> (TABLE                   , s pc)
  3509.   i | i == iLEVAL   -> (LEVAL   (intAt   (s pc)), s (s pc))
  3510.   i | i == iRUPDAP  -> (RUPDAP                  , s pc)
  3511.   i | i == iRUPDATE -> (RUPDATE                 , s pc)
  3512. -- list of instructions starting at given address
  3513. instrsAt :: Addr -> [Instr]
  3514. instrsAt pc = let (i, pc')  = instrAt pc in i : instrsAt pc'
  3515. ----------------------------------------------------------------
  3516. ----------------------------------------------------------------
  3517. -- tests
  3518. ----------------------------------------------------------------
  3519. -- test1, test2 :: Either Cell Int
  3520. -- test1 = catchError (error "foo")
  3521. -- test2 = catchError 1
  3522. -- test3, test4, test5 :: Int
  3523. -- test3 = myCatch (1+error "foo") 2
  3524. -- test4 = myCatch 1 (error "bar")
  3525. -- test5 = myCatch (error "foo") (error "bar")
  3526. -- test6, test7, test8, test9 :: IO ()
  3527. -- test6 = printString "abcdefg"
  3528. -- test7 = printString (error "a" : "bcdefg")
  3529. -- test8 = printString ("abc" ++ error "defg")
  3530. -- test9 = printString (error "a" : "bc" ++ error "defg")
  3531. -- -- if an error occurs, replace it with a default (hopefully error-free) value
  3532. -- myCatch :: a -> a -> a
  3533. -- myCatch x deflt = case catchError x of
  3534. --            Right x' -> x'
  3535. --            Left _   -> deflt
  3536. -- -- lazily print a string - catching any errors as necessary
  3537. -- printString :: String -> IO ()
  3538. -- printString str =
  3539. --   case catchError str of
  3540. --   Left _       -> putStr "<error>"
  3541. --   Right []     -> return ()
  3542. --   Right (c:cs) -> case catchError c of
  3543. --              Left _   -> putStr "<error>" >> printString cs
  3544. --              Right c' -> putChar c' >> printString cs
  3545. -----------------------------------------------------------------------------
  3546. -- A simple "dynamic typing" library
  3547. -----------------------------------------------------------------------------
  3548. module HugsDynamic
  3549.    ( Typeable(typeOf)
  3550.    , Dynamic, toDynamic, fromDynamic, dynApply  -- the primitives
  3551.    , fromDyn, dynApp                            -- raise errors instead of Maybes
  3552.    , intToDyn, fromDynInt, strToDyn, fromDynStr -- specialised versions
  3553.    , Tycon(..), Type(..)                   -- added by sof
  3554.    ) where
  3555. -- Added nicer printers for better error messages  -- jcp
  3556. import IOExts(unsafePerformIO)
  3557. data Tycon = Tycon String     deriving Eq
  3558. instance Show Tycon where
  3559.   showsPrec p (Tycon s) = showString s
  3560. data Type  = App Tycon [Type] deriving Eq
  3561. instance Show Type where
  3562.   showsPrec p (App tycon tys) 
  3563.     | tycon == listTC && onearg 
  3564.     = showString "[" . shows arg1 . showString "]"
  3565.     | tycon == funTC && twoarg 
  3566.     = showParen (p > 8) $
  3567.       showsPrec 9 arg1 . showString " -> " . showsPrec 8 arg2
  3568.     | tycon == tup2TC && twoarg 
  3569.     = showString "(" . showsPrec 0 arg1 . showString ", " . showsPrec 0 arg2 .
  3570.       showString ")"
  3571.     | zeroarg
  3572.     = showsPrec p tycon 
  3573.     | otherwise
  3574.     = showParen (p > 9) $
  3575.       showsPrec p tycon . showArgs tys
  3576.    where
  3577.     (arg1 : arg2 : _) = tys
  3578.     l = length tys
  3579.     zeroarg = l == 0
  3580.     onearg = l == 1
  3581.     twoarg = l == 2  
  3582.     showArgs [] = id
  3583.     showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as 
  3584. unitTC    = Tycon "()"
  3585. intTC     = Tycon "Int"
  3586. integerTC = Tycon "Integer"
  3587. floatTC   = Tycon "Float"
  3588. doubleTC  = Tycon "Double"
  3589. charTC    = Tycon "Char"
  3590. ioTC      = Tycon "IO"
  3591. funTC     = Tycon "->"
  3592. listTC    = Tycon "[]"
  3593. tup2TC    = Tycon "(,)"
  3594. -- ToDo: Either might be more useful for reporting errors
  3595. tyApp :: Type -> Type -> Maybe Type
  3596. tyApp (App tc [t1,t2]) t3
  3597.   | tc == funTC
  3598.   = if t1 == t3 then Just t2 else Nothing
  3599. tyApp _ _ = Nothing
  3600. ---------------------------------------------------------------
  3601. class Typeable a where
  3602.   typeOf :: a -> Type
  3603. instance Typeable ()      where typeOf x = App unitTC    []
  3604. instance Typeable Int     where typeOf x = App intTC     []
  3605. instance Typeable Integer where typeOf x = App integerTC []
  3606. instance Typeable Float   where typeOf x = App floatTC   []
  3607. instance Typeable Double  where typeOf x = App doubleTC  []
  3608. instance Typeable Char    where typeOf x = App charTC    []
  3609. instance Typeable a => Typeable (IO a) where 
  3610.   typeOf m = 
  3611.     case unsafePerformIO m of { r ->
  3612.     App ioTC  [typeOf r]
  3613.     }
  3614. instance (Typeable a, Typeable b) => Typeable (a -> b) where
  3615.   typeOf f = 
  3616.     -- We use case to bind arg and result to avoid excess polymorphism
  3617.     case undefined of { arg ->
  3618.     case f arg     of { result ->
  3619.     App funTC [typeOf arg, typeOf result]
  3620.     }}
  3621. instance Typeable a => Typeable [a] where
  3622.   typeOf xs = App listTC [typeOf (head xs)]
  3623. instance (Typeable a, Typeable b) => Typeable (a,b) where
  3624.   typeOf p = App tup2TC [typeOf (fst p), typeOf (snd p)]
  3625. ----------------------------------------------------------------
  3626. data Object  = Object -- dummy type - we're going to switch the typechecker off
  3627. data Dynamic = Dynamic Type Object
  3628. instance Show Dynamic where
  3629.   showsPrec _ (Dynamic ty _) = showString "<<" . showsPrec 0 ty . showString ">>"
  3630. toDynamic :: Typeable a => a -> Dynamic
  3631. toDynamic x = Dynamic (typeOf x) (unsafeCoerce x)
  3632. fromDynamic :: Typeable a => Dynamic -> Maybe a
  3633. fromDynamic (Dynamic ty x) =
  3634.   -- We use case to bind r to avoid excess polymorphism
  3635.   case unsafeCoerce x of { r -> 
  3636.   if ty == typeOf r then Just r else Nothing
  3637. dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
  3638. dynApply (Dynamic t1 f) (Dynamic t2 x) =
  3639.   tyApp t1 t2   >>= \ t3 -> 
  3640.   return (Dynamic t3 ((unsafeCoerce f) x))
  3641. ----------------------------------------------------------------
  3642. fromDyn :: Typeable a => Dynamic -> a
  3643. fromDyn d = res
  3644.    where res = case fromDynamic d of
  3645.                 Just r -> r
  3646.                 Nothing -> error ("fromDyn failed.  Expecting " ++
  3647.                                   show expectedType ++
  3648.                                   " found " ++ show d) 
  3649.          expectedType = toDynamic res
  3650. intToDyn :: Int -> Dynamic
  3651. intToDyn = toDynamic
  3652. strToDyn :: String -> Dynamic
  3653. strToDyn = toDynamic
  3654. fromDynInt :: Dynamic -> Int
  3655. fromDynInt = fromDyn
  3656. fromDynStr :: Dynamic -> String
  3657. fromDynStr = fromDyn
  3658. runDyn :: Dynamic -> IO ()
  3659. runDyn = fromDyn
  3660. dynApp :: Dynamic -> Dynamic -> Dynamic
  3661. dynApp f x = case dynApply f x of 
  3662.              Just r -> r
  3663.              Nothing -> error ("Type error in dynamic application.\n" ++
  3664.                                "Can't apply function " ++ show f ++
  3665.                                " to argument " ++ show x)
  3666. ----------------------------------------------------------------
  3667. test1 = toDynamic (1::Int)
  3668. test2 = toDynamic ((+) :: Int -> Int -> Int)
  3669. test3 = dynApp test2 test1
  3670. test4 = dynApp test3 test1
  3671. test5 = fromDyn test4 
  3672. test5,test6,test7 :: Int
  3673. test6 = fromDyn test1
  3674. test7 = fromDyn test2
  3675. ----------------------------------------------------------------
  3676. primitive unsafeCoerce "primUnsafeCoerce" :: a -> b
  3677. ----------------------------------------------------------------
  3678. -- A "generic" (or "polymorphic") print function in Haskell
  3679. -- This is very heavily based on the code in printer.c
  3680. -- (Together with the decompiler and error catching primitives,
  3681. -- this might make a good base on which to build a debugger?)
  3682. -- NB This library is an _experimental_ feature which may be
  3683. --    removed in future versions of Hugs.
  3684. --    It can only be used if Hugs was configured with the
  3685. --    "--enable-internal--prims" flag.
  3686. ----------------------------------------------------------------
  3687. module GenericPrint(
  3688.         printError, 
  3689.         outputString, 
  3690.         print
  3691.         ) where
  3692. import Prelude hiding (print)
  3693. import HugsInternals(
  3694.         Name, nameInfo, nameString,
  3695.         Cell, getCell,
  3696.         CellKind(..), classifyCell,
  3697.         )
  3698. import IOExts( unsafePerformIO )
  3699. import Array
  3700. ----------------------------------------------------------------
  3701. -- The top-level print routine 
  3702. ----------------------------------------------------------------
  3703. printError   :: Cell -> IO ()
  3704. outputString :: String -> IO ()
  3705. print        :: a -> IO ()
  3706. printError err = do
  3707.   putStr "\nProgram error: " 
  3708.   printDBadRedex err 
  3709.   putStr "\n"
  3710. outputString s = outputStr (getCell s)
  3711. print x        = print' True (getCell x)
  3712. ----------------------------------------------------------------
  3713. printBadRedex err = do
  3714.   putChar '{' 
  3715.   print' False err 
  3716.   putChar '}'
  3717. printDBadRedex err = do
  3718.   kind <- classifyCell False err
  3719.   case kind of
  3720.   Apply fun args -> do
  3721.       funkind <- classifyCell False fun
  3722.       case (funkind, args) of
  3723.       (Fun nm, [msg]) | nm == nameError ->
  3724.         outputStr msg
  3725.       _ -> printBadRedex err
  3726.   _ -> printBadRedex err
  3727. outputStr :: Cell -> IO ()
  3728. outputStr xs = do
  3729.   kind <- hugsClassifyCell True xs
  3730.   case kind of
  3731.   Apply fun args ->
  3732.       hugsClassifyCell True fun >>= \ funkind ->
  3733.       case (funkind, args) of
  3734.       (Con nm, [y,ys]) | nm == nameCons ->
  3735.         hugsClassifyCell True y >>= \ ykind ->
  3736.         case ykind of
  3737.         Char c ->
  3738.           putChar c >>
  3739.           outputStr ys
  3740.         Error err ->
  3741.           printBadRedex err >>
  3742.           outputStr ys
  3743.         _ ->
  3744.           printBadRedex y >>
  3745.           outputStr ys
  3746.       (Error err, _) ->
  3747.         printBadRedex err
  3748.       _ ->
  3749.         printBadRedex xs
  3750.   Con nm | nm == nameNil ->
  3751.         return ()
  3752.   Error err ->
  3753.         printBadRedex err
  3754.   _ ->
  3755.         printBadRedex xs
  3756. print' :: Bool -> Cell -> IO ()
  3757. print' strict x = printCell strict min_prec x
  3758. --ToDo: combine with sprint (if possible)
  3759. lprint :: Bool -> Cell -> Cell -> IO ()
  3760. lprint strict x xs =
  3761.   printCell strict min_prec x >>
  3762.   hugsClassifyCell strict xs >>= \ kind ->
  3763.   case kind of
  3764.   Apply fun args ->
  3765.       hugsClassifyCell strict fun >>= \ funkind ->
  3766.         case (funkind, args) of
  3767.         (Con nm, [y,ys]) | nm == nameCons ->
  3768.           putStr ", " >>
  3769.           lprint strict y ys
  3770.         (Error err, _) ->
  3771.           printBadRedex err
  3772.         _ ->
  3773.           putStr "] ++ " >>
  3774.           printBadRedex xs
  3775.   Con nm | nm == nameNil ->
  3776.           putChar ']'
  3777.   Error err ->
  3778.           printBadRedex err
  3779.   _ ->
  3780.           putStr "] ++ " >>
  3781.           printBadRedex xs
  3782. sprint :: Bool -> Char -> Cell -> IO ()
  3783. sprint strict c xs =
  3784.   putStr (showLitChar c "") >>
  3785.   hugsClassifyCell strict xs >>= \ kind ->
  3786.   case kind of
  3787.   Apply fun args ->
  3788.       hugsClassifyCell strict fun >>= \ funkind ->
  3789.         case (funkind, args) of
  3790.         (Con nm, [y,ys]) | nm == nameCons ->
  3791.           hugsClassifyCell strict y >>= \ ykind ->
  3792.           case ykind of
  3793.           Char c -> sprint strict c ys
  3794.           _      -> lprint False y ys
  3795.         _ ->
  3796.           putStr "\" ++ " >>
  3797.           printBadRedex xs
  3798.   Con nm | nm == nameNil ->
  3799.           putChar '"'
  3800.   _ ->
  3801.           putStr "\" ++ " >>
  3802.           printBadRedex xs
  3803. printCell :: Bool -> Int -> Cell -> IO ()
  3804. printCell strict d x =
  3805.   hugsClassifyCell strict x >>= \ kind ->
  3806.   case kind of
  3807.   Apply fun args ->
  3808.       hugsClassifyCell strict fun >>= \ funkind ->
  3809.       case funkind of
  3810.       Con nm ->
  3811.         case args of
  3812.           [x,xs] | nm == nameCons
  3813.             -> hugsClassifyCell strict x >>= \ xkind ->
  3814.                case xkind of
  3815.                Char c -> putChar '"' >> sprint strict c xs
  3816.                _      -> putChar '[' >> lprint strict x xs
  3817.           [x] | assoc /= 'A'
  3818.             -> printParen True (
  3819.                  printCell strict (fun_prec-1) x >>
  3820.                  putChar ' ' >>
  3821.                  putStr (asOp nameStr)
  3822.                )
  3823.           (x1:x2:xs) | assoc /= 'A'
  3824.             -> printParen (not (null xs) && d >= fun_prec) (
  3825.                  printParen (d <= p) (do
  3826.                    printCell strict lp x1
  3827.                    putChar ' '           
  3828.                    putStr (asOp nameStr) 
  3829.                    putChar ' '           
  3830.                    printCell strict rp x2
  3831.                    ) >>
  3832.                  mapM_ (\ arg ->
  3833.                    putChar ' ' >>
  3834.                    printCell strict p arg
  3835.                  ) xs
  3836.                  )
  3837.           xs
  3838.             -> printParen (not (null xs) && d >= fun_prec) (
  3839.                  -- test that xs is nonNull should be redundant but
  3840.                  -- no harm being robust
  3841.                  putStr (asVar nameStr)       >>
  3842.                  mapM_ (\arg ->
  3843.                    putChar ' ' >>
  3844.                    printCell strict fun_prec arg
  3845.                  ) xs
  3846.                  )
  3847.          where
  3848.           (arity, p, assoc) = nameInfo nm
  3849.           nameStr = nameString nm
  3850.           -- from Appendix E2 of Haskell 1.2 report
  3851.           lp = if assoc == 'L' then p else p+1
  3852.           rp = if assoc == 'R' then p else p+1
  3853.         
  3854.       Fun nm ->
  3855.         printParen (d >= fun_prec) (
  3856.           putStr (asVar nameStr)       >>
  3857.           mapM_ (\arg ->
  3858.             putChar ' ' >>
  3859.             -- switch to lazy printing!
  3860.             printCell False fun_prec arg
  3861.           ) args
  3862.           )
  3863.        where
  3864.         nameStr = nameString nm
  3865.       
  3866.       Tuple arity ->
  3867.         printParen (not (null extra) && d >= fun_prec) (
  3868.           printParen True (
  3869.             for__ fields (\ field ->
  3870.               printCell strict min_prec field
  3871.             ) (putChar ',') >>
  3872.             -- Haskell's syntax makes it impossible to construct an
  3873.             -- incomplete tuple - but let's play safe!
  3874.             mapM_ (\_ ->
  3875.               putChar ','
  3876.             ) [numArgs+1..arity]
  3877.           ) >>
  3878.           -- Haskell's type system makes extra arguments impossible
  3879.           -- - but let's play safe!
  3880.           mapM_ (\ arg ->
  3881.             putChar ' ' >>
  3882.             printCell strict fun_prec arg
  3883.           ) extra
  3884.         )
  3885.        where
  3886.         (fields, extra) = splitAt arity args
  3887.       Error err ->
  3888.           printBadRedex err
  3889.       _
  3890.         -> printParen (not (null args) && d >= fun_prec) (
  3891.              printCell strict fun_prec fun   >>
  3892.              mapM_ (\arg ->
  3893.                putChar ' ' >>
  3894.                printCell strict fun_prec arg
  3895.              ) args
  3896.              )
  3897.      where
  3898.         numArgs = length args
  3899.   Fun nm ->
  3900.     putStr (asVar (nameString nm))
  3901.   Con nm ->
  3902.     putStr (asVar (nameString nm))
  3903.   Tuple arity ->
  3904.     putStr ('(' : replicate arity ',' ++ ")")
  3905.   Int x ->
  3906.     putStr (show x)
  3907.   Integer x ->
  3908.     putStr (show x)
  3909.   Float x ->
  3910.     putStr (show x)
  3911.   Char x ->
  3912.     putStr ('\'' : showLitChar x "\'")
  3913.   Prim prim ->
  3914.     putStr prim
  3915.   Error err ->
  3916.     printBadRedex err
  3917. ----------------------------------------------------------------
  3918. -- Cell/Name utilities
  3919. ----------------------------------------------------------------
  3920. nameCons    =  cellName (:)
  3921. nameNil     =  cellName []
  3922. nameError   =  cellName error
  3923. -- Here's something VERY subtle.
  3924. -- We use classifyCell instead of hugsClassifyCell because
  3925. -- otherwise, this gets put in the same dependency class as everything
  3926. -- else and the lack of polymorphic recursion bites us.
  3927. -- (Using classifyCell is equally good here because it wont fail.)
  3928. cellName :: a -> Name
  3929. cellName x = unsafePerformIO (
  3930.   classifyCell True (getCell x) >>= \ kind ->
  3931.   case kind of
  3932.   Fun nm -> return nm
  3933.   Con nm -> return nm
  3934. -- This implements the error-handling policy:
  3935. hugsClassifyCell :: Bool -> Cell -> IO CellKind
  3936. hugsClassifyCell strict obj =
  3937.   classifyCell strict obj >>= \ kind ->
  3938.   case kind of
  3939.   Error err ->
  3940.     if failOnError then
  3941.       exitWith (printError err)
  3942.     else
  3943.       return kind
  3944.   _ ->
  3945.     return kind
  3946. ----------------------------------------------------------------
  3947. -- Utilities
  3948. ----------------------------------------------------------------
  3949. intersperse :: a -> [a] -> [a]
  3950. intersperse x (y:ys@(_:_)) = y : x : intersperse x ys
  3951. intersperse x ys = ys
  3952. for__ :: Monad m => [a] -> (a -> m ()) -> m () -> m ()
  3953. for__ xs f inc = sequence $ intersperse inc $ map f xs
  3954. min_prec, max_prec, fun_prec :: Int
  3955. min_prec = 0
  3956. max_prec = 9
  3957. fun_prec = max_prec+2
  3958. asOp str
  3959.  | isOp str  = str
  3960.  | otherwise = '`' : str ++ "`"
  3961. asVar str
  3962.  | isOp str  = '(' : str ++ ")"
  3963.  | otherwise = str
  3964. isOp (c:_) = not (isAlpha c || c == '[')
  3965. isOp _     = False
  3966. printParen :: Bool -> IO () -> IO ()
  3967. printParen True m  = putChar '(' >> m >> putChar ')'
  3968. printParen False m = m
  3969. ----------------------------------------------------------------
  3970. -- Missing primitives
  3971. ----------------------------------------------------------------
  3972. -- In Hugs0, this accessed the value of the :set -f" flag
  3973. failOnError :: Bool
  3974. failOnError = True
  3975. -- In Hugs0, this executed the action and terminated the current evaluation
  3976. exitWith :: IO () -> IO a
  3977. exitWith m = m >> error "{exitWith}"
  3978. ----------------------------------------------------------------
  3979. -- from Prelude.hs
  3980. ----------------------------------------------------------------
  3981. showLitChar               :: Char -> ShowS
  3982. showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (fromEnum c))
  3983. showLitChar '\DEL'         = showString "\\DEL"
  3984. showLitChar '\\'           = showString "\\\\"
  3985. showLitChar c | c >= ' '   = showChar c
  3986. showLitChar '\a'           = showString "\\a"
  3987. showLitChar '\b'           = showString "\\b"
  3988. showLitChar '\f'           = showString "\\f"
  3989. showLitChar '\n'           = showString "\\n"
  3990. showLitChar '\r'           = showString "\\r"
  3991. showLitChar '\t'           = showString "\\t"
  3992. showLitChar '\v'           = showString "\\v"
  3993. showLitChar '\SO'          = protectEsc ('H'==) (showString "\\SO")
  3994. showLitChar c              = showString ('\\' : asciiTab!c)
  3995. asciiTab = listArray ('\NUL', ' ')
  3996.            ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
  3997.             "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
  3998.             "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
  3999.             "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
  4000.             "SP"]
  4001. protectEsc p f             = f . cont
  4002.  where cont s@(c:_) | p c  = "\\&" ++ s
  4003.        cont s              = s
  4004. ----------------------------------------------------------------
  4005. ----------------------------------------------------------------
  4006. -- This is a simple implementation of Cordy Hall's assertions
  4007. -- (for performance debugging).
  4008. -- NB These primitives are an _experimental_ feature which may be
  4009. --    removed in future versions of Hugs.
  4010. --    They can only be used if hugs was configured with the
  4011. --    "--enable-internal-prims" flag.
  4012. -- These primitives mostly break referential transparency - but you're
  4013. -- only supposed to use them for debugging purposes.
  4014. ----------------------------------------------------------------
  4015. module CVHAssert(
  4016.     Test, Action, 
  4017.     assert,
  4018.     isEvaluated,
  4019.     pointerEqual
  4020.     ) where
  4021. import HugsInternals(
  4022.     ptrEq,
  4023.     Name,   nameInfo,
  4024.     Cell,   getCell, cellPtrEq,
  4025.     CellKind(..), classifyCell,
  4026. import IOExts(
  4027.     unsafePerformIO
  4028. ----------------------------------------------------------------
  4029. -- High level operations
  4030. ----------------------------------------------------------------
  4031. type Test a   = a -> Bool
  4032. type Action a = a -> IO ()
  4033. assert :: Test a -> Action a -> a -> a
  4034. assert test action x = 
  4035.   unsafePerformIO (if test x then return () else action x)
  4036.   `seq`
  4037. isEvaluated :: a -> Bool
  4038. isEvaluated x = unsafePerformIO (
  4039.   isEvaluatedCell (getCell x)
  4040. representationSize :: a -> Int
  4041. representationSize x = unsafePerformIO (do 
  4042.   cells <- cellsOf (getCell x) []
  4043.   return (cellSize * length cells)
  4044. pointerEqual :: a -> a -> Bool
  4045. pointerEqual = ptrEq
  4046. ----------------------------------------------------------------
  4047. -- Utilities
  4048. ----------------------------------------------------------------
  4049. isEvaluatedCell :: Cell -> IO Bool
  4050. isEvaluatedCell cell = do
  4051.   kind <- classifyCell False cell
  4052.   case kind of
  4053.     Apply fun args -> do 
  4054.             funkind <- classifyCell False fun
  4055.                     case funkind of
  4056.                     Fun nm    -> return (nameArity nm > length args)
  4057.                     _         -> return True
  4058.     _            -> return True
  4059. arityOf :: Cell -> IO Int
  4060. arityOf cell = do
  4061.   kind <- classifyCell False cell
  4062.   case kind of
  4063.     Apply fun args -> do 
  4064.             funarity <- arityOf fun
  4065.             return (funarity - length args)
  4066.     Fun   nm -> return (nameArity nm)
  4067.     Con   nm -> return (nameArity nm)
  4068.     Tuple i  -> return i
  4069.     _            -> return 0
  4070. nameArity :: Name -> Int
  4071. nameArity nm = case nameInfo nm of (arity,_,_) -> arity
  4072. -- list cells occurring in Cell
  4073. cellsOf :: Cell -> [Cell] -> IO [Cell]
  4074. cellsOf cell seen 
  4075.   | cell `elemCell` seen 
  4076.   = return seen
  4077.   | otherwise
  4078.   = do
  4079.       let seen' = cell:seen
  4080.       kind <- classifyCell False cell
  4081.       case kind of
  4082.     Apply f xs -> do
  4083.                 seen'' <- cellsOf f seen'
  4084.                 cellsOf' xs seen''
  4085.     Fun     _  -> return seen'
  4086.     Con     _  -> return seen'
  4087.     Tuple   _  -> return seen'
  4088.     Int     _  -> return seen'
  4089.     Integer _  -> return seen'
  4090.     Float   _  -> return seen'
  4091.     Char    _  -> return seen'
  4092.     Prim    _  -> return seen'
  4093.     Error   _  -> return seen'    -- we could argue about this one
  4094. cellsOf' :: [Cell] -> [Cell] -> IO [Cell]
  4095. cellsOf' []     seen = return seen
  4096. cellsOf' (x:xs) seen = do seen' <- cellsOf x seen
  4097.                           cellsOf' xs seen'
  4098. elemCell :: Cell -> [Cell] -> Bool
  4099. x `elemCell` []     = False
  4100. x `elemCell` (y:ys) = x `cellPtrEq` y || x `elemCell` ys
  4101. cellSize :: Int
  4102. cellSize = 8
  4103. ----------------------------------------------------------------
  4104. -----------------------------------------------------------------------------
  4105. -- Library of escape sequences for ANSI compatible screen I/O:
  4106. -- Suitable for use with Hugs 98
  4107. -----------------------------------------------------------------------------
  4108. module AnsiScreen(
  4109.     Pos(..),
  4110.     cls,
  4111.     goto, at, home, 
  4112.     highlight
  4113.     ) where
  4114. -- Basic screen control codes:
  4115. type Pos           = (Int,Int)
  4116. at        :: Pos -> String -> String
  4117. highlight :: String -> String
  4118. goto      :: Int -> Int -> String
  4119. home      :: String
  4120. cls       :: String
  4121. at (x,y) s  = goto x y ++ s
  4122. highlight s = "\ESC[7m"++s++"\ESC[0m"
  4123. goto x y    = '\ESC':'[':(show y ++(';':show x ++ "H"))
  4124. home        = goto 1 1
  4125. -- Choose whichever of the following lines is suitable for your system:
  4126. cls         = "\ESC[2J"     -- for PC with ANSI.SYS
  4127. --cls         = "\^L"         -- for Sun window
  4128. -----------------------------------------------------------------------------
  4129. -----------------------------------------------------------------------------
  4130. -- Library of functions for writing interactive programs with screen-oriented
  4131. -- I/O (assumes Ansi screen).
  4132. -- Suitable for use with Hugs 98.
  4133. -----------------------------------------------------------------------------
  4134. module AnsiInteract(
  4135.     module AnsiInteract,
  4136.     module Interact,
  4137.     module AnsiScreen
  4138.     ) where
  4139. import AnsiScreen
  4140. import Interact
  4141. -- Screen oriented input/output functions:
  4142. clearScreen       :: Interact -> Interact
  4143. writeAt           :: Pos -> String -> Interact -> Interact
  4144. moveTo            :: Pos -> Interact -> Interact
  4145. readAt            :: Pos                  ->  -- Start coordinates
  4146.                      Int                  ->  -- Maximum input length
  4147.                      (String -> Interact) ->  -- How to use entered string
  4148.                      Interact
  4149. defReadAt         :: Pos                  ->  -- Start coordinates        
  4150.                      Int                  ->  -- Maximum input length     
  4151.                      String               ->  -- Default string value     
  4152.                      (String -> Interact) ->  -- How to use entered string
  4153.                      Interact
  4154. promptReadAt      :: Pos                  -> -- Start coordinates        
  4155.                      Int                  -> -- Maximum input length     
  4156.                      String               -> -- Prompt
  4157.                      (String -> Interact) -> -- How to use entered string
  4158.                      Interact
  4159. defPromptReadAt   :: Pos                  -> -- Start coordinates        
  4160.                      Int                  -> -- Maximum input length     
  4161.                      String               -> -- Prompt
  4162.                      String               -> -- Default string value
  4163.                      (String -> Interact) -> -- How to use entered string
  4164.                      Interact
  4165. clearScreen        = writeStr cls
  4166. writeAt (x,y) s    = writeStr (goto x y ++ s)
  4167. moveTo  (x,y)      = writeStr (goto x y)
  4168. readAt pt l use    = writeAt pt (replicate l '_') (moveTo pt (loop 0 ""))
  4169.  where loop n s    = readChar (return s) (\c ->
  4170.                      case c of '\BS'         -> delete n s
  4171.                                '\DEL'        -> delete n s
  4172.                                '\n'          -> return s
  4173.                                c | n < l     -> writeChar c (loop (n+1) (c:s))
  4174.                                  | otherwise -> ringBell (loop n s))
  4175.        delete n s  = if n>0 then writeStr "\BS_\BS" (loop (n-1) (tail s))
  4176.                             else ringBell (loop 0 "")
  4177.        return s    = use (reverse s)
  4178. defReadAt (x,y) l def use
  4179.                    = writeAt (x,y) (take l (def++repeat '_')) (
  4180.                      readChar (use def) (\c ->
  4181.                      if c=='\n' then use def
  4182.                                 else unreadChar c (readAt (x,y) l use)))
  4183. promptReadAt (x,y) l prompt use
  4184.                    = writeAt (x,y) prompt (readAt (x+length prompt,y) l use)
  4185. defPromptReadAt (x,y) l prompt def use
  4186.                    = writeAt (x,y) prompt (
  4187.                      defReadAt (x+length prompt,y) l def use)
  4188. -----------------------------------------------------------------------------
  4189. -----------------------------------------------------------------------------
  4190. -- Unsigned Integers
  4191. -- Suitable for use with Hugs 98 on 32 bit systems.
  4192. -----------------------------------------------------------------------------
  4193. module Word
  4194.     ( Word8
  4195.     , Word16
  4196.     , Word32
  4197.     , Word64
  4198.     , word8ToWord32  -- :: Word8  -> Word32
  4199.     , word32ToWord8  -- :: Word32 -> Word8
  4200.     , word16ToWord32 -- :: Word16 -> Word32
  4201.     , word32ToWord16 -- :: Word32 -> Word16
  4202.     , word8ToInt     -- :: Word8  -> Int
  4203.     , intToWord8     -- :: Int    -> Word8
  4204.     , word16ToInt    -- :: Word16 -> Int
  4205.     , intToWord16    -- :: Int    -> Word16
  4206.     , word32ToInt    -- :: Word32 -> Int
  4207.     , intToWord32    -- :: Int    -> Word32
  4208.     ) where
  4209. import Bits
  4210. import Int
  4211. -----------------------------------------------------------------------------
  4212. -- The "official" coercion functions
  4213. -----------------------------------------------------------------------------
  4214. word8ToWord32  :: Word8  -> Word32
  4215. word32ToWord8  :: Word32 -> Word8
  4216. word16ToWord32 :: Word16 -> Word32
  4217. word32ToWord16 :: Word32 -> Word16
  4218. word8ToInt   :: Word8  -> Int
  4219. intToWord8   :: Int    -> Word8
  4220. word16ToInt  :: Word16 -> Int
  4221. intToWord16  :: Int    -> Word16
  4222. word8ToInt  = word32ToInt    . word8ToWord32
  4223. intToWord8  = word32ToWord8  . intToWord32
  4224. word16ToInt = word32ToInt    . word16ToWord32
  4225. intToWord16 = word32ToWord16 . intToWord32
  4226. primitive intToWord32 "intToWord" :: Int    -> Word32
  4227. primitive word32ToInt "wordToInt" :: Word32 -> Int
  4228. -----------------------------------------------------------------------------
  4229. -- Word8
  4230. -----------------------------------------------------------------------------
  4231. newtype Word8  = W8 Word32
  4232. word8ToWord32 (W8 x) = x .&. 0xff
  4233. word32ToWord8 = W8
  4234. instance Eq  Word8     where (==)    = binop (==)
  4235. instance Ord Word8     where compare = binop compare
  4236. instance Num Word8 where
  4237.     x + y         = to (binop (+) x y)
  4238.     x - y         = to (binop (-) x y)
  4239.     negate        = to . negate . from
  4240.     x * y         = to (binop (*) x y)
  4241.     abs           = absReal
  4242.     signum        = signumReal
  4243.     fromInteger   = to . primIntegerToWord
  4244.     fromInt       = intToWord8
  4245. instance Bounded Word8 where
  4246.     minBound = 0
  4247.     maxBound = 0xff
  4248. instance Real Word8 where
  4249.     toRational x = toInteger x % 1
  4250. instance Integral Word8 where
  4251.     x `div` y     = to  (binop div x y)
  4252.     x `quot` y    = to  (binop quot x y)
  4253.     x `rem` y     = to  (binop rem x y)
  4254.     x `mod` y     = to  (binop mod x y)
  4255.     x `quotRem` y = to2 (binop quotRem x y)
  4256.     divMod        = quotRem
  4257.     even          = even      . from
  4258.     toInteger     = toInteger . from
  4259.     toInt         = word8ToInt
  4260. instance Ix Word8 where
  4261.     range (m,n)          = [m..n]
  4262.     index b@(m,n) i
  4263.        | inRange b i = word32ToInt (from (i - m))
  4264.        | otherwise   = error "index: Index out of range"
  4265.     inRange (m,n) i      = m <= i && i <= n
  4266. instance Enum Word8 where
  4267.     toEnum         = to . intToWord32
  4268.     fromEnum       = word32ToInt . from
  4269.     enumFrom c       = map toEnum [fromEnum c .. fromEnum (maxBound::Word8)]
  4270.     enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Word8)]
  4271.                where last = if d < c then minBound else maxBound
  4272. instance Read Word8 where
  4273.     readsPrec p = readDec
  4274. instance Show Word8 where
  4275.     showsPrec p = showInt  -- a particularily counterintuitive name!
  4276. instance Bits Word8 where
  4277.   x .&. y       = to (binop (.&.) x y)
  4278.   x .|. y       = to (binop (.|.) x y)
  4279.   x `xor` y     = to (binop xor x y)
  4280.   complement    = to . complement . from
  4281.   x `shift` i   = to (from x `shift` i)
  4282. --  rotate      
  4283.   bit           = to . bit
  4284.   setBit x i    = to (setBit (from x) i)
  4285.   clearBit x i  = to (clearBit (from x) i)
  4286.   complementBit x i = to (complementBit (from x) i)
  4287.   testBit x i   = testBit (from x) i
  4288.   bitSize  _    = 8
  4289.   isSigned _    = False
  4290. -----------------------------------------------------------------------------
  4291. -- Word16
  4292. -----------------------------------------------------------------------------
  4293. newtype Word16 = W16 Word32
  4294. word16ToWord32 (W16 x) = x .&. 0xffff
  4295. word32ToWord16 = W16
  4296. instance Eq  Word16     where (==)    = binop (==)
  4297. instance Ord Word16     where compare = binop compare
  4298. instance Num Word16 where
  4299.     x + y         = to (binop (+) x y)
  4300.     x - y         = to (binop (-) x y)
  4301.     negate        = to . negate . from
  4302.     x * y         = to (binop (*) x y)
  4303.     abs           = absReal
  4304.     signum        = signumReal
  4305.     fromInteger   = to . primIntegerToWord
  4306.     fromInt       = intToWord16
  4307. instance Bounded Word16 where
  4308.     minBound = 0
  4309.     maxBound = 0xffff
  4310. instance Real Word16 where
  4311.   toRational x = toInteger x % 1
  4312. instance Integral Word16 where
  4313.   x `div` y     = to  (binop div x y)
  4314.   x `quot` y    = to  (binop quot x y)
  4315.   x `rem` y     = to  (binop rem x y)
  4316.   x `mod` y     = to  (binop mod x y)
  4317.   x `quotRem` y = to2 (binop quotRem x y)
  4318.   divMod        = quotRem
  4319.   even          = even      . from
  4320.   toInteger     = toInteger . from
  4321.   toInt         = word16ToInt
  4322. instance Ix Word16 where
  4323.   range (m,n)          = [m..n]
  4324.   index b@(m,n) i
  4325.          | inRange b i = word32ToInt (from (i - m))
  4326.          | otherwise   = error "index: Index out of range"
  4327.   inRange (m,n) i      = m <= i && i <= n
  4328. instance Enum Word16 where
  4329.   toEnum         = to . intToWord32
  4330.   fromEnum       = word32ToInt . from
  4331.   enumFrom c       = map toEnum [fromEnum c .. fromEnum (maxBound::Word16)]
  4332.   enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Word16)]
  4333.                where last = if d < c then minBound else maxBound
  4334. instance Read Word16 where
  4335.   readsPrec p = readDec
  4336. instance Show Word16 where
  4337.   showsPrec p = showInt  -- a particularily counterintuitive name!
  4338. instance Bits Word16 where
  4339.   x .&. y       = to (binop (.&.) x y)
  4340.   x .|. y       = to (binop (.|.) x y)
  4341.   x `xor` y     = to (binop xor x y)
  4342.   complement    = to . complement . from
  4343.   x `shift` i   = to (from x `shift` i)
  4344. --  rotate      
  4345.   bit           = to . bit
  4346.   setBit x i    = to (setBit (from x) i)
  4347.   clearBit x i  = to (clearBit (from x) i)
  4348.   complementBit x i = to (complementBit (from x) i)
  4349.   testBit x i   = testBit (from x) i
  4350.   bitSize  _    = 16
  4351.   isSigned _    = False
  4352. -----------------------------------------------------------------------------
  4353. -- Word32
  4354. -----------------------------------------------------------------------------
  4355. data Word32     -- builtin datatype of 32 bit naturals
  4356. instance Eq  Word32     where (==)    = primEqWord
  4357. instance Ord Word32     where compare = primCmpWord
  4358. instance Num Word32 where
  4359.     (+)           = primPlusWord
  4360.     (-)           = primMinusWord
  4361.     negate        = primNegateWord
  4362.     (*)           = primMulWord
  4363.     abs           = absReal
  4364.     signum        = signumReal
  4365.     fromInteger   = primIntegerToWord
  4366.     fromInt       = intToWord32
  4367. instance Bounded Word32 where
  4368.     minBound = 0
  4369.     maxBound = primMaxWord
  4370. instance Real Word32 where
  4371.     toRational x = toInteger x % 1
  4372. instance Integral Word32 where
  4373.     div       = primDivWord
  4374.     quot      = primQuotWord
  4375.     rem       = primRemWord
  4376.     mod       = primModWord
  4377.     quotRem   = primQrmWord
  4378.     divMod    = quotRem
  4379.     even      = primEvenWord
  4380.     toInteger = primWordToInteger
  4381.     toInt     = word32ToInt 
  4382. instance Ix Word32 where
  4383.     range (m,n)          = [m..n]
  4384.     index b@(m,n) i
  4385.        | inRange b i = word32ToInt (i - m)
  4386.        | otherwise   = error "index: Index out of range"
  4387.     inRange (m,n) i      = m <= i && i <= n
  4388. instance Enum Word32 where
  4389.     toEnum        = intToWord32
  4390.     fromEnum      = word32ToInt
  4391.     --No: suffers from overflow problems: 
  4392.     --   [4294967295 .. 1] :: [Word32]
  4393.     --   = [4294967295,0,1]
  4394.     --enumFrom c       = map toEnum [fromEnum c .. fromEnum (maxBound::Word32)]
  4395.     --enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Word32)]
  4396.     --                    where last = if d < c then minBound else maxBound
  4397.     enumFrom       = numericEnumFrom
  4398.     enumFromTo     = numericEnumFromTo
  4399.     enumFromThen   = numericEnumFromThen
  4400.     enumFromThenTo = numericEnumFromThenTo
  4401. instance Read Word32 where
  4402.     readsPrec p = readDec
  4403. instance Show Word32 where
  4404.     showsPrec p = showInt  -- a particularily counterintuitive name!
  4405. instance Bits Word32 where
  4406.   (.&.)         = primAndWord
  4407.   (.|.)         = primOrWord
  4408.   xor           = primXorWord
  4409.   complement    = primComplementWord
  4410.   shift         = primShiftWord
  4411. --  rotate      
  4412.   bit           = primBitWord
  4413.   setBit x i    = x .|. bit i
  4414.   clearBit x i  = x .&. complement (bit i)
  4415.   complementBit x i = x `xor` bit i
  4416.   testBit       = primTestWord
  4417.   bitSize  _    = 32
  4418.   isSigned _    = False
  4419. -----------------------------------------------------------------------------
  4420. -- Word64
  4421. -----------------------------------------------------------------------------
  4422. data Word64 = W64 {lo,hi::Word32} deriving (Eq, Ord, Bounded)
  4423. w64ToInteger W64{lo=lo,hi=hi} = toInteger lo + 0x100000000 * toInteger hi 
  4424. integerToW64 x = case x `quotRem` 0x100000000 of 
  4425.                  (h,l) -> W64{lo=fromInteger l, hi=fromInteger h}
  4426. instance Show Word64 where
  4427.   showsPrec p = showInt . w64ToInteger
  4428. instance Read Word64 where
  4429.   readsPrec p s = [ (integerToW64 x,r) | (x,r) <- readDec s ]
  4430. -----------------------------------------------------------------------------
  4431. -- End of exported definitions
  4432. -- The remainder of this file consists of definitions which are only
  4433. -- used in the implementation.
  4434. -----------------------------------------------------------------------------
  4435. -----------------------------------------------------------------------------
  4436. -- Enumeration code: copied from Prelude
  4437. -----------------------------------------------------------------------------
  4438. numericEnumFrom        :: Real a => a -> [a]
  4439. numericEnumFromThen    :: Real a => a -> a -> [a]
  4440. numericEnumFromTo      :: Real a => a -> a -> [a]
  4441. numericEnumFromThenTo  :: Real a => a -> a -> a -> [a]
  4442. numericEnumFrom n            = n : (numericEnumFrom $! (n+1))
  4443. numericEnumFromThen n m      = iterate ((m-n)+) n
  4444. numericEnumFromTo n m        = takeWhile (<= m) (numericEnumFrom n)
  4445. numericEnumFromThenTo n n' m = takeWhile (if n' >= n then (<= m) else (>= m))
  4446.                                          (numericEnumFromThen n n')
  4447. -----------------------------------------------------------------------------
  4448. -- Coercions - used to make the instance declarations more uniform
  4449. -----------------------------------------------------------------------------
  4450. class Coerce a where
  4451.   to   :: Word32 -> a
  4452.   from :: a -> Word32
  4453. instance Coerce Word8 where
  4454.   from = word8ToWord32
  4455.   to   = word32ToWord8
  4456. instance Coerce Word16 where
  4457.   from = word16ToWord32
  4458.   to   = word32ToWord16
  4459. binop :: Coerce word => (Word32 -> Word32 -> a) -> (word -> word -> a)
  4460. binop op x y = from x `op` from y
  4461. to2 :: Coerce word => (Word32, Word32) -> (word, word)
  4462. to2 (x,y) = (to x, to y)
  4463. -----------------------------------------------------------------------------
  4464. -- primitives
  4465. -----------------------------------------------------------------------------
  4466. primitive primEqWord        :: Word32 -> Word32 -> Bool
  4467. primitive primCmpWord       :: Word32 -> Word32 -> Ordering
  4468. primitive primPlusWord,
  4469.       primMinusWord,
  4470.       primMulWord        :: Word32 -> Word32 -> Word32
  4471. primitive primNegateWord    :: Word32 -> Word32
  4472. primitive primIntegerToWord :: Integer -> Word32
  4473. primitive primMaxWord       :: Word32
  4474. primitive primDivWord,
  4475.       primQuotWord,
  4476.       primRemWord,
  4477.       primModWord       :: Word32 -> Word32 -> Word32
  4478. primitive primQrmWord       :: Word32 -> Word32 -> (Word32,Word32)
  4479. primitive primEvenWord      :: Word32 -> Bool
  4480. primitive primWordToInteger :: Word32 -> Integer
  4481. primitive primAndWord       :: Word32 -> Word32 -> Word32
  4482. primitive primOrWord        :: Word32 -> Word32 -> Word32
  4483. primitive primXorWord       :: Word32 -> Word32 -> Word32
  4484. primitive primComplementWord:: Word32 -> Word32
  4485. primitive primShiftWord     :: Word32 -> Int -> Word32
  4486. primitive primBitWord       :: Int -> Word32
  4487. primitive primTestWord      :: Word32 -> Int -> Bool
  4488. -----------------------------------------------------------------------------
  4489. -- Code copied from the Prelude
  4490. -----------------------------------------------------------------------------
  4491. absReal x    | x >= 0    = x
  4492.          | otherwise = -x
  4493. signumReal x | x == 0    =  0
  4494.          | x > 0     =  1
  4495.          | otherwise = -1
  4496. -----------------------------------------------------------------------------
  4497. -- End
  4498. -----------------------------------------------------------------------------
  4499. -- A first cut at implementing the (key,value) form of Weak pointers.
  4500. -- Notes (please refer to the draft specification for background):
  4501. --  - mkWeakPair is listed in the signature specification, but its
  4502. --    semantics are not described, and hence we have not provided
  4503. --    an implementation here.
  4504. --  - Programmers using weak pointers should call runFinalizer at
  4505. --    regular intervals to ensure that finalizers are scheduled for
  4506. --    execution.  This implementation provides functions runFinalizer,
  4507. --    finalizerWaiting, and runAllFinalizers to provide programmers with
  4508. --    control over the execution of finalizers.  None of these functions
  4509. --    are part of the current specification.
  4510. -- Tested with Hugs 98.
  4511. module Weak(Weak,
  4512.         mkWeak, mkWeakPtr, mkWeakPair,
  4513.             deRefWeak, finalize, addFinalizer, replaceFinalizer,
  4514.         runFinalizer, finalizerWaiting, runAllFinalizers ) where
  4515. data Weak a
  4516. primitive mkWeak    :: k -> v -> Maybe (IO ()) -> IO (Weak v)
  4517. primitive deRefWeak :: Weak v -> IO (Maybe v)
  4518. primitive replaceFinalizer :: Weak v -> Maybe (IO ()) -> IO (Maybe (IO ()))
  4519. primitive finalize  :: Weak v -> IO ()
  4520. primitive weakPtrEq :: Weak a -> Weak a -> Bool
  4521. instance Eq (Weak a) where
  4522.   (==) = weakPtrEq
  4523. mkWeakPtr           :: k -> Maybe (IO ()) -> IO (Weak k)
  4524. mkWeakPtr v f        = mkWeak v v f
  4525. mkWeakPair          :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v))
  4526. mkWeakPair k v f     = mkWeak k (k,v) f
  4527. addFinalizer        :: k -> IO () -> IO ()
  4528. addFinalizer v f     = do mkWeakPtr v (Just f)
  4529.               return ()
  4530. primitive runFinalizer     :: IO ()
  4531. primitive finalizerWaiting :: IO Bool
  4532. runAllFinalizers    :: IO ()
  4533. runAllFinalizers     = do waiting <- finalizerWaiting
  4534.               if waiting then do runFinalizer
  4535.                          runAllFinalizers
  4536.                      else return ()
  4537. {- for testing purposes
  4538. primitive gc "primGC" :: IO ()
  4539. -- not a CAF!
  4540. test z = do
  4541.   { let k = [z]        -- use a list so we're sure it's heap allocated
  4542.   ; print k        -- this makes sure x is in whnf
  4543.   ; w <- mkWeak k "value" (Just (putStrLn ("Finalizer for "++show k)))
  4544.             -- note that the finalizer uses the key, but
  4545.             -- this shouldn't keep the weak ptr alive!
  4546.   ; showWeakPtr w
  4547.   ; gc
  4548.   ; print k        -- this makes sure k is still alive after the GC
  4549.   ; showWeakPtr w    -- so it's probably still alive here
  4550.   ; gc
  4551.   ; showWeakPtr w    -- but ought to be dead by here
  4552. showWeakPtr :: Show a => Weak a -> IO ()
  4553. showWeakPtr w = do
  4554.   { x <- deRefWeak w
  4555.   ; print x
  4556. -- End of module Weak
  4557. module Stable where 
  4558. data StableName a -- abstract
  4559. primitive makeStableName   :: a -> IO (StableName a)
  4560. primitive deRefStableName  :: StableName a -> a
  4561. primitive hashStableName   :: StableName a -> Int
  4562. primitive eqStableName       :: StableName a -> StableName a -> Bool
  4563. instance Eq (StableName a) where
  4564.     (==) = eqStableName
  4565. -----------------------------------------------------------------------------
  4566. -- Strict State Thread module
  4567. -- This library provides support for both lazy and strict state threads,
  4568. -- as described in the PLDI '94 paper by John Launchbury and Simon Peyton
  4569. -- Jones.  In addition to the monad ST, it also provides mutable variables
  4570. -- STRef and mutable arrays STArray.  It is identical to the LazyST
  4571. -- module except that the ST instance is strict.
  4572. -- Suitable for use with Hugs 98.
  4573. -----------------------------------------------------------------------------
  4574. module ST 
  4575.     ( ST
  4576.     , runST
  4577.     , thenLazyST, thenStrictST, returnST
  4578.     , unsafeInterleaveST
  4579.     , fixST 
  4580.     , stToIO
  4581.     , unsafeIOtoST
  4582.     , STRef
  4583.       -- instance Eq (STRef s a)
  4584.     , newSTRef
  4585.     , readSTRef
  4586.     , writeSTRef 
  4587.         , STArray
  4588.           -- instance Eq (STArray s ix elt)
  4589.         , newSTArray
  4590.         , boundsSTArray
  4591.         , readSTArray
  4592.         , writeSTArray
  4593.         , thawSTArray
  4594.         , freezeSTArray
  4595.         , unsafeFreezeSTArray
  4596.         , Ix
  4597.     ) where
  4598. import Array(Array,Ix(index),bounds,assocs)
  4599. import IOExts(unsafePerformIO)
  4600. import Monad   
  4601. -----------------------------------------------------------------------------
  4602. data ST s a      -- implemented as an internal primitive
  4603. primitive runST                        :: (forall s. ST s a) -> a
  4604. primitive returnST     "STReturn"      :: a -> ST s a
  4605. primitive thenLazyST   "STLazyBind"    :: ST s a -> (a -> ST s b) -> ST s b
  4606. primitive thenStrictST "STStrictBind"  :: ST s a -> (a -> ST s b) -> ST s b
  4607. primitive unsafeInterleaveST "STInter" :: ST s a -> ST s a
  4608. primitive fixST        "STFix"         :: (a -> ST s a) -> ST s a
  4609. primitive stToIO    "primSTtoIO"   :: ST s a -> IO a
  4610. unsafeIOtoST        :: IO a -> ST s a
  4611. unsafeIOtoST         = returnST . unsafePerformIO
  4612. instance Functor (ST s) where
  4613.     fmap = liftM
  4614. instance Monad (ST s) where
  4615.     (>>=)  = thenStrictST
  4616.     return = returnST
  4617. -----------------------------------------------------------------------------
  4618. data STRef s a   -- implemented as an internal primitive
  4619. primitive newSTRef   "STNew"      :: a -> ST s (STRef s a)
  4620. primitive readSTRef  "STDeref"    :: STRef s a -> ST s a
  4621. primitive writeSTRef "STAssign"   :: STRef s a -> a -> ST s ()
  4622. primitive eqSTRef    "STMutVarEq" :: STRef s a -> STRef s a -> Bool
  4623. instance Eq (STRef s a) where (==) = eqSTRef
  4624. -----------------------------------------------------------------------------
  4625. data STArray s ix elt -- implemented as an internal primitive
  4626. newSTArray          :: Ix ix => (ix,ix) -> elt -> ST s (STArray s ix elt)
  4627. boundsSTArray       :: Ix ix => STArray s ix elt -> (ix, ix)
  4628. readSTArray         :: Ix ix => STArray s ix elt -> ix -> ST s elt
  4629. writeSTArray        :: Ix ix => STArray s ix elt -> ix -> elt -> ST s ()
  4630. thawSTArray         :: Ix ix => Array ix elt -> ST s (STArray s ix elt)
  4631. freezeSTArray       :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
  4632. unsafeFreezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
  4633. newSTArray bs e      = primNewArr bs (rangeSize bs) e
  4634. boundsSTArray a      = primBounds a
  4635. readSTArray a i      = primReadArr index a i
  4636. writeSTArray a i e   = primWriteArr index a i e
  4637. thawSTArray arr      = newSTArray (bounds arr) err `thenStrictST` \ stArr ->
  4638.                let 
  4639.                          fillin [] = returnST stArr
  4640.                          fillin ((ix,v):ixvs) = writeSTArray stArr ix v
  4641.                           `thenStrictST` \ _ -> fillin ixvs
  4642.                in fillin (assocs arr)
  4643.  where
  4644.   err = error "thawArray: element not overwritten" -- shouldnae happen
  4645. freezeSTArray a      = primFreeze a
  4646. unsafeFreezeSTArray  = freezeSTArray  -- not as fast as GHC
  4647. instance Eq (STArray s ix elt) where
  4648.   (==) = eqSTArray
  4649. primitive primNewArr   "STNewArr"
  4650.           :: (a,a) -> Int -> b -> ST s (STArray s a b)
  4651. primitive primReadArr  "STReadArr"
  4652.           :: ((a,a) -> a -> Int) -> STArray s a b -> a -> ST s b
  4653. primitive primWriteArr "STWriteArr"
  4654.           :: ((a,a) -> a -> Int) -> STArray s a b -> a -> b -> ST s ()
  4655. primitive primFreeze   "STFreeze"
  4656.           :: STArray s a b -> ST s (Array a b)
  4657. primitive primBounds   "STBounds"
  4658.           :: STArray s a b -> (a,a)
  4659. primitive eqSTArray    "STArrEq"
  4660.           :: STArray s a b -> STArray s a b -> Bool
  4661. -----------------------------------------------------------------------------
  4662. % (c) The GRASP/AQUA Project, Glasgow University, 1995
  4663. \section[Semaphore]{Quantity semaphores}
  4664. General/quantity semaphores
  4665. \begin{code}
  4666. module Semaphore
  4667.       (
  4668.        {- abstract -}
  4669.        QSem,
  4670.        newQSem,        --:: Int  -> IO QSem
  4671.        waitQSem,    --:: QSem -> IO ()
  4672.        signalQSem,    --:: QSem -> IO ()
  4673.        {- abstract -}
  4674.        QSemN,
  4675.        newQSemN,    --:: Int   -> IO QSemN
  4676.        waitQSemN,    --:: QSemN -> Int -> IO ()
  4677.        signalQSemN    --:: QSemN -> Int -> IO ()
  4678.       ) where
  4679. import ConcBase
  4680. \end{code}
  4681. General semaphores are also implemented readily in terms of shared
  4682. @MVar@s, only have to catch the case when the semaphore is tried
  4683. waited on when it is empty (==0). Implement this in the same way as
  4684. shared variables are implemented - maintaining a list of @MVar@s
  4685. representing threads currently waiting. The counter is a shared
  4686. variable, ensuring the mutual exclusion on its access.
  4687. \begin{code}
  4688. data QSem = QSem (MVar (Int, [MVar ()]))
  4689. newQSem :: Int -> IO QSem
  4690. newQSem init 
  4691.  = newMVar (init,[])      >>= \ sem ->
  4692.    return (QSem sem)
  4693. waitQSem :: QSem -> IO ()
  4694. waitQSem (QSem sem)
  4695.  = takeMVar sem     >>= \ (avail,blocked) ->    -- gain ex. access
  4696.    if avail > 0 then
  4697.      putMVar sem (avail-1,[]) >> 
  4698.      return ()
  4699.    else
  4700.      newEmptyMVar       >>= \ block ->
  4701.      {-
  4702.     Stuff the reader at the back of the queue,
  4703.     so as to preserve waiting order. A signalling
  4704.     process then only have to pick the MVar at the
  4705.     front of the blocked list.
  4706.     The version of waitQSem given in the paper could
  4707.     lead to starvation.
  4708.      -}
  4709.      putMVar sem (0, blocked++[block]) >> 
  4710.      takeMVar block               >>= \ v ->
  4711.      return v
  4712. signalQSem :: QSem -> IO ()
  4713. signalQSem (QSem sem)
  4714.  = takeMVar sem   >>= \ (avail,blocked) ->
  4715.    case blocked of
  4716.      [] -> putMVar sem (avail+1,[]) >>
  4717.        return ()
  4718.      (block:blocked') ->
  4719.        putMVar sem (0,blocked') >>
  4720.        putMVar block ()         >>
  4721.        return ()
  4722. data QSemN
  4723.  = QSemN (MVar (Int,[(Int,MVar ())]))
  4724. newQSemN :: Int -> IO QSemN 
  4725. newQSemN init 
  4726.  = newMVar (init,[])      >>= \ sem ->
  4727.    return (QSemN sem)
  4728. waitQSemN :: QSemN -> Int -> IO ()
  4729. waitQSemN (QSemN sem) sz
  4730.  = takeMVar sem >>= \ (avail,blocked) ->    -- gain ex. access
  4731.    if avail > 0 then
  4732.      putMVar sem (avail-1,[]) >>
  4733.      return ()
  4734.    else
  4735.      newEmptyMVar                     >>= \ block ->
  4736.      putMVar sem (0, blocked++[(sz,block)]) >> 
  4737.      takeMVar block                >>
  4738.      return ()
  4739. signalQSemN :: QSemN -> Int  -> IO ()
  4740. signalQSemN (QSemN sem) n
  4741.  = takeMVar sem              >>= \ (avail,blocked) ->
  4742.    free (avail+n) blocked      >>= \ (avail',blocked') ->
  4743.    putMVar sem (avail',blocked') >>
  4744.    return ()
  4745.    where
  4746.     free avail [] = return (avail,[])
  4747.     free avail ((req,block):blocked) =
  4748.      if avail >= req then
  4749.     putMVar block () >>
  4750.     free (avail-req) blocked
  4751.      else
  4752.     free avail blocked >>= \ (avail',blocked') ->
  4753.         return (avail',(req,block):blocked')
  4754. \end{code}
  4755. % (c) The GRASP/AQUA Project, Glasgow University, 1995
  4756. \section[SampleVar]{Sample variables}
  4757. Sample variables are slightly different from a normal @MVar@:
  4758. \begin{itemize}
  4759. \item Reading an empty @SampleVar@ causes the reader to block.
  4760.     (same as @takeMVar@ on empty @MVar@)
  4761. \item Reading a filled @SampleVar@ empties it and returns value.
  4762.     (same as @takeMVar@)
  4763. \item Writing to an empty @SampleVar@ fills it with a value, and
  4764. potentially, wakes up a blocked reader  (same as for @putMVar@ on empty @MVar@).
  4765. \item Writing to a filled @SampleVar@ overwrites the current value.
  4766.  (different from @putMVar@ on full @MVar@.)
  4767. \end{itemize}
  4768. \begin{code}
  4769. module SampleVar
  4770.        (
  4771.          SampleVar,        --:: type _ =
  4772.          newSampleVar,     --:: IO (SampleVar a)
  4773.      emptySampleVar,   --:: SampleVar a -> IO ()
  4774.      readSampleVar,       --:: SampleVar a -> IO a
  4775.      writeSampleVar       --:: SampleVar a -> a -> IO ()
  4776.        ) where
  4777. import ConcBase
  4778. type SampleVar a
  4779.  = MVar (Int,        -- 1  == full
  4780.             -- 0  == empty
  4781.             -- <0 no of readers blocked
  4782.           MVar a)
  4783. -- Initally, a @SampleVar@ is empty/unfilled.
  4784. newEmptySampleVar :: IO (SampleVar a)
  4785. newEmptySampleVar
  4786.  = newEmptyMVar          >>= \ val ->
  4787.    newMVar (0,val)
  4788. newSampleVar :: a -> IO (SampleVar a)
  4789. newSampleVar a = do
  4790.    v <- newEmptySampleVar
  4791.    writeSampleVar v a
  4792.    return v
  4793. emptySampleVar :: SampleVar a -> IO ()
  4794. emptySampleVar v
  4795.  = takeMVar v         >>= \ (readers,var) ->
  4796.    if readers >= 0 then
  4797.      putMVar v (0,var)
  4798.    else
  4799.      putMVar v (readers,var)
  4800. -- filled => make empty and grab sample
  4801. -- not filled => try to grab value, empty when read val.
  4802. readSampleVar :: SampleVar a -> IO a
  4803. readSampleVar svar
  4804.  = takeMVar svar                >>= \ (readers,val) ->
  4805.    putMVar svar (readers-1,val) >>
  4806.    takeMVar val
  4807. -- filled => overwrite
  4808. -- not filled => fill, write val
  4809. writeSampleVar :: SampleVar a -> a -> IO ()
  4810. writeSampleVar svar v
  4811.  = takeMVar svar  >>= \ (readers, val) ->
  4812.    case readers of
  4813.      1 -> 
  4814.        swapMVar val v         >> 
  4815.        putMVar svar (1,val)
  4816.      _ -> 
  4817.        putMVar val v >> 
  4818.        putMVar svar (min 1 (readers+1), val)
  4819. \end{code}
  4820. *********************************************************************************
  4821. *                                                                               *
  4822. *       John Hughes's and Simon Peyton Jones's Pretty Printer Combinators       *
  4823. *                                                                               *
  4824. *               based on "The Design of a Pretty-printing Library"              *
  4825. *               in Advanced Functional Programming,                             *
  4826. *               Johan Jeuring and Erik Meijer (eds), LNCS 925                   *
  4827. *               http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps                *
  4828. *                                                                               *
  4829. *               Heavily modified by Simon Peyton Jones, Dec 96                  *
  4830. *                                                                               *
  4831. *********************************************************************************
  4832. Version 3.0     28 May 1997
  4833.   * Cured massive performance bug.  If you write
  4834.         foldl <> empty (map (text.show) [1..10000])
  4835.     you get quadratic behaviour with V2.0.  Why?  For just the same reason as you get
  4836.     quadratic behaviour with left-associated (++) chains.
  4837.     This is really bad news.  One thing a pretty-printer abstraction should
  4838.     certainly guarantee is insensivity to associativity.  It matters: suddenly
  4839.     GHC's compilation times went up by a factor of 100 when I switched to the
  4840.     new pretty printer.
  4841.     I fixed it with a bit of a hack (because I wanted to get GHC back on the
  4842.     road).  I added two new constructors to the Doc type, Above and Beside:
  4843.          <> = Beside
  4844.          $$ = Above
  4845.     Then, where I need to get to a "TextBeside" or "NilAbove" form I "force"
  4846.     the Doc to squeeze out these suspended calls to Beside and Above; but in so
  4847.     doing I re-associate. It's quite simple, but I'm not satisfied that I've done
  4848.     the best possible job.  I'll send you the code if you are interested.
  4849.   * Added new exports:
  4850.         punctuate, hang
  4851.         int, integer, float, double, rational,
  4852.         lparen, rparen, lbrack, rbrack, lbrace, rbrace,
  4853.   * fullRender's type signature has changed.  Rather than producing a string it
  4854.     now takes an extra couple of arguments that tells it how to glue fragments
  4855.     of output together:
  4856.         fullRender :: Mode
  4857.                    -> Int                       -- Line length
  4858.                    -> Float                     -- Ribbons per line
  4859.                    -> (TextDetails -> a -> a)   -- What to do with text
  4860.                    -> a                         -- What to do at the end
  4861.                    -> Doc
  4862.                    -> a                         -- Result
  4863.     The "fragments" are encapsulated in the TextDetails data type:
  4864.         data TextDetails = Chr  Char
  4865.                          | Str  String
  4866.                          | PStr FAST_STRING
  4867.     The Chr and Str constructors are obvious enough.  The PStr constructor has a packed
  4868.     string (FAST_STRING) inside it.  It's generated by using the new "ptext" export.
  4869.     An advantage of this new setup is that you can get the renderer to do output
  4870.     directly (by passing in a function of type (TextDetails -> IO () -> IO ()),
  4871.     rather than producing a string that you then print.
  4872. Version 2.0     24 April 1997
  4873.   * Made empty into a left unit for <> as well as a right unit;
  4874.     it is also now true that
  4875.         nest k empty = empty
  4876.     which wasn't true before.
  4877.   * Fixed an obscure bug in sep that occassionally gave very wierd behaviour
  4878.   * Added $+$
  4879.   * Corrected and tidied up the laws and invariants
  4880. ======================================================================
  4881. Relative to John's original paper, there are the following new features:
  4882. 1.  There's an empty document, "empty".  It's a left and right unit for 
  4883.     both <> and $$, and anywhere in the argument list for
  4884.     sep, hcat, hsep, vcat, fcat etc.
  4885.     It is Really Useful in practice.
  4886. 2.  There is a paragraph-fill combinator, fsep, that's much like sep,
  4887.     only it keeps fitting things on one line until itc can't fit any more.
  4888. 3.  Some random useful extra combinators are provided.  
  4889.         <+> puts its arguments beside each other with a space between them,
  4890.             unless either argument is empty in which case it returns the other
  4891.         hcat is a list version of <>
  4892.         hsep is a list version of <+>
  4893.         vcat is a list version of $$
  4894.         sep (separate) is either like hsep or like vcat, depending on what fits
  4895.         cat  is behaves like sep,  but it uses <> for horizontal conposition
  4896.         fcat is behaves like fsep, but it uses <> for horizontal conposition
  4897.         These new ones do the obvious things:
  4898.                 char, semi, comma, colon, space,
  4899.                 parens, brackets, braces, 
  4900.                 quotes, doubleQuotes
  4901.         
  4902. 4.      The "above" combinator, $$, now overlaps its two arguments if the
  4903.         last line of the top argument stops before the first line of the second begins.
  4904.         For example:  text "hi" $$ nest 5 "there"
  4905.         lays out as
  4906.                         hi   there
  4907.         rather than
  4908.                         hi
  4909.                              there
  4910.         There are two places this is really useful
  4911.         a) When making labelled blocks, like this:
  4912.                 Left ->   code for left
  4913.                 Right ->  code for right
  4914.                 LongLongLongLabel ->
  4915.                           code for longlonglonglabel
  4916.            The block is on the same line as the label if the label is
  4917.            short, but on the next line otherwise.
  4918.         b) When laying out lists like this:
  4919.                 [ first
  4920.                 , second
  4921.                 , third
  4922.                 ]
  4923.            which some people like.  But if the list fits on one line
  4924.            you want [first, second, third].  You can't do this with
  4925.            John's original combinators, but it's quite easy with the
  4926.            new $$.
  4927.         The combinator $+$ gives the original "never-overlap" behaviour.
  4928. 5.      Several different renderers are provided:
  4929.                 * a standard one
  4930.                 * one that uses cut-marks to avoid deeply-nested documents 
  4931.                         simply piling up in the right-hand margin
  4932.                 * one that ignores indentation (fewer chars output; good for machines)
  4933.                 * one that ignores indentation and newlines (ditto, only more so)
  4934. 6.      Numerous implementation tidy-ups
  4935.         Use of unboxed data types to speed up the implementation
  4936. \begin{code}
  4937. module Pretty (
  4938.         Doc,            -- Abstract
  4939.         Mode(..), TextDetails(..),
  4940.         empty, isEmpty, nest,
  4941.         text, char, ptext,
  4942.         int, integer, float, double, rational,
  4943.         parens, brackets, braces, quotes, doubleQuotes,
  4944.         semi, comma, colon, space, equals,
  4945.         lparen, rparen, lbrack, rbrack, lbrace, rbrace,
  4946.         (<>), (<+>), hcat, hsep, 
  4947.         ($$), ($+$), vcat, 
  4948.         sep, cat, 
  4949.         fsep, fcat, 
  4950.         hang, punctuate,
  4951.         
  4952. --      renderStyle,            -- Haskell 1.3 only
  4953.         render, fullRender
  4954.   ) where
  4955. -- Don't import Util( assertPanic ) because it makes a loop in the module structure
  4956. infixl 6 <> 
  4957. infixl 6 <+>
  4958. infixl 5 $$, $+$
  4959. \end{code}
  4960. *********************************************************
  4961. *                                                       *
  4962. \subsection{CPP magic so that we can compile with both GHC and Hugs}
  4963. *                                                       *
  4964. *********************************************************
  4965. The library uses unboxed types to get a bit more speed, but these CPP macros
  4966. allow you to use either GHC or Hugs.  To get GHC, just set the CPP variable
  4967.         __GLASGOW_HASKELL__
  4968. *********************************************************
  4969. *                                                       *
  4970. \subsection{The interface}
  4971. *                                                       *
  4972. *********************************************************
  4973. The primitive @Doc@ values
  4974. \begin{code}
  4975. empty                     :: Doc
  4976. isEmpty                   :: Doc    -> Bool
  4977. text                      :: String -> Doc 
  4978. char                      :: Char -> Doc
  4979. semi, comma, colon, space, equals              :: Doc
  4980. lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc
  4981. parens, brackets, braces  :: Doc -> Doc 
  4982. quotes, doubleQuotes      :: Doc -> Doc
  4983. int      :: Int -> Doc
  4984. integer  :: Integer -> Doc
  4985. float    :: Float -> Doc
  4986. double   :: Double -> Doc
  4987. rational :: Rational -> Doc
  4988. \end{code}
  4989. Combining @Doc@ values
  4990. \begin{code}
  4991. (<>)   :: Doc -> Doc -> Doc     -- Beside
  4992. hcat   :: [Doc] -> Doc          -- List version of <>
  4993. (<+>)  :: Doc -> Doc -> Doc     -- Beside, separated by space
  4994. hsep   :: [Doc] -> Doc          -- List version of <+>
  4995. ($$)   :: Doc -> Doc -> Doc     -- Above; if there is no
  4996.                                 -- overlap it "dovetails" the two
  4997. vcat   :: [Doc] -> Doc          -- List version of $$
  4998. cat    :: [Doc] -> Doc          -- Either hcat or vcat
  4999. sep    :: [Doc] -> Doc          -- Either hsep or vcat
  5000. fcat   :: [Doc] -> Doc          -- ``Paragraph fill'' version of cat
  5001. fsep   :: [Doc] -> Doc          -- ``Paragraph fill'' version of sep
  5002. nest   :: Int -> Doc -> Doc     -- Nested
  5003. \end{code}
  5004. GHC-specific ones.
  5005. \begin{code}
  5006. hang :: Doc -> Int -> Doc -> Doc
  5007. punctuate :: Doc -> [Doc] -> [Doc]      -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn]
  5008. \end{code}
  5009. Displaying @Doc@ values. 
  5010. \begin{code}
  5011. instance Show Doc where
  5012.   showsPrec prec doc cont = showDoc doc cont
  5013. render     :: Doc -> String             -- Uses default style
  5014. fullRender :: Mode
  5015.            -> Int                       -- Line length
  5016.            -> Float                     -- Ribbons per line
  5017.            -> (TextDetails -> a -> a)   -- What to do with text
  5018.            -> a                         -- What to do at the end
  5019.            -> Doc
  5020.            -> a                         -- Result
  5021. {-      When we start using 1.3 
  5022. renderStyle  :: Style -> Doc -> String
  5023. data Style = Style { lineLength     :: Int,     -- In chars
  5024.                      ribbonsPerLine :: Float,   -- Ratio of ribbon length to line length
  5025.                      mode :: Mode
  5026.              }
  5027. style :: Style          -- The default style
  5028. style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
  5029. data Mode = PageMode            -- Normal 
  5030.           | ZigZagMode          -- With zig-zag cuts
  5031.           | LeftMode            -- No indentation, infinitely long lines
  5032.           | OneLineMode         -- All on one line
  5033. \end{code}
  5034. *********************************************************
  5035. *                                                       *
  5036. \subsection{The @Doc@ calculus}
  5037. *                                                       *
  5038. *********************************************************
  5039. The @Doc@ combinators satisfy the following laws:
  5040. \begin{verbatim}
  5041. Laws for $$
  5042. ~~~~~~~~~~~
  5043. <a1>    (x $$ y) $$ z   = x $$ (y $$ z)
  5044. <a2>    empty $$ x      = x
  5045. <a3>    x $$ empty      = x
  5046.         ...ditto $+$...
  5047. Laws for <>
  5048. ~~~~~~~~~~~
  5049. <b1>    (x <> y) <> z   = x <> (y <> z)
  5050. <b2>    empty <> x      = empty
  5051. <b3>    x <> empty      = x
  5052.         ...ditto <+>...
  5053. Laws for text
  5054. ~~~~~~~~~~~~~
  5055. <t1>    text s <> text t        = text (s++t)
  5056. <t2>    text "" <> x            = x, if x non-empty
  5057. Laws for nest
  5058. ~~~~~~~~~~~~~
  5059. <n1>    nest 0 x                = x
  5060. <n2>    nest k (nest k' x)      = nest (k+k') x
  5061. <n3>    nest k (x <> y)         = nest k z <> nest k y
  5062. <n4>    nest k (x $$ y)         = nest k x $$ nest k y
  5063. <n5>    nest k empty            = empty
  5064. <n6>    x <> nest k y           = x <> y, if x non-empty
  5065. ** Note the side condition on <n6>!  It is this that
  5066. ** makes it OK for empty to be a left unit for <>.
  5067. Miscellaneous
  5068. ~~~~~~~~~~~~~
  5069. <m1>    (text s <> x) $$ y = text s <> ((text "" <> x)) $$ 
  5070.                                          nest (-length s) y)
  5071. <m2>    (x $$ y) <> z = x $$ (y <> z)
  5072.         if y non-empty
  5073. Laws for list versions
  5074. ~~~~~~~~~~~~~~~~~~~~~~
  5075. <l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)
  5076.         ...ditto hsep, hcat, vcat, fill...
  5077. <l2>    nest k (sep ps) = sep (map (nest k) ps)
  5078.         ...ditto hsep, hcat, vcat, fill...
  5079. Laws for oneLiner
  5080. ~~~~~~~~~~~~~~~~~
  5081. <o1>    oneLiner (nest k p) = nest k (oneLiner p)
  5082. <o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y 
  5083. \end{verbatim}
  5084. You might think that the following verion of <m1> would
  5085. be neater:
  5086. \begin{verbatim}
  5087. <3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$ 
  5088.                                          nest (-length s) y)
  5089. \end{verbatim}
  5090. But it doesn't work, for if x=empty, we would have
  5091. \begin{verbatim}
  5092.         text s $$ y = text s <> (empty $$ nest (-length s) y)
  5093.                     = text s <> nest (-length s) y
  5094. \end{verbatim}
  5095. *********************************************************
  5096. *                                                       *
  5097. \subsection{Simple derived definitions}
  5098. *                                                       *
  5099. *********************************************************
  5100. \begin{code}
  5101. semi  = char ';'
  5102. colon = char ':'
  5103. comma = char ','
  5104. space = char ' '
  5105. equals = char '='
  5106. lparen = char '('
  5107. rparen = char ')'
  5108. lbrack = char '['
  5109. rbrack = char ']'
  5110. lbrace = char '{'
  5111. rbrace = char '}'
  5112. int      n = text (show n)
  5113. integer  n = text (show n)
  5114. float    n = text (show n)
  5115. double   n = text (show n)
  5116. rational n = text (show n)
  5117. -- SIGBJORN wrote instead:
  5118. -- rational n = text (show (fromRationalX n))
  5119. quotes p        = char '`' <> p <> char '\''
  5120. doubleQuotes p  = char '"' <> p <> char '"'
  5121. parens p        = char '(' <> p <> char ')'
  5122. brackets p      = char '[' <> p <> char ']'
  5123. braces p        = char '{' <> p <> char '}'
  5124. hcat = foldr (<>)  empty
  5125. hsep = foldr (<+>) empty
  5126. vcat = foldr ($$)  empty
  5127. hang d1 n d2 = sep [d1, nest n d2]
  5128. punctuate p []     = []
  5129. punctuate p (d:ds) = go d ds
  5130.                    where
  5131.                      go d [] = [d]
  5132.                      go d (e:es) = (d <> p) : go e es
  5133. \end{code}
  5134. *********************************************************
  5135. *                                                       *
  5136. \subsection{The @Doc@ data type}
  5137. *                                                       *
  5138. *********************************************************
  5139. A @Doc@ represents a {\em set} of layouts.  A @Doc@ with
  5140. no occurrences of @Union@ or @NoDoc@ represents just one layout.
  5141. \begin{code}
  5142. data Doc
  5143.  = Empty                                -- empty
  5144.  | NilAbove Doc                         -- text "" $$ x
  5145.  | TextBeside TextDetails Int Doc       -- text s <> x  
  5146.  | Nest Int Doc                         -- nest k x
  5147.  | Union Doc Doc                        -- ul `union` ur
  5148.  | NoDoc                                -- The empty set of documents
  5149.  | Beside Doc Bool Doc                  -- True <=> space between
  5150.  | Above  Doc Bool Doc                  -- True <=> never overlap
  5151. type RDoc = Doc         -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside
  5152. reduceDoc :: Doc -> RDoc
  5153. reduceDoc (Beside p g q) = beside p g (reduceDoc q)
  5154. reduceDoc (Above  p g q) = above  p g (reduceDoc q)
  5155. reduceDoc p              = p
  5156. data TextDetails = Chr  Char
  5157.                  | Str  String
  5158.                  | PStr String
  5159. space_text = Chr ' '
  5160. nl_text    = Chr '\n'
  5161. \end{code}
  5162. Here are the invariants:
  5163. \begin{itemize}
  5164. \item
  5165. The argument of @NilAbove@ is never @Empty@. Therefore
  5166. a @NilAbove@ occupies at least two lines.
  5167. \item
  5168. The arugment of @TextBeside@ is never @Nest@.
  5169. \item 
  5170. The layouts of the two arguments of @Union@ both flatten to the same string.
  5171. \item 
  5172. The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
  5173. \item
  5174. The right argument of a union cannot be equivalent to the empty set (@NoDoc@).
  5175. If the left argument of a union is equivalent to the empty set (@NoDoc@),
  5176. then the @NoDoc@ appears in the first line.
  5177. \item 
  5178. An empty document is always represented by @Empty@.
  5179. It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s.
  5180. \item 
  5181. The first line of every layout in the left argument of @Union@
  5182. is longer than the first line of any layout in the right argument.
  5183. (1) ensures that the left argument has a first line.  In view of (3),
  5184. this invariant means that the right argument must have at least two
  5185. lines.
  5186. \end{itemize}
  5187. \begin{code}
  5188.         -- Arg of a NilAbove is always an RDoc
  5189. nilAbove_ p = NilAbove p
  5190.         -- Arg of a TextBeside is always an RDoc
  5191. textBeside_ s sl p = TextBeside s sl p
  5192.         -- Arg of Nest is always an RDoc
  5193. nest_ k p = Nest k p
  5194.         -- Args of union are always RDocs
  5195. union_ p q = Union p q
  5196. \end{code}
  5197. Notice the difference between
  5198.         * NoDoc (no documents)
  5199.         * Empty (one empty document; no height and no width)
  5200.         * text "" (a document containing the empty string;
  5201.                    one line high, but has no width)
  5202. *********************************************************
  5203. *                                                       *
  5204. \subsection{@empty@, @text@, @nest@, @union@}
  5205. *                                                       *
  5206. *********************************************************
  5207. \begin{code}
  5208. empty = Empty
  5209. isEmpty Empty = True
  5210. isEmpty _     = False
  5211. char  c = textBeside_ (Chr c) 1 Empty
  5212. text  s = case length   s of {sl -> textBeside_ (Str s)  sl Empty}
  5213. ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}
  5214. nest k  p = mkNest k (reduceDoc p)        -- Externally callable version
  5215. -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
  5216. mkNest k       (Nest k1 p) = mkNest (k + k1) p
  5217. mkNest k       NoDoc       = NoDoc
  5218. mkNest k       Empty       = Empty
  5219. mkNest 0       p           = p                  -- Worth a try!
  5220. mkNest k       p           = nest_ k p
  5221. -- mkUnion checks for an empty document
  5222. mkUnion Empty q = Empty
  5223. mkUnion p q     = p `union_` q
  5224. \end{code}
  5225. *********************************************************
  5226. *                                                       *
  5227. \subsection{Vertical composition @$$@}
  5228. *                                                       *
  5229. *********************************************************
  5230. \begin{code}
  5231. p $$  q = Above p False q
  5232. p $+$ q = Above p True q
  5233. above :: Doc -> Bool -> RDoc -> RDoc
  5234. above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
  5235. above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g 0 (reduceDoc q)
  5236. above p g q                  = aboveNest p             g 0 (reduceDoc q)
  5237. aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
  5238. -- Specfication: aboveNest p g k q = p $g$ (nest k q)
  5239. aboveNest NoDoc               g k q = NoDoc
  5240. aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_` 
  5241.                                       aboveNest p2 g k q
  5242.                                 
  5243. aboveNest Empty               g k q = mkNest k q
  5244. aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k - k1) q)
  5245.                                   -- p can't be Empty, so no need for mkNest
  5246.                                 
  5247. aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
  5248. aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
  5249.                                     where
  5250.                                       k1   = k - sl
  5251.                                       rest = case p of
  5252.                                                 Empty -> nilAboveNest g k1 q
  5253.                                                 other -> aboveNest  p g k1 q
  5254. \end{code}
  5255. \begin{code}
  5256. nilAboveNest :: Bool -> Int -> RDoc -> RDoc
  5257. -- Specification: text s <> nilaboveNest g k q 
  5258. --              = text s <> (text "" $g$ nest k q)
  5259. nilAboveNest g k Empty       = Empty    -- Here's why the "text s <>" is in the spec!
  5260. nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
  5261. nilAboveNest g k q           | (not g) && (k > 0)        -- No newline if no overlap
  5262.                              = textBeside_ (Str (spaces k)) k q
  5263.                              | otherwise                        -- Put them really above
  5264.                              = nilAbove_ (mkNest k q)
  5265. \end{code}
  5266. *********************************************************
  5267. *                                                       *
  5268. \subsection{Horizontal composition @<>@}
  5269. *                                                       *
  5270. *********************************************************
  5271. \begin{code}
  5272. p <>  q = Beside p False q
  5273. p <+> q = Beside p True  q
  5274. beside :: Doc -> Bool -> RDoc -> RDoc
  5275. -- Specification: beside g p q = p <g> q
  5276. beside NoDoc               g q   = NoDoc
  5277. beside (p1 `Union` p2)     g q   = (beside p1 g q) `union_` (beside p2 g q)
  5278. beside Empty               g q   = q
  5279. beside (Nest k p)          g q   = nest_ k (beside p g q)       -- p non-empty
  5280. beside p@(Beside p1 g1 q1) g2 q2 
  5281.            {- (A `op1` B) `op2` C == A `op1` (B `op2` C)  iff op1 == op2 
  5282.                                                  [ && (op1 == <> || op1 == <+>) ] -}
  5283.          | g1 == g2              = beside p1 g1 (beside q1 g2 q2)
  5284.          | otherwise             = beside (reduceDoc p) g2 q2
  5285. beside p@(Above _ _ _)     g q   = beside (reduceDoc p) g q
  5286. beside (NilAbove p)        g q   = nilAbove_ (beside p g q)
  5287. beside (TextBeside s sl p) g q   = textBeside_ s sl rest
  5288.                                where
  5289.                                   rest = case p of
  5290.                                            Empty -> nilBeside g q
  5291.                                            other -> beside p g q
  5292. \end{code}
  5293. \begin{code}
  5294. nilBeside :: Bool -> RDoc -> RDoc
  5295. -- Specification: text "" <> nilBeside g p 
  5296. --              = text "" <g> p
  5297. nilBeside g Empty      = Empty  -- Hence the text "" in the spec
  5298. nilBeside g (Nest _ p) = nilBeside g p
  5299. nilBeside g p          | g         = textBeside_ space_text 1 p
  5300.                        | otherwise = p
  5301. \end{code}
  5302. *********************************************************
  5303. *                                                       *
  5304. \subsection{Separate, @sep@, Hughes version}
  5305. *                                                       *
  5306. *********************************************************
  5307. \begin{code}
  5308. -- Specification: sep ps  = oneLiner (hsep ps)
  5309. --                         `union`
  5310. --                          vcat ps
  5311. sep = sepX True         -- Separate with spaces
  5312. cat = sepX False        -- Don't
  5313. sepX x []     = empty
  5314. sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
  5315. -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
  5316. --                            = oneLiner (x <g> nest k (hsep ys))
  5317. --                              `union` x $$ nest k (vcat ys)
  5318. sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
  5319. sep1 g NoDoc               k ys = NoDoc
  5320. sep1 g (p `Union` q)       k ys = sep1 g p k ys
  5321.                                   `union_`
  5322.                                   (aboveNest q False k (reduceDoc (vcat ys)))
  5323. sep1 g Empty               k ys = mkNest k (sepX g ys)
  5324. sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k - n) ys)
  5325. sep1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))
  5326. sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
  5327. -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
  5328. -- Called when we have already found some text in the first item
  5329. -- We have to eat up nests
  5330. sepNB g (Nest _ p)  k ys  = sepNB g p k ys
  5331. sepNB g Empty k ys        = oneLiner (nilBeside g (reduceDoc rest))
  5332.                                 `mkUnion` 
  5333.                             nilAboveNest False k (reduceDoc (vcat ys))
  5334.                           where
  5335.                             rest | g         = hsep ys
  5336.                                  | otherwise = hcat ys
  5337. sepNB g p k ys            = sep1 g p k ys
  5338. \end{code}
  5339. *********************************************************
  5340. *                                                       *
  5341. \subsection{@fill@}
  5342. *                                                       *
  5343. *********************************************************
  5344. \begin{code}
  5345. fsep = fill True
  5346. fcat = fill False
  5347. -- Specification: 
  5348. --   fill []  = empty
  5349. --   fill [p] = p
  5350. --   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) 
  5351. --                                          (fill (oneLiner p2 : ps))
  5352. --                     `union`
  5353. --                      p1 $$ fill ps
  5354. fill g []     = empty
  5355. fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
  5356. fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
  5357. fill1 g NoDoc               k ys = NoDoc
  5358. fill1 g (p `Union` q)       k ys = fill1 g p k ys
  5359.                                    `union_`
  5360.                                    (aboveNest q False k (fill g ys))
  5361. fill1 g Empty               k ys = mkNest k (fill g ys)
  5362. fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)
  5363. fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
  5364. fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
  5365. fillNB g (Nest _ p)  k ys  = fillNB g p k ys
  5366. fillNB g Empty k []        = Empty
  5367. fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
  5368.                              `mkUnion` 
  5369.                              nilAboveNest False k (fill g (y:ys))
  5370.                            where
  5371.                              k1 | g         = k - 1
  5372.                                 | otherwise = k
  5373. fillNB g p k ys            = fill1 g p k ys
  5374. \end{code}
  5375. *********************************************************
  5376. *                                                       *
  5377. \subsection{Selecting the best layout}
  5378. *                                                       *
  5379. *********************************************************
  5380. \begin{code}
  5381. best :: Mode
  5382.      -> Int             -- Line length
  5383.      -> Int             -- Ribbon length
  5384.      -> RDoc
  5385.      -> RDoc            -- No unions in here!
  5386. best OneLineMode w r p
  5387.   = get p
  5388.   where
  5389.     get Empty               = Empty
  5390.     get NoDoc               = NoDoc
  5391.     get (NilAbove p)        = nilAbove_ (get p)
  5392.     get (TextBeside s sl p) = textBeside_ s sl (get p)
  5393.     get (Nest k p)          = get p             -- Elide nest
  5394.     get (p `Union` q)       = first (get p) (get q)
  5395. best mode w r p
  5396.   = get w p
  5397.   where
  5398.     get :: Int          -- (Remaining) width of line
  5399.         -> Doc -> Doc
  5400.     get w Empty               = Empty
  5401.     get w NoDoc               = NoDoc
  5402.     get w (NilAbove p)        = nilAbove_ (get w p)
  5403.     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
  5404.     get w (Nest k p)          = nest_ k (get (w - k) p)
  5405.     get w (p `Union` q)       = nicest w r (get w p) (get w q)
  5406.     get1 :: Int         -- (Remaining) width of line
  5407.          -> Int         -- Amount of first line already eaten up
  5408.          -> Doc         -- This is an argument to TextBeside => eat Nests
  5409.          -> Doc         -- No unions in here!
  5410.     get1 w sl Empty               = Empty
  5411.     get1 w sl NoDoc               = NoDoc
  5412.     get1 w sl (NilAbove p)        = nilAbove_ (get (w - sl) p)
  5413.     get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
  5414.     get1 w sl (Nest k p)          = get1 w sl p
  5415.     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p) 
  5416.                                                    (get1 w sl q)
  5417. nicest w r p q = nicest1 w r 0 p q
  5418. nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p
  5419.                    | otherwise                   = q
  5420. fits :: Int     -- Space available
  5421.      -> Doc
  5422.      -> Bool    -- True if *first line* of Doc fits in space available
  5423. fits n p    | n < 0 = False
  5424. fits n NoDoc               = False
  5425. fits n Empty               = True
  5426. fits n (NilAbove _)        = True
  5427. fits n (TextBeside _ sl p) = fits (n - sl) p
  5428. minn x y | x < y    = x
  5429.          | otherwise = y
  5430. \end{code}
  5431. @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.
  5432. @first@ returns its first argument if it is non-empty, otherwise its second.
  5433. \begin{code}
  5434. first p q | nonEmptySet p = p 
  5435.           | otherwise     = q
  5436. nonEmptySet NoDoc           = False
  5437. nonEmptySet (p `Union` q)      = True
  5438. nonEmptySet Empty              = True
  5439. nonEmptySet (NilAbove p)       = True           -- NoDoc always in first line
  5440. nonEmptySet (TextBeside _ _ p) = nonEmptySet p
  5441. nonEmptySet (Nest _ p)         = nonEmptySet p
  5442. \end{code}
  5443. @oneLiner@ returns the one-line members of the given set of @Doc@s.
  5444. \begin{code}
  5445. oneLiner :: Doc -> Doc
  5446. oneLiner NoDoc               = NoDoc
  5447. oneLiner Empty               = Empty
  5448. oneLiner (NilAbove p)        = NoDoc
  5449. oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
  5450. oneLiner (Nest k p)          = nest_ k (oneLiner p)
  5451. oneLiner (p `Union` q)       = oneLiner p
  5452. \end{code}
  5453. *********************************************************
  5454. *                                                       *
  5455. \subsection{Displaying the best layout}
  5456. *                                                       *
  5457. *********************************************************
  5458. \begin{code}
  5459. renderStyle Style{mode, lineLength, ribbonsPerLine} doc 
  5460.   = fullRender mode lineLength ribbonsPerLine doc ""
  5461. render doc       = showDoc doc ""
  5462. showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc
  5463. string_txt (Chr c)   s  = c:s
  5464. string_txt (Str s1)  s2 = s1 ++ s2
  5465. string_txt (PStr s1) s2 = s1 ++ s2
  5466. \end{code}
  5467. \begin{code}
  5468. fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)
  5469. fullRender LeftMode    _ _ txt end doc = easy_display nl_text    txt end (reduceDoc doc)
  5470. fullRender mode line_length ribbons_per_line txt end doc
  5471.   = display mode line_length ribbon_length txt end best_doc
  5472.   where 
  5473.     best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc)
  5474.     hacked_line_length, ribbon_length :: Int
  5475.     ribbon_length = round (fromIntegral line_length / ribbons_per_line)
  5476.     hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length }
  5477. display mode page_width ribbon_width txt end doc
  5478.   = case page_width - ribbon_width of { gap_width ->
  5479.     case gap_width `quot` 2 of { shift ->
  5480.     let
  5481.         lay k (Nest k1 p)  = lay (k + k1) p
  5482.         lay k Empty        = end
  5483.         lay k (NilAbove p) = nl_text `txt` lay k p
  5484.         lay k (TextBeside s sl p)
  5485.             = case mode of
  5486.                     ZigZagMode |  k >= gap_width
  5487.                                -> nl_text `txt` (
  5488.                                   Str (multi_ch shift '/') `txt` (
  5489.                                   nl_text `txt` (
  5490.                                   lay1 (k - shift) s sl p)))
  5491.                                |  k < 0
  5492.                                -> nl_text `txt` (
  5493.                                   Str (multi_ch shift '\\') `txt` (
  5494.                                   nl_text `txt` (
  5495.                                   lay1 (k + shift) s sl p )))
  5496.                     other -> lay1 k s sl p
  5497.         lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p)
  5498.         lay2 k (NilAbove p)        = nl_text `txt` lay k p
  5499.         lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p)
  5500.         lay2 k (Nest _ p)          = lay2 k p
  5501.         lay2 k Empty               = end
  5502.     in
  5503.     lay 0 doc
  5504.     }}
  5505. cant_fail = error "easy_display: NoDoc"
  5506. easy_display nl_text txt end doc 
  5507.   = lay doc cant_fail
  5508.   where
  5509.     lay NoDoc               no_doc = no_doc
  5510.     lay (Union p q)         no_doc = {- lay p -} (lay q cant_fail)              -- Second arg can't be NoDoc
  5511.     lay (Nest k p)          no_doc = lay p no_doc
  5512.     lay Empty               no_doc = end
  5513.     lay (NilAbove p)        no_doc = nl_text `txt` lay p cant_fail      -- NoDoc always on first line
  5514.     lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc
  5515. indent n | n >= 8 = '\t' : indent (n - 8)
  5516.          | otherwise      = spaces n
  5517. multi_ch 0 ch = ""
  5518. multi_ch n       ch = ch : multi_ch (n - 1) ch
  5519. spaces 0 = ""
  5520. spaces n       = ' ' : spaces (n - 1)
  5521. \end{code}
  5522. module NumExts
  5523.     ( doubleToFloat
  5524.     , floatToDouble
  5525.     ) where
  5526. primitive doubleToFloat :: Double -> Float
  5527. primitive floatToDouble :: Float -> Double
  5528. {-----------------------------------------------------------------------------
  5529.                    A LIBRARY OF MEMOIZATION COMBINATORS
  5530.                             15th September 1999
  5531.                              Byron Cook
  5532.                         OGI
  5533. This Hugs module implements several flavors of memoization functions,
  5534. as described in Haskell Workshop 1997.
  5535. -----------------------------------------------------------------------------}
  5536. module Memo(
  5537.         memo,  
  5538.         memoN,  
  5539.         memoFix,
  5540.         memoFixN,
  5541.         cache, 
  5542.         cacheN, 
  5543.         cacheFix,
  5544.         cacheFixN
  5545.         ) where
  5546. import ST
  5547. -- import IOExts (unsafePtrEq, trace)
  5548. memo      :: (a -> b) -> (a -> b)
  5549. memoN     :: Int -> (a -> b) -> (a -> b)
  5550. memoFix   :: ((a -> b) -> (a -> b)) -> (a -> b)
  5551. memoFixN  :: Int -> ((a -> b) -> (a -> b)) -> (a -> b)
  5552. cache     :: (a -> b) -> (a -> b)
  5553. cacheN    :: Int -> (a -> b) -> (a -> b)
  5554. cacheFix  :: ((a -> b) -> (a -> b)) -> (a -> b)
  5555. cacheFixN :: Int -> ((a -> b) -> (a -> b)) -> (a -> b)
  5556. ----------------------------------------------------------------
  5557. -- Memoization Functions (memo-tables are hash-tables)
  5558. ----------------------------------------------------------------
  5559. memo          = memoN defaultSize 
  5560. memoN         = mkMemo eql hash 
  5561. memoFix       = memoFixN defaultSize 
  5562. memoFixN n f  = let g = f h
  5563.                     h = memoN n g
  5564.                 in g
  5565. ----------------------------------------------------------------
  5566. -- Caching Functions (memo-tables are caches)
  5567. ----------------------------------------------------------------
  5568. cache          = cacheN defaultSize
  5569. cacheN         = mkCache eql hash
  5570. cacheFix       = cacheFixN defaultSize
  5571. cacheFixN n f  = let g = f h
  5572.                      h = cacheN n g
  5573.                  in g
  5574. ----------------------------------------------------------------
  5575. -- Type synonyms
  5576. ----------------------------------------------------------------
  5577. type TaintedEq a   = a -> a -> ST Mem Bool
  5578. type HashTable a b = STArray Mem Int [(a,b)]
  5579. type Cache a b     = STArray Mem Int (Maybe (a,b))
  5580. type HashSize      = Int
  5581. type HashFunc a    = a -> ST Mem Int
  5582. type Mem           = ()
  5583. ----------------------------------------------------------------
  5584. -- Foundation functions
  5585. ----------------------------------------------------------------
  5586. defaultSize :: HashSize
  5587. defaultSize = 40
  5588. memoize :: ST Mem t -> (t -> a -> b -> ST Mem b) -> 
  5589.            (a -> b) -> a -> b
  5590. memoize new access f = {-trace "memoize" $-} unsafeST $ do 
  5591.   t <- new
  5592.   return (\x -> unsafeST $ access t x (f x))
  5593. mkMemo  :: TaintedEq a -> HashFunc a -> Int -> (a -> c) -> (a -> c)
  5594. mkCache :: TaintedEq a -> HashFunc a -> Int -> (a -> c) -> (a -> c)
  5595. mkCache e h sz = memoize (newCache sz) (accessCache e h sz)
  5596. mkMemo  e h sz = memoize (newHash sz)  (accessHash e  h sz)
  5597. ----------------------------------------------------------------
  5598. -- Hash and Cache Tables
  5599. ----------------------------------------------------------------
  5600. accessHash  :: TaintedEq a ->  
  5601.                HashFunc a -> 
  5602.                Int -> 
  5603.                HashTable a b -> 
  5604.                a -> b -> ST Mem b
  5605. accessHash equal h sz table x v = do 
  5606.   hv' <- h x
  5607.   let hv = hv' `mod` sz
  5608.   l <- readSTArray table hv
  5609.   find l l hv
  5610.  where find l [] hv = {-trace "miss " $-} do
  5611.          u <- writeSTArray table  hv ((x,v):l) 
  5612.          case u of {() -> return v}
  5613.        find l ((x',v'):xs) hv = do
  5614.          a <- equal x x'
  5615.          if a then {-trace "hit "-} (return $ v')
  5616.           else find l xs hv
  5617. newHash :: Int -> ST Mem (HashTable a b)
  5618. newHash n = newSTArray (0,n) []
  5619. accessCache  :: TaintedEq a ->
  5620.                 HashFunc a ->
  5621.                 Int ->
  5622.                 Cache a b ->
  5623.                 a -> b -> ST Mem b
  5624. accessCache equal h sz table x v = do 
  5625.   hv' <- h x 
  5626.   let hv = hv' `mod` sz 
  5627.   l <-  readSTArray table hv
  5628.   case l of
  5629.      Nothing      -> do u <- writeSTArray table hv (Just (x,v))
  5630.                         case u of {() -> return v}
  5631.      Just (x',y)  -> do e <- equal x' x
  5632.                         if e then return y
  5633.                          else do u <- writeSTArray table hv (Just (x,v))
  5634.                                  case u of {() -> return v}
  5635. newCache :: Int -> ST Mem (Cache a b)
  5636. newCache n = newSTArray (0,n) Nothing
  5637. ------------------------------------------------------------------
  5638. -- These functions are bad --- dont pay attention to them
  5639. primitive primUnsafeCoerce "primUnsafeCoerce" :: a -> b  
  5640. unsafeST :: ST s a -> a
  5641. unsafeST m = fst (reifyST m ())
  5642. reifyST :: ST s a -> (b -> (a,b))
  5643. reifyST = primUnsafeCoerce
  5644. -- lisp style eql --- as described in "Lazy-memo functions"
  5645. primitive eql "STEql" :: a -> a -> ST Mem Bool
  5646. -- a `eql` b = return (a `unsafePtrEq` b)
  5647. -- hash based on addresses (or values if the arg is a base type)
  5648. primitive hash "STHash" :: a -> ST Mem Int
  5649. ------------------------------------------------------------------
  5650. -----------------------------------------------------------------------------
  5651. -- Lazy State Thread module
  5652. -- This library provides support for both lazy and strict state threads,
  5653. -- as described in the PLDI '94 paper by John Launchbury and Simon Peyton
  5654. -- Jones.  In addition to the monad ST, it also provides mutable variables
  5655. -- STRef and mutable arrays STArray.  It is identical to the ST module
  5656. -- except that the ST instance is lazy.
  5657. -- Suitable for use with Hugs 98.
  5658. -----------------------------------------------------------------------------
  5659. module LazyST 
  5660.     ( ST
  5661.     , runST
  5662.     , thenLazyST, thenStrictST, returnST
  5663.     , unsafeInterleaveST
  5664.     , fixST 
  5665.     , stToIO
  5666.     , unsafeIOtoST
  5667.     , STRef
  5668.       -- instance Eq (STRef s a)
  5669.     , newSTRef
  5670.     , readSTRef
  5671.     , writeSTRef 
  5672.         , STArray
  5673.           -- instance Eq (STArray s ix elt)
  5674.         , newSTArray
  5675.         , boundsSTArray
  5676.         , readSTArray
  5677.         , writeSTArray
  5678.         , thawSTArray
  5679.         , freezeSTArray
  5680.         , unsafeFreezeSTArray
  5681.         , Ix
  5682.     ) where
  5683. import Array(Array,Ix(index),bounds,assocs)
  5684. import IOExts(unsafePerformIO)
  5685. import Monad   
  5686. -----------------------------------------------------------------------------
  5687. data ST s a      -- implemented as an internal primitive
  5688. primitive runST                        :: (forall s. ST s a) -> a
  5689. primitive returnST     "STReturn"      :: a -> ST s a
  5690. primitive thenLazyST   "STLazyBind"    :: ST s a -> (a -> ST s b) -> ST s b
  5691. primitive thenStrictST "STStrictBind"  :: ST s a -> (a -> ST s b) -> ST s b
  5692. primitive unsafeInterleaveST "STInter" :: ST s a -> ST s a
  5693. primitive fixST        "STFix"         :: (a -> ST s a) -> ST s a
  5694. primitive stToIO    "primSTtoIO"   :: ST s a -> IO a
  5695. unsafeIOtoST        :: IO a -> ST s a
  5696. unsafeIOtoST         = returnST . unsafePerformIO
  5697. instance Functor (ST s) where
  5698.     fmap = liftM
  5699. instance Monad (ST s) where
  5700.     (>>=)  = thenLazyST
  5701.     return = returnST
  5702. -----------------------------------------------------------------------------
  5703. data STRef s a   -- implemented as an internal primitive
  5704. primitive newSTRef   "STNew"      :: a -> ST s (STRef s a)
  5705. primitive readSTRef  "STDeref"    :: STRef s a -> ST s a
  5706. primitive writeSTRef "STAssign"   :: STRef s a -> a -> ST s ()
  5707. primitive eqSTRef    "STMutVarEq" :: STRef s a -> STRef s a -> Bool
  5708. instance Eq (STRef s a) where (==) = eqSTRef
  5709. -----------------------------------------------------------------------------
  5710. data STArray s ix elt -- implemented as an internal primitive
  5711. newSTArray          :: Ix ix => (ix,ix) -> elt -> ST s (STArray s ix elt)
  5712. boundsSTArray       :: Ix ix => STArray s ix elt -> (ix, ix)
  5713. readSTArray         :: Ix ix => STArray s ix elt -> ix -> ST s elt
  5714. writeSTArray        :: Ix ix => STArray s ix elt -> ix -> elt -> ST s ()
  5715. thawSTArray         :: Ix ix => Array ix elt -> ST s (STArray s ix elt)
  5716. freezeSTArray       :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
  5717. unsafeFreezeSTArray :: Ix ix => STArray s ix elt -> ST s (Array ix elt)
  5718. newSTArray bs e      = primNewArr bs (rangeSize bs) e
  5719. boundsSTArray a      = primBounds a
  5720. readSTArray a i      = primReadArr index a i
  5721. writeSTArray a i e   = primWriteArr index a i e
  5722. thawSTArray arr      = newSTArray (bounds arr) err `thenStrictST` \ stArr ->
  5723.                let 
  5724.                          fillin [] = returnST stArr
  5725.                          fillin ((ix,v):ixvs) = writeSTArray stArr ix v
  5726.                           `thenStrictST` \ _ -> fillin ixvs
  5727.                in fillin (assocs arr)
  5728.  where
  5729.   err = error "thawArray: element not overwritten" -- shouldnae happen
  5730. freezeSTArray a      = primFreeze a
  5731. unsafeFreezeSTArray  = freezeSTArray  -- not as fast as GHC
  5732. instance Eq (STArray s ix elt) where
  5733.   (==) = eqSTArray
  5734. primitive primNewArr   "STNewArr"
  5735.           :: (a,a) -> Int -> b -> ST s (STArray s a b)
  5736. primitive primReadArr  "STReadArr"
  5737.           :: ((a,a) -> a -> Int) -> STArray s a b -> a -> ST s b
  5738. primitive primWriteArr "STWriteArr"
  5739.           :: ((a,a) -> a -> Int) -> STArray s a b -> a -> b -> ST s ()
  5740. primitive primFreeze   "STFreeze"
  5741.           :: STArray s a b -> ST s (Array a b)
  5742. primitive primBounds   "STBounds"
  5743.           :: STArray s a b -> (a,a)
  5744. primitive eqSTArray    "STArrEq"
  5745.           :: STArray s a b -> STArray s a b -> Bool
  5746. -----------------------------------------------------------------------------
  5747. -----------------------------------------------------------------------------
  5748. -- IO monad extensions:
  5749. -- Suitable for use with Hugs 98.
  5750. -----------------------------------------------------------------------------
  5751. module IOExts
  5752.     ( fixIO
  5753.     , unsafePerformIO
  5754.     , unsafeInterleaveIO
  5755.     , IORef
  5756.       -- instance Eq (IORef a)
  5757.     , newIORef
  5758.     , readIORef
  5759.     , writeIORef
  5760.         , IOArray
  5761.           -- instance Eq (IOArray ix elt)
  5762.         , newIOArray
  5763.         , boundsIOArray
  5764.         , readIOArray
  5765.         , writeIOArray
  5766.         , thawIOArray
  5767.         , freezeIOArray
  5768.         , unsafeFreezeIOArray
  5769.     , performGC
  5770.     , trace
  5771.     , unsafePtrEq
  5772.     , unsafePtrToInt
  5773.     ) where
  5774. import Trace( trace )
  5775. import IO( ioeGetErrorString )
  5776. import Array
  5777. -----------------------------------------------------------------------------
  5778. primitive performGC "primGC" :: IO ()
  5779. unsafePerformIO :: IO a -> a
  5780. unsafePerformIO m = performIO (runAndShowError m)
  5781. unsafeInterleaveIO :: IO a -> IO a
  5782. unsafeInterleaveIO m = interleaveIO (runAndShowError m)
  5783. primitive unsafePtrEq    :: a -> a -> Bool
  5784. primitive unsafePtrToInt :: a -> Int
  5785. fixIO :: (a -> IO a) -> IO a
  5786. fixIO m = IO fixIO'
  5787.  where
  5788.   fixIO' fail succ =
  5789.     case r of
  5790.     Hugs_Return a   -> succ a
  5791.     Hugs_Error err  -> fail err
  5792.     other           -> other
  5793.    where
  5794.     r = case m a of { IO ma -> ma Hugs_Error Hugs_Return }
  5795.     a = case r   of 
  5796.         Hugs_Return a  -> a
  5797.         Hugs_Error err -> error "IOExts:fixIO: thread exited with error"
  5798.         _              -> error "IOExts:fixIO: thread exited with no result"
  5799. performIO :: IO a -> a
  5800. performIO (IO m) = 
  5801.   case m Hugs_Error Hugs_Return of
  5802.   Hugs_Return a  -> a
  5803.   Hugs_Error err -> error "IOExts.performIO: thread exited with error"
  5804.   _              -> error "IOExts.performIO: thread exited with no result"
  5805. interleaveIO :: IO a -> IO a
  5806. interleaveIO (IO m) = IO (\ f s -> 
  5807.   s (case m Hugs_Error Hugs_Return of
  5808.      Hugs_Return a  -> a
  5809.      Hugs_Error err -> error "IOExts.interleaveIO: thread exited with error"
  5810.      _              -> error "IOExts.interleaveIO: thread exited with no result"
  5811.      ))
  5812. runAndShowError :: IO a -> IO a
  5813. runAndShowError m =
  5814.   m `catch` \err -> do 
  5815.       putChar '\n'
  5816.       putStr (ioeGetErrorString err)
  5817.       return undefined
  5818. -----------------------------------------------------------------------------
  5819. data IORef a        -- mutable variables containing values of type a
  5820. primitive newIORef   "newRef" :: a -> IO (IORef a)
  5821. primitive readIORef  "getRef" :: IORef a -> IO a
  5822. primitive writeIORef "setRef" :: IORef a -> a -> IO ()
  5823. primitive eqIORef    "eqRef"  :: IORef a -> IORef a -> Bool
  5824. instance Eq (IORef a) where
  5825.     (==) = eqIORef
  5826. -----------------------------------------------------------------------------
  5827. data IOArray ix elt -- implemented as an internal primitive
  5828. newIOArray          :: Ix ix => (ix,ix) -> elt -> IO (IOArray ix elt)
  5829. boundsIOArray       :: Ix ix => IOArray ix elt -> (ix, ix)
  5830. readIOArray         :: Ix ix => IOArray ix elt -> ix -> IO elt
  5831. writeIOArray        :: Ix ix => IOArray ix elt -> ix -> elt -> IO ()
  5832. thawIOArray         :: Ix ix => Array ix elt -> IO (IOArray ix elt)
  5833. freezeIOArray       :: Ix ix => IOArray ix elt -> IO (Array ix elt)
  5834. unsafeFreezeIOArray :: Ix ix => IOArray ix elt -> IO (Array ix elt)
  5835. newIOArray bs e      = primNewArr bs (rangeSize bs) e
  5836. boundsIOArray a      = primBounds a
  5837. readIOArray a i      = primReadArr index a i
  5838. writeIOArray a i e   = primWriteArr index a i e
  5839. thawIOArray arr      = do a <- newIOArray (bounds arr) err
  5840.               let fillin []          = return a
  5841.                   fillin((ix,v):ixs) = do writeIOArray a ix v
  5842.                                                       fillin ixs
  5843.                           fillin (assocs arr)
  5844.                        where err =  error "thawArray: element not overwritten"
  5845. freezeIOArray a      = primFreeze a
  5846. unsafeFreezeIOArray  = freezeIOArray  -- not as fast as GHC
  5847. instance Eq (IOArray ix elt) where
  5848.   (==) = eqIOArray
  5849. primitive primNewArr   "IONewArr"
  5850.           :: (a,a) -> Int -> b -> IO (IOArray a b)
  5851. primitive primReadArr  "IOReadArr"
  5852.           :: ((a,a) -> a -> Int) -> IOArray a b -> a -> IO b
  5853. primitive primWriteArr "IOWriteArr"
  5854.           :: ((a,a) -> a -> Int) -> IOArray a b -> a -> b -> IO ()
  5855. primitive primFreeze   "IOFreeze"
  5856.           :: IOArray a b -> IO (Array a b)
  5857. primitive primBounds   "IOBounds"
  5858.           :: IOArray a b -> (a,a)
  5859. primitive eqIOArray    "IOArrEq"
  5860.           :: IOArray a b -> IOArray a b -> Bool
  5861. -----------------------------------------------------------------------------
  5862. -----------------------------------------------------------------------------
  5863. -- Signed Integers
  5864. -- Suitable for use with Hugs 98 on 32 bit systems.
  5865. -----------------------------------------------------------------------------
  5866. module Int
  5867.     ( Int8
  5868.     , Int16
  5869.     , Int32
  5870.     , Int64
  5871.     , int8ToInt  -- :: Int8  -> Int
  5872.     , intToInt8  -- :: Int   -> Int8
  5873.     , int16ToInt -- :: Int16 -> Int
  5874.     , intToInt16 -- :: Int   -> Int16
  5875.     , int32ToInt -- :: Int32 -> Int
  5876.     , intToInt32 -- :: Int   -> Int32
  5877.     , toInt
  5878.     , fromInt
  5879.     -- plus Eq, Ord, Num, Bounded, Real, Integral, Ix, Enum, Read,
  5880.     --  Show and Bits instances for each of Int8, Int16 and Int32
  5881.     ) where
  5882. import Bits
  5883. -----------------------------------------------------------------------------
  5884. -- The "official" coercion functions
  5885. -----------------------------------------------------------------------------
  5886. int8ToInt  :: Int8  -> Int
  5887. intToInt8  :: Int   -> Int8
  5888. int16ToInt :: Int16 -> Int
  5889. intToInt16 :: Int   -> Int16
  5890. int32ToInt :: Int32 -> Int
  5891. intToInt32 :: Int   -> Int32
  5892. -- And some non-exported ones
  5893. int8ToInt16  :: Int8  -> Int16
  5894. int8ToInt32  :: Int8  -> Int32
  5895. int16ToInt8  :: Int16 -> Int8
  5896. int16ToInt32 :: Int16 -> Int32
  5897. int32ToInt8  :: Int32 -> Int8
  5898. int32ToInt16 :: Int32 -> Int16
  5899. int8ToInt16  = I16 . int8ToInt
  5900. int8ToInt32  = I32 . int8ToInt
  5901. int16ToInt8  = I8  . int16ToInt
  5902. int16ToInt32 = I32 . int16ToInt
  5903. int32ToInt8  = I8  . int32ToInt
  5904. int32ToInt16 = I16 . int32ToInt
  5905. -----------------------------------------------------------------------------
  5906. -- Int8
  5907. -----------------------------------------------------------------------------
  5908. newtype Int8  = I8 Int
  5909. int8ToInt (I8 x) = if x' <= 0x7f then x' else x' - 0x100
  5910.  where x' = x `primAnd` 0xff
  5911. intToInt8 = I8
  5912. instance Eq  Int8     where (==)    = binop (==)
  5913. instance Ord Int8     where compare = binop compare
  5914. instance Num Int8 where
  5915.     x + y         = to (binop (+) x y)
  5916.     x - y         = to (binop (-) x y)
  5917.     negate        = to . negate . from
  5918.     x * y         = to (binop (*) x y)
  5919.     abs           = absReal
  5920.     signum        = signumReal
  5921.     fromInteger   = to . fromInteger
  5922.     fromInt       = to
  5923. instance Bounded Int8 where
  5924.     minBound = 0x80
  5925.     maxBound = 0x7f 
  5926. instance Real Int8 where
  5927.     toRational x = toInteger x % 1
  5928. instance Integral Int8 where
  5929.     x `div` y     = to  (binop div x y)
  5930.     x `quot` y    = to  (binop quot x y)
  5931.     x `rem` y     = to  (binop rem x y)
  5932.     x `mod` y     = to  (binop mod x y)
  5933.     x `quotRem` y = to2 (binop quotRem x y)
  5934.     even          = even      . from
  5935.     toInteger     = toInteger . from
  5936.     toInt         = toInt     . from
  5937. instance Ix Int8 where
  5938.     range (m,n)          = [m..n]
  5939.     index b@(m,n) i
  5940.           | inRange b i = from (i - m)
  5941.           | otherwise   = error "index: Index out of range"
  5942.     inRange (m,n) i      = m <= i && i <= n
  5943. instance Enum Int8 where
  5944.     toEnum         = to 
  5945.     fromEnum       = from
  5946.     enumFrom c       = map toEnum [fromEnum c .. fromEnum (maxBound::Int8)]
  5947.     enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Int8)]
  5948.               where last = if d < c then minBound else maxBound
  5949. instance Read Int8 where
  5950.     readsPrec p s = [ (to x,r) | (x,r) <- readsPrec p s ]
  5951. instance Show Int8 where
  5952.     showsPrec p = showsPrec p . from
  5953. binop8 :: (Int32 -> Int32 -> a) -> (Int8 -> Int8 -> a)
  5954. binop8 op x y = int8ToInt32 x `op` int8ToInt32 y
  5955. instance Bits Int8 where
  5956.   x .&. y       = int32ToInt8 (binop8 (.&.) x y)
  5957.   x .|. y       = int32ToInt8 (binop8 (.|.) x y)
  5958.   x `xor` y     = int32ToInt8 (binop8 xor x y)
  5959.   complement    = int32ToInt8 . complement . int8ToInt32
  5960.   x `shift` i   = int32ToInt8 (int8ToInt32 x `shift` i)
  5961. --  rotate      
  5962.   bit           = int32ToInt8 . bit
  5963.   setBit x i    = int32ToInt8 (setBit (int8ToInt32 x) i)
  5964.   clearBit x i  = int32ToInt8 (clearBit (int8ToInt32 x) i)
  5965.   complementBit x i = int32ToInt8 (complementBit (int8ToInt32 x) i)
  5966.   testBit x i   = testBit (int8ToInt32 x) i
  5967.   bitSize  _    = 8
  5968.   isSigned _    = True
  5969. -----------------------------------------------------------------------------
  5970. -- Int16
  5971. -----------------------------------------------------------------------------
  5972. newtype Int16  = I16 Int
  5973. int16ToInt (I16 x) = if x' <= 0x7fff then x' else x' - 0x10000
  5974.  where x' = x `primAnd` 0xffff
  5975. intToInt16 = I16
  5976. instance Eq  Int16     where (==)    = binop (==)
  5977. instance Ord Int16     where compare = binop compare
  5978. instance Num Int16 where
  5979.     x + y         = to (binop (+) x y)
  5980.     x - y         = to (binop (-) x y)
  5981.     negate        = to . negate . from
  5982.     x * y         = to (binop (*) x y)
  5983.     abs           = absReal
  5984.     signum        = signumReal
  5985.     fromInteger   = to . fromInteger
  5986.     fromInt       = to
  5987. instance Bounded Int16 where
  5988.     minBound = 0x8000
  5989.     maxBound = 0x7fff 
  5990. instance Real Int16 where
  5991.     toRational x = toInteger x % 1
  5992. instance Integral Int16 where
  5993.     x `div` y     = to  (binop div x y)
  5994.     x `quot` y    = to  (binop quot x y)
  5995.     x `rem` y     = to  (binop rem x y)
  5996.     x `mod` y     = to  (binop mod x y)
  5997.     x `quotRem` y = to2 (binop quotRem x y)
  5998.     even          = even      . from
  5999.     toInteger     = toInteger . from
  6000.     toInt         = toInt     . from
  6001. instance Ix Int16 where
  6002.     range (m,n)          = [m..n]
  6003.     index b@(m,n) i
  6004.           | inRange b i = from (i - m)
  6005.           | otherwise   = error "index: Index out of range"
  6006.     inRange (m,n) i      = m <= i && i <= n
  6007. instance Enum Int16 where
  6008.     toEnum         = to 
  6009.     fromEnum       = from
  6010.     enumFrom c       = map toEnum [fromEnum c .. fromEnum (maxBound::Int16)]
  6011.     enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Int16)]
  6012.               where last = if d < c then minBound else maxBound
  6013. instance Read Int16 where
  6014.     readsPrec p s = [ (to x,r) | (x,r) <- readsPrec p s ]
  6015. instance Show Int16 where
  6016.     showsPrec p = showsPrec p . from
  6017. binop16 :: (Int32 -> Int32 -> a) -> (Int16 -> Int16 -> a)
  6018. binop16 op x y = int16ToInt32 x `op` int16ToInt32 y
  6019. instance Bits Int16 where
  6020.   x .&. y       = int32ToInt16 (binop16 (.&.) x y)
  6021.   x .|. y       = int32ToInt16 (binop16 (.|.) x y)
  6022.   x `xor` y     = int32ToInt16 (binop16 xor x y)
  6023.   complement    = int32ToInt16 . complement . int16ToInt32
  6024.   x `shift` i   = int32ToInt16 (int16ToInt32 x `shift` i)
  6025. --  rotate      
  6026.   bit           = int32ToInt16 . bit
  6027.   setBit x i    = int32ToInt16 (setBit (int16ToInt32 x) i)
  6028.   clearBit x i  = int32ToInt16 (clearBit (int16ToInt32 x) i)
  6029.   complementBit x i = int32ToInt16 (complementBit (int16ToInt32 x) i)
  6030.   testBit x i   = testBit (int16ToInt32 x) i
  6031.   bitSize  _    = 16
  6032.   isSigned _    = True
  6033. -----------------------------------------------------------------------------
  6034. -- Int32
  6035. -----------------------------------------------------------------------------
  6036. newtype Int32  = I32 Int
  6037. int32ToInt (I32 x) = x
  6038. intToInt32 = I32
  6039. instance Eq  Int32     where (==)    = binop (==)
  6040. instance Ord Int32     where compare = binop compare
  6041. instance Num Int32 where
  6042.     x + y         = to (binop (+) x y)
  6043.     x - y         = to (binop (-) x y)
  6044.     negate        = to . negate . from
  6045.     x * y         = to (binop (*) x y)
  6046.     abs           = absReal
  6047.     signum        = signumReal
  6048.     fromInteger   = to . fromInteger
  6049.     fromInt       = to
  6050. instance Bounded Int32 where
  6051.     minBound = to minBound
  6052.     maxBound = to maxBound
  6053. instance Real Int32 where
  6054.     toRational x = toInteger x % 1
  6055. instance Integral Int32 where
  6056.     x `div` y     = to  (binop div x y)
  6057.     x `quot` y    = to  (binop quot x y)
  6058.     x `rem` y     = to  (binop rem x y)
  6059.     x `mod` y     = to  (binop mod x y)
  6060.     x `quotRem` y = to2 (binop quotRem x y)
  6061.     even          = even      . from
  6062.     toInteger     = toInteger . from
  6063.     toInt         = toInt     . from
  6064. instance Ix Int32 where
  6065.     range (m,n)          = [m..n]
  6066.     index b@(m,n) i
  6067.           | inRange b i = from (i - m)
  6068.           | otherwise   = error "index: Index out of range"
  6069.     inRange (m,n) i      = m <= i && i <= n
  6070. instance Enum Int32 where
  6071.     toEnum         = to 
  6072.     fromEnum       = from
  6073.     enumFrom c       = map toEnum [fromEnum c .. fromEnum (maxBound::Int32)]
  6074.     enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Int32)]
  6075.               where last = if d < c then minBound else maxBound
  6076. instance Read Int32 where
  6077.     readsPrec p s = [ (to x,r) | (x,r) <- readsPrec p s ]
  6078. instance Show Int32 where
  6079.     showsPrec p = showsPrec p . from
  6080. instance Bits Int32 where
  6081.   (.&.)           = primAndInt
  6082.   (.|.)           = primOrInt
  6083.   xor             = primXorInt
  6084.   complement      = primComplementInt
  6085.   shift           = primShiftInt
  6086. --  rotate           
  6087.   bit             = primBitInt
  6088.   setBit x i    = x .|. bit i
  6089.   clearBit x i  = x .&. complement (bit i)
  6090.   complementBit x i = x `xor` bit i
  6091.   testBit       = primTestInt
  6092.   bitSize  _    = 32
  6093.   isSigned _    = True
  6094. -----------------------------------------------------------------------------
  6095. -- Int64
  6096. -- This is not ideal, but does have the advantage that you can 
  6097. -- now typecheck generated code that include Int64 statements.
  6098. -----------------------------------------------------------------------------
  6099. type Int64 = Integer
  6100. -----------------------------------------------------------------------------
  6101. -- End of exported definitions
  6102. -- The remainder of this file consists of definitions which are only
  6103. -- used in the implementation.
  6104. -----------------------------------------------------------------------------
  6105. -----------------------------------------------------------------------------
  6106. -- Coercions - used to make the instance declarations more uniform
  6107. -----------------------------------------------------------------------------
  6108. class Coerce a where
  6109.   to   :: Int -> a
  6110.   from :: a -> Int
  6111. instance Coerce Int32 where
  6112.   from = int32ToInt
  6113.   to   = intToInt32
  6114. instance Coerce Int8 where
  6115.   from = int8ToInt
  6116.   to   = intToInt8
  6117. instance Coerce Int16 where
  6118.   from = int16ToInt
  6119.   to   = intToInt16
  6120. binop :: Coerce int => (Int -> Int -> a) -> (int -> int -> a)
  6121. binop op x y = from x `op` from y
  6122. to2 :: Coerce int => (Int, Int) -> (int, int)
  6123. to2 (x,y) = (to x, to y)
  6124. -----------------------------------------------------------------------------
  6125. -- Extra primitives
  6126. -----------------------------------------------------------------------------
  6127. primitive primAnd "primAndInt" :: Int -> Int -> Int
  6128. primitive primAndInt        :: Int32 -> Int32 -> Int32
  6129. primitive primOrInt         :: Int32 -> Int32 -> Int32
  6130. primitive primXorInt        :: Int32 -> Int32 -> Int32
  6131. primitive primComplementInt :: Int32 -> Int32
  6132. primitive primShiftInt      :: Int32 -> Int -> Int32
  6133. primitive primBitInt        :: Int -> Int32
  6134. primitive primTestInt       :: Int32 -> Int -> Bool
  6135. -----------------------------------------------------------------------------
  6136. -- Code copied from the Prelude
  6137. -----------------------------------------------------------------------------
  6138. absReal x    | x >= 0    = x
  6139.          | otherwise = -x
  6140. signumReal x | x == 0    =  0
  6141.          | x > 0     =  1
  6142.          | otherwise = -1
  6143. -----------------------------------------------------------------------------
  6144. -- End
  6145. -----------------------------------------------------------------------------
  6146. A Haskell port of GNU's getopt library 
  6147. Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
  6148. changes Dec. 1997)
  6149. Two rather obscure features are missing: The Bash 2.0 non-option hack
  6150. (if you don't already know it, you probably don't want to hear about
  6151. it...) and the recognition of long options with a single dash
  6152. (e.g. '-help' is recognised as '--help', as long as there is no short
  6153. option 'h').
  6154. Other differences between GNU's getopt and this implementation: * To
  6155. enforce a coherent description of options and arguments, there are
  6156. explanation fields in the option/argument descriptor.  * Error
  6157. messages are now more informative, but no longer POSIX
  6158. compliant... :-( And a final Haskell advertisement: The GNU C
  6159. implementation uses well over 1100 lines, we need only 195 here,
  6160. including a 46 line example! :-)
  6161. \begin{code}
  6162. module GetOpt (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt) where
  6163. import List(isPrefixOf)
  6164. data ArgOrder a                        -- what to do with options following non-options:
  6165.    = RequireOrder                      --    no option processing after first non-option
  6166.    | Permute                           --    freely intersperse options and non-options
  6167.    | ReturnInOrder (String -> a)       --    wrap non-options into options
  6168. data OptDescr a =                      -- description of a single options:
  6169.    Option [Char]                       --    list of short option characters
  6170.           [String]                     --    list of long option strings (without "--")
  6171.           (ArgDescr a)                 --    argument descriptor
  6172.           String                       --    explanation of option for user
  6173. data ArgDescr a                        -- description of an argument option:
  6174.    = NoArg                   a         --    no argument expected
  6175.    | ReqArg (String       -> a) String --    option requires argument
  6176.    | OptArg (Maybe String -> a) String --    optional argument
  6177. data OptKind a                         -- kind of cmd line arg (internal use only):
  6178.    = Opt       a                       --    an option
  6179.    | NonOpt    String                  --    a non-option
  6180.    | EndOfOpts                         --    end-of-options marker (i.e. "--")
  6181.    | OptErr    String                  --    something went wrong...
  6182. usageInfo :: String                    -- header
  6183.           -> [OptDescr a]              -- option descriptors
  6184.           -> String                    -- nicely formatted decription of options
  6185. usageInfo header optDescr = unlines (header:table)
  6186.    where (ss,ls,ds)     = (unzip3 . map fmtOpt) optDescr
  6187.          table          = zipWith3 paste (sameLen ss) (sameLen ls) (sameLen ds)
  6188.          paste x y z    = "  " ++ x ++ "  " ++ y ++ "  " ++ z
  6189.          sameLen xs     = flushLeft ((maximum . map length) xs) xs
  6190.          flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]
  6191. fmtOpt :: OptDescr a -> (String,String,String)
  6192. fmtOpt (Option sos los ad descr) = (sepBy ',' (map (fmtShort ad) sos),
  6193.                                     sepBy ',' (map (fmtLong  ad) los),
  6194.                                     descr)
  6195.    where sepBy _  []     = ""
  6196.          sepBy _  [x]    = x
  6197.          sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs
  6198. fmtShort :: ArgDescr a -> Char -> String
  6199. fmtShort (NoArg  _   ) so = "-" ++ [so]
  6200. fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad
  6201. fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"
  6202. fmtLong :: ArgDescr a -> String -> String
  6203. fmtLong (NoArg  _   ) lo = "--" ++ lo
  6204. fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
  6205. fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
  6206. getOpt :: ArgOrder a                   -- non-option handling
  6207.        -> [OptDescr a]                 -- option descriptors
  6208.        -> [String]                     -- the commandline arguments
  6209.        -> ([a],[String],[String])      -- (options,non-options,error messages)
  6210. getOpt _        _        []         =  ([],[],[])
  6211. getOpt ordering optDescr (arg:args) = procNextOpt opt ordering
  6212.    where procNextOpt (Opt o)    _                 = (o:os,xs,es)
  6213.          procNextOpt (NonOpt x) RequireOrder      = ([],x:rest,[])
  6214.          procNextOpt (NonOpt x) Permute           = (os,x:xs,es)
  6215.          procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es)
  6216.          procNextOpt EndOfOpts  RequireOrder      = ([],rest,[])
  6217.          procNextOpt EndOfOpts  Permute           = ([],rest,[])
  6218.          procNextOpt EndOfOpts  (ReturnInOrder f) = (map f rest,[],[])
  6219.          procNextOpt (OptErr e) _                 = (os,xs,e:es)
  6220.          (opt,rest) = getNext arg args optDescr
  6221.          (os,xs,es) = getOpt ordering optDescr rest
  6222. -- take a look at the next cmd line arg and decide what to do with it
  6223. getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
  6224. getNext ('-':'-':[]) rest _        = (EndOfOpts,rest)
  6225. getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
  6226. getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr
  6227. getNext a            rest _        = (NonOpt a,rest)
  6228. -- handle long option
  6229. longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
  6230. longOpt ls rs optDescr = long ads arg rs
  6231.    where (opt,arg) = break (=='=') ls
  6232.          options   = [ o  | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `isPrefixOf` l ]
  6233.          ads       = [ ad | Option _ _ ad _ <- options ]
  6234.          optStr    = ("--"++opt)
  6235.          long (_:_:_)      _        rest     = (errAmbig options optStr,rest)
  6236.          long [NoArg  a  ] []       rest     = (Opt a,rest)
  6237.          long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr,rest)
  6238.          long [ReqArg _ d] []       []       = (errReq d optStr,[])
  6239.          long [ReqArg f _] []       (r:rest) = (Opt (f r),rest)
  6240.          long [ReqArg f _] ('=':xs) rest     = (Opt (f xs),rest)
  6241.          long [OptArg f _] []       rest     = (Opt (f Nothing),rest)
  6242.          long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)),rest)
  6243.          long _            _        rest     = (errUnrec optStr,rest)
  6244. -- handle short option
  6245. shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
  6246. shortOpt x xs rest optDescr = short ads xs rest
  6247.   where options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]
  6248.         ads     = [ ad | Option _ _ ad _ <- options ]
  6249.         optStr  = '-':[x]
  6250.         short (_:_:_)        _  rest     = (errAmbig options optStr,rest)
  6251.         short (NoArg  a  :_) [] rest     = (Opt a,rest)
  6252.         short (NoArg  a  :_) xs rest     = (Opt a,('-':xs):rest)
  6253.         short (ReqArg f d:_) [] []       = (errReq d optStr,[])
  6254.         short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)
  6255.         short (ReqArg f _:_) xs rest     = (Opt (f xs),rest)
  6256.         short (OptArg f _:_) [] rest     = (Opt (f Nothing),rest)
  6257.         short (OptArg f _:_) xs rest     = (Opt (f (Just xs)),rest)
  6258.         short []             [] rest     = (errUnrec optStr,rest)
  6259.         short []             xs rest     = (errUnrec optStr,('-':xs):rest)
  6260. -- miscellaneous error formatting
  6261. errAmbig :: [OptDescr a] -> String -> OptKind a
  6262. errAmbig ods optStr = OptErr (usageInfo header ods)
  6263.    where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
  6264. errReq :: String -> String -> OptKind a
  6265. errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
  6266. errUnrec :: String -> OptKind a
  6267. errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n")
  6268. errNoArg :: String -> OptKind a
  6269. errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
  6270. -----------------------------------------------------------------------------------------
  6271. -- and here a small and hopefully enlightening example:
  6272. data Flag = Verbose | Version | Name String | Output String | Arg String   deriving Show
  6273. options :: [OptDescr Flag]
  6274. options =
  6275.    [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",
  6276.     Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",
  6277.     Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",
  6278.     Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]
  6279. out :: Maybe String -> Flag
  6280. out Nothing  = Output "stdout"
  6281. out (Just o) = Output o
  6282. test :: ArgOrder Flag -> [String] -> String
  6283. test order cmdline = case getOpt order options cmdline of
  6284.                         (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"
  6285.                         (_,_,errs) -> concat errs ++ usageInfo header options
  6286.    where header = "Usage: foobar [OPTION...] files..."
  6287. -- example runs:
  6288. -- putStr (test RequireOrder ["foo","-v"])
  6289. --    ==> options=[]  args=["foo", "-v"]
  6290. -- putStr (test Permute ["foo","-v"])
  6291. --    ==> options=[Verbose]  args=["foo"]
  6292. -- putStr (test (ReturnInOrder Arg) ["foo","-v"])
  6293. --    ==> options=[Arg "foo", Verbose]  args=[]
  6294. -- putStr (test Permute ["foo","--","-v"])
  6295. --    ==> options=[]  args=["foo", "-v"]
  6296. -- putStr (test Permute ["-?o","--name","bar","--na=baz"])
  6297. --    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]
  6298. -- putStr (test Permute ["--ver","foo"])
  6299. --    ==> option `--ver' is ambiguous; could be one of:
  6300. --          -v      --verbose             verbosely list files
  6301. --          -V, -?  --version, --release  show version info   
  6302. --        Usage: foobar [OPTION...] files...
  6303. --          -v        --verbose             verbosely list files  
  6304. --          -V, -?    --version, --release  show version info     
  6305. --          -o[FILE]  --output[=FILE]       use FILE for dump     
  6306. --          -n USER   --name=USER           only dump USER's files
  6307. -----------------------------------------------------------------------------------------
  6308. \end{code}
  6309. module Foreign 
  6310.     ( StablePtr, ForeignObj
  6311.     , makeStablePtr, deRefStablePtr, freeStablePtr
  6312.     , makeForeignObj, writeForeignObj
  6313.     ) where
  6314. import Addr( Addr )
  6315. data StablePtr a
  6316. primitive makeStablePtr   :: a -> IO (StablePtr a)
  6317. primitive deRefStablePtr  :: StablePtr a -> IO a
  6318. primitive freeStablePtr   :: StablePtr a -> IO ()
  6319. data ForeignObj
  6320. primitive makeForeignObj  :: Addr{-x-} -> Addr{-free-} -> IO ForeignObj
  6321. primitive writeForeignObj :: ForeignObj -> Addr -> IO ()
  6322. primitive eqForeignObj    :: ForeignObj -> ForeignObj -> Bool
  6323. instance Eq ForeignObj where (==) = eqForeignObj
  6324. % (c) AQUA Project, Glasgow University, 1998
  6325. Cheap and cheerful dynamic types.
  6326. The Dynamic interface is part of the Hugs/GHC standard
  6327. libraries, providing basic support for dynamic types.
  6328. Operations for injecting values of arbitrary type into
  6329. a dynamically typed value, Dynamic, are provided, together
  6330. with operations for converting dynamic values into a concrete
  6331. (monomorphic) type.
  6332. The Dynamic implementation provided is closely based on code
  6333. contained in Hugs library of the same name.
  6334. NOTE: test code at the end, but commented out.
  6335. \begin{code}
  6336. module Dynamic
  6337.     (
  6338.       -- dynamic type
  6339.       Dynamic      -- abstract, instance of: Show (?)
  6340.     , toDyn       -- :: Typeable a => a -> Dynamic
  6341.     , fromDyn      -- :: Typeable a => Dynamic -> a -> a
  6342.     , fromDynamic -- :: Typeable a => Dynamic -> Maybe a
  6343.       -- type representation
  6344.     , Typeable(typeOf) 
  6345.       -- class Typeable a where { typeOf :: a -> TypeRep }
  6346.       -- Dynamic defines Typeable instances for the following
  6347.       -- Prelude types: Char, Int, Float, Double, Bool
  6348.       --                (), Maybe a, (a->b), [a]
  6349.       --        (a,b) (a,b,c) (a,b,c,d) (a,b,c,d,e)
  6350.     , TypeRep      -- abstract, instance of: Eq, Show
  6351.     , TyCon        -- abstract, instance of: Eq, Show
  6352.       -- type representation constructors/operators:
  6353.     , mkTyCon       -- :: String  -> TyCon
  6354.     , mkAppTy       -- :: TyCon   -> [TypeRep] -> TypeRep
  6355.     , mkFunTy      -- :: TypeRep -> TypeRep   -> TypeRep
  6356.     , applyTy       -- :: TypeRep -> TypeRep   -> Maybe TypeRep
  6357.       -- 
  6358.       -- let iTy = mkTyCon "Int" in show (mkAppTy (mkTyCon ",,")
  6359.       --                                 [iTy,iTy,iTy])
  6360.       -- 
  6361.       -- returns "(Int,Int,Int)"
  6362.       --
  6363.       -- The TypeRep Show instance promises to print tuple types
  6364.       -- correctly. Tuple type constructors are specified by a 
  6365.       -- sequence of commas, e.g., (mkTyCon ",,,,,,") returns
  6366.       -- the 7-tuple tycon.
  6367.     ) where
  6368. {- BEGIN_FOR_GHC
  6369. import GlaExts
  6370. import PrelDynamic
  6371.    END_FOR_GHC -}
  6372. import IOExts 
  6373.        ( unsafePerformIO,
  6374.          IORef, newIORef, readIORef, writeIORef
  6375.         )
  6376. {- BEGIN_FOR_HUGS -}
  6377. data TypeRep
  6378.  = App TyCon   [TypeRep]
  6379.  | Fun TypeRep TypeRep
  6380.    deriving ( Eq )
  6381. -- type constructors are 
  6382. data TyCon = TyCon Int String
  6383. instance Eq TyCon where
  6384.   (TyCon t1 _) == (TyCon t2 _) = t1 == t2
  6385. data Dynamic = Dynamic TypeRep Obj
  6386. data Obj = Obj  
  6387.  -- dummy type to hold the dynamically typed value.
  6388. primitive unsafeCoerce "primUnsafeCoerce" :: a -> b
  6389. {- END_FOR_HUGS -}
  6390. {- BEGIN_FOR_GHC
  6391. unsafeCoerce :: a -> b
  6392. unsafeCoerce = unsafeCoerce#
  6393.    END_FOR_GHC -}
  6394. \end{code}
  6395. The dynamic type is represented by Dynamic, carrying
  6396. the dynamic value along with its type representation:
  6397. \begin{code}
  6398. -- the instance just prints the type representation.
  6399. instance Show Dynamic where
  6400.    showsPrec _ (Dynamic t _) = 
  6401.           showString "<<" . 
  6402.       showsPrec 0 t   . 
  6403.       showString ">>"
  6404. \end{code}
  6405. Operations for going to and from Dynamic:
  6406. \begin{code}
  6407. toDyn :: Typeable a => a -> Dynamic
  6408. toDyn v = Dynamic (typeOf v) (unsafeCoerce v)
  6409. fromDyn :: Typeable a => Dynamic -> a -> a
  6410. fromDyn (Dynamic t v) def
  6411.   | typeOf def == t = unsafeCoerce v
  6412.   | otherwise       = def
  6413. fromDynamic :: Typeable a => Dynamic -> Maybe a
  6414. fromDynamic (Dynamic t v) =
  6415.   case unsafeCoerce v of 
  6416.     r | t == typeOf r -> Just r
  6417.       | otherwise     -> Nothing
  6418. \end{code}
  6419. (Abstract) universal datatype:
  6420. \begin{code}
  6421. instance Show TypeRep where
  6422.   showsPrec p (App tycon tys) =
  6423.     case tys of
  6424.       [] -> showsPrec p tycon
  6425.       [x] | tycon == listTc    -> showChar '[' . shows x . showChar ']'
  6426.       xs  
  6427.         | isTupleTyCon tycon -> showTuple tycon xs
  6428.     | otherwise         ->
  6429.         showParen (p > 9) $
  6430.            showsPrec p tycon . 
  6431.         showChar ' '      . 
  6432.         showArgs tys
  6433.   showsPrec p (Fun f a) =
  6434.      showParen (p > 8) $
  6435.      showsPrec 9 f . showString " -> " . showsPrec 8 a
  6436. \end{code}
  6437. To make it possible to convert values with user-defined types
  6438. into type Dynamic, we need a systematic way of getting
  6439. the type representation of an arbitrary type. Type class
  6440. provide a good fit, here
  6441. \begin{code}
  6442. class Typeable a where
  6443.   typeOf :: a -> TypeRep
  6444. \end{code}
  6445. NOTE: The argument to the overloaded `typeOf' is only
  6446. used to carry type information, and Typeable instances
  6447. should *never* look at its value.
  6448. \begin{code}
  6449. isTupleTyCon :: TyCon -> Bool
  6450. isTupleTyCon (TyCon _ (',':_)) = True
  6451. isTupleTyCon _               = False
  6452. instance Show TyCon where
  6453.   showsPrec _ (TyCon _ s) = showString s
  6454. -- If we enforce the restriction that TyCons are
  6455. -- shared, we can map them onto Ints very simply
  6456. -- which allows for efficient comparison.
  6457. mkTyCon :: String -> TyCon
  6458. mkTyCon str = unsafePerformIO $ do
  6459.    v <- readIORef uni
  6460.    writeIORef uni (v+1)
  6461.    return (TyCon v str)
  6462. uni :: IORef Int
  6463. uni = unsafePerformIO ( newIORef 0 )
  6464. \end{code}
  6465. Some (Show.TypeRep) helpers:
  6466. \begin{code}
  6467. showArgs :: Show a => [a] -> ShowS
  6468. showArgs [] = id
  6469. showArgs [a] = showsPrec 10 a
  6470. showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as 
  6471. showTuple :: TyCon -> [TypeRep] -> ShowS
  6472. showTuple (TyCon _ str) args = showChar '(' . go str args
  6473.  where
  6474.   go [] [a] = showsPrec 10 a . showChar ')'
  6475.   go _  []  = showChar ')' -- a failure condition, really.
  6476.   go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
  6477.   go _ _   = showChar ')'
  6478. \end{code}
  6479. \begin{code}
  6480. mkAppTy  :: TyCon   -> [TypeRep] -> TypeRep
  6481. mkAppTy tyc args = App tyc args
  6482. mkFunTy  :: TypeRep -> TypeRep   -> TypeRep
  6483. mkFunTy f a = Fun f a
  6484. \end{code}
  6485. Auxillary functions
  6486. \begin{code}
  6487. -- (f::(a->b)) `dynApply` (x::a) = (f a)::b
  6488. dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
  6489. dynApply (Dynamic t1 f) (Dynamic t2 x) =
  6490.   case applyTy t1 t2 of
  6491.     Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))
  6492.     Nothing -> Nothing
  6493. dynApp :: Dynamic -> Dynamic -> Dynamic
  6494. dynApp f x = case dynApply f x of 
  6495.              Just r -> r
  6496.              Nothing -> error ("Type error in dynamic application.\n" ++
  6497.                                "Can't apply function " ++ show f ++
  6498.                                " to argument " ++ show x)
  6499. applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
  6500. applyTy (Fun t1 t2) t3
  6501.   | t1 == t3    = Just t2
  6502. applyTy _ _     = Nothing
  6503. \end{code}
  6504. \begin{code}
  6505. instance Typeable Int where
  6506.   typeOf _ = mkAppTy intTc []
  6507. instance Typeable Char where
  6508.   typeOf _ = mkAppTy charTc []
  6509. instance Typeable Bool where
  6510.   typeOf _ = mkAppTy boolTc []
  6511. instance Typeable Float where
  6512.   typeOf _ = mkAppTy floatTc []
  6513. instance Typeable Double where
  6514.   typeOf _ = mkAppTy doubleTc []
  6515. instance Typeable Integer where
  6516.   typeOf _ = mkAppTy integerTc []
  6517. instance Typeable a => Typeable (IO a) where
  6518.   typeOf action = mkAppTy ioTc [typeOf (doIO action)]
  6519.     where
  6520.       doIO :: IO a -> a
  6521.       doIO = undefined
  6522. instance Typeable a => Typeable [a] where
  6523.   typeOf ls = mkAppTy listTc [typeOf (hd ls)]
  6524.     where
  6525.       hd :: [a] -> a
  6526.       hd = undefined
  6527. instance Typeable a => Typeable (Maybe a) where
  6528.   typeOf mb = mkAppTy maybeTc [typeOf (getJ mb)]
  6529.     where
  6530.       getJ :: Maybe a -> a
  6531.       getJ = undefined
  6532. instance (Typeable a, Typeable b) => Typeable (Either a b) where
  6533.   typeOf ei = mkAppTy maybeTc [typeOf (getL ei), typeOf (getR ei)]
  6534.     where
  6535.       getL :: Either a b -> a
  6536.       getL = undefined
  6537.       getR :: Either a b -> a
  6538.       getR = undefined
  6539. instance (Typeable a, Typeable b) => Typeable (a -> b) where
  6540.   typeOf f = mkFunTy (typeOf (arg f)) (typeOf (res f))
  6541.    where
  6542.     arg :: (a -> b) -> a
  6543.     arg = undefined
  6544.     res :: (a -> b) -> b
  6545.     res = undefined
  6546. instance Typeable () where
  6547.   typeOf _ = mkAppTy unitTc []
  6548. instance Typeable TypeRep where
  6549.   typeOf _ = mkAppTy typeRepTc []
  6550. instance Typeable TyCon where
  6551.   typeOf _ = mkAppTy tyConTc []
  6552. instance Typeable Dynamic where
  6553.   typeOf _ = mkAppTy dynamicTc []
  6554. instance Typeable Ordering where
  6555.   typeOf _ = mkAppTy orderingTc []
  6556. instance (Typeable a, Typeable b) => Typeable (a,b) where
  6557.   typeOf tu = mkAppTy tup2Tc [typeOf (fst tu), typeOf (snd tu)]
  6558.     where
  6559.       fst :: (a,b) -> a
  6560.       fst = undefined
  6561.       snd :: (a,b) -> b
  6562.       snd = undefined
  6563.       tup2Tc = mkTyCon ","
  6564. instance ( Typeable a
  6565.          , Typeable b
  6566.      , Typeable c) => Typeable (a,b,c) where
  6567.   typeOf tu = mkAppTy tup3Tc [ typeOf (fst tu)
  6568.                              , typeOf (snd tu)
  6569.                  , typeOf (thd tu)
  6570.                  ]
  6571.     where
  6572.       fst :: (a,b,c) -> a
  6573.       fst = undefined
  6574.       snd :: (a,b,c) -> b
  6575.       snd = undefined
  6576.       thd :: (a,b,c) -> c
  6577.       thd = undefined
  6578.       tup3Tc = mkTyCon ",,"
  6579. instance ( Typeable a
  6580.      , Typeable b
  6581.      , Typeable c
  6582.      , Typeable d) => Typeable (a,b,c,d) where
  6583.   typeOf tu = mkAppTy tup4Tc [ typeOf (fst tu)
  6584.                              , typeOf (snd tu)
  6585.                  , typeOf (thd tu)
  6586.                  , typeOf (fth tu)
  6587.                  ]
  6588.     where
  6589.       fst :: (a,b,c,d) -> a
  6590.       fst = undefined
  6591.       snd :: (a,b,c,d) -> b
  6592.       snd = undefined
  6593.       thd :: (a,b,c,d) -> c
  6594.       thd = undefined
  6595.       fth :: (a,b,c,d) -> d
  6596.       fth = undefined
  6597.       tup4Tc = mkTyCon ",,,"
  6598. instance ( Typeable a
  6599.      , Typeable b
  6600.      , Typeable c
  6601.      , Typeable d
  6602.      , Typeable e) => Typeable (a,b,c,d,e) where
  6603.   typeOf tu = mkAppTy tup5Tc [ typeOf (fst tu)
  6604.                              , typeOf (snd tu)
  6605.                  , typeOf (thd tu)
  6606.                  , typeOf (fth tu)
  6607.                  , typeOf (ffth tu)
  6608.                  ]
  6609.     where
  6610.       fst :: (a,b,c,d,e) -> a
  6611.       fst = undefined
  6612.       snd :: (a,b,c,d,e) -> b
  6613.       snd = undefined
  6614.       thd :: (a,b,c,d,e) -> c
  6615.       thd = undefined
  6616.       fth :: (a,b,c,d,e) -> d
  6617.       fth = undefined
  6618.       ffth :: (a,b,c,d,e) -> e
  6619.       ffth = undefined
  6620.       tup5Tc = mkTyCon ",,,,"
  6621. \end{code}
  6622. @TyCon@s are provided for the following:
  6623. \begin{code}
  6624. -- prelude types:
  6625. intTc, charTc, boolTc :: TyCon
  6626. intTc      = mkTyCon "Int"
  6627. charTc     = mkTyCon "Char"
  6628. boolTc     = mkTyCon "Bool"
  6629. floatTc, doubleTc, integerTc :: TyCon
  6630. floatTc    = mkTyCon "Float"
  6631. doubleTc   = mkTyCon "Double"
  6632. integerTc  = mkTyCon "Integer"
  6633. ioTc, maybeTc, eitherTc, listTc :: TyCon
  6634. ioTc       = mkTyCon "IO"
  6635. maybeTc    = mkTyCon "Maybe"
  6636. eitherTc   = mkTyCon "Either"
  6637. listTc     = mkTyCon "[]"
  6638. unitTc, orderingTc, arrayTc, complexTc, handleTc :: TyCon
  6639. unitTc     = mkTyCon "()"
  6640. orderingTc = mkTyCon "Ordering"
  6641. arrayTc    = mkTyCon "Array"
  6642. complexTc  = mkTyCon "Complex"
  6643. handleTc   = mkTyCon "Handle"
  6644. -- Hugs/GHC extension lib types:
  6645. addrTc, stablePtrTc, mvarTc :: TyCon
  6646. addrTc       = mkTyCon "Addr"
  6647. stablePtrTc  = mkTyCon "StablePtr"
  6648. mvarTc       = mkTyCon "MVar"
  6649. foreignObjTc, stTc :: TyCon
  6650. foreignObjTc = mkTyCon "ForeignObj"
  6651. stTc         = mkTyCon "ST"
  6652. int8Tc, int16Tc, int32Tc, int64Tc :: TyCon
  6653. int8Tc       = mkTyCon "Int8"
  6654. int16Tc      = mkTyCon "Int16"
  6655. int32Tc      = mkTyCon "Int32"
  6656. int64Tc         = mkTyCon "Int64"
  6657. word8Tc, word16Tc, word32Tc, word64Tc :: TyCon
  6658. word8Tc      = mkTyCon "Word8"
  6659. word16Tc     = mkTyCon "Word16"
  6660. word32Tc     = mkTyCon "Word32"
  6661. word64Tc     = mkTyCon "Word64"
  6662. tyConTc, typeRepTc, dynamicTc :: TyCon
  6663. tyConTc      = mkTyCon "TyCon"
  6664. typeRepTc    = mkTyCon "Type"
  6665. dynamicTc    = mkTyCon "Dynamic"
  6666. -- GHC specific:
  6667. {- BEGIN_FOR_GHC
  6668. byteArrayTc, mutablebyteArrayTc, wordTc :: TyCon
  6669. byteArrayTc  = mkTyCon "ByteArray"
  6670. mutablebyteArrayTc = mkTyCon "MutableByteArray"
  6671. wordTc       = mkTyCon "Word"
  6672.    END_FOR_GHC -}
  6673. \end{code}
  6674. begin{code}
  6675. test1,test2, test3, test4 :: Dynamic
  6676. test1 = toDyn (1::Int)
  6677. test2 = toDyn ((+) :: Int -> Int -> Int)
  6678. test3 = dynApp test2 test1
  6679. test4 = dynApp test3 test1
  6680. test5, test6,test7 :: Int
  6681. test5 = fromDyn test4 0
  6682. test6 = fromDyn test1 0
  6683. test7 = fromDyn test2 0
  6684. test8 :: Dynamic
  6685. test8 = toDyn (mkAppTy listTc)
  6686. test9 :: Float
  6687. test9 = fromDyn test8 0
  6688. printf :: String -> [Dynamic] -> IO ()
  6689. printf str args = putStr (decode str args)
  6690.  where
  6691.   decode [] [] = []
  6692.   decode ('%':'n':cs) (d:ds) =
  6693.     (\ v -> show v++decode cs ds) (fromDyn  d (0::Int))
  6694.   decode ('%':'c':cs) (d:ds) =
  6695.     (\ v -> show v++decode cs ds) (fromDyn  d ('\0'))
  6696.   decode ('%':'b':cs) (d:ds) =
  6697.     (\ v -> show v++decode cs ds) (fromDyn  d (False::Bool))
  6698.   decode (x:xs) ds = x:decode xs ds
  6699. test10 :: IO ()
  6700. test10 = printf "%n = %c, that much is %b\n" [toDyn (3::Int),toDyn 'a', toDyn False]
  6701. end{code}
  6702. % (c) The AQUA Project, Glasgow University, 1994-1996
  6703. \section[Concurrent]{Concurrent Haskell constructs}
  6704. A common interface to a collection of useful concurrency abstractions.
  6705. Currently, the collection only contains the abstractions found in the
  6706. {\em Concurrent Haskell} paper (presented at the Haskell Workshop
  6707. 1995, draft available via \tr{ftp} from
  6708. \tr{ftp.dcs.gla.ac.uk/pub/glasgow-fp/drafts}.)  plus a couple of
  6709. others. See the paper and the individual files containing the module
  6710. definitions for explanation on what they do.
  6711. \begin{code}
  6712. module Concurrent (
  6713.     module ChannelVar,
  6714.     module Channel,
  6715.     module Semaphore,
  6716. --ADR:    module Merge,
  6717.     module SampleVar,
  6718.     module ConcBase
  6719.     ) where
  6720. --ADR: import Parallel
  6721. import ChannelVar
  6722. import Channel
  6723. import Semaphore
  6724. --ADR: import Merge
  6725. import SampleVar
  6726. import ConcBase
  6727. \end{code}
  6728. -----------------------------------------------------------------------------
  6729. -- This implements Concurrent Haskell's "MVar"s as described in the paper
  6730. --   "Concurrent Haskell"
  6731. --   Simon Peyton Jones, Andrew Gordon and Sigbjorn Finne.
  6732. --   In Proceedings of the ACM Symposium on Principles of Programming
  6733. --   Languages,St Petersburg Beach, Florida, January 1996. 
  6734. --   http://www.dcs.gla.ac.uk/fp/authors/Simon_Peyton_Jones/
  6735. --     concurrent-haskell.ps
  6736. -- except that we have made the following name changes for compatability
  6737. -- with GHC 2.05.
  6738. --   newMVar  -> newEmptyMVar
  6739. -- There is one significant difference between this implementation and
  6740. -- GHC 2.05: 
  6741. -- o GHC uses preemptive multitasking.
  6742. --   Context switches can occur at any time (except if you call a C
  6743. --   function (like "getchar") which blocks the entire process while
  6744. --   waiting for input.
  6745. -- o Hugs uses cooperative multitasking.  
  6746. --   Context switches only occur when you use one of the primitives
  6747. --   defined in this module.  This means that programs such as:
  6748. --     main = forkIO (write 'a') >> write 'b'
  6749. --     where
  6750. --      write c = putChar c >> write c
  6751. --   will print either "aaaaaaaaaaaaaa..." or "bbbbbbbbbbbb..."
  6752. --   instead of some random interleaving of 'a's and 'b's.
  6753. -- Cooperative multitasking is sufficient for writing coroutines and simple
  6754. -- graphical user interfaces but the usual assumptions of fairness don't
  6755. -- apply and Channel.getChanContents cannot be implemented.
  6756. -----------------------------------------------------------------------------
  6757. module ConcBase(
  6758.     forkIO,
  6759.     runOrBlockIO,
  6760.     MVar,
  6761.     newEmptyMVar, newMVar, takeMVar, putMVar,
  6762.     swapMVar, readMVar, isEmptyMVar,
  6763.         yield
  6764.     ) where
  6765. import IO(IOMode, Handle, ioeGetErrorString) -- for binary file ops
  6766. import IOExts
  6767. ----------------------------------------------------------------
  6768. -- The interface
  6769. ----------------------------------------------------------------
  6770. forkIO      :: IO () -> IO () -- Spawn a thread
  6771. newEmptyMVar :: IO (MVar a)
  6772. newMVar      :: a -> IO (MVar a)
  6773. takeMVar     :: MVar a -> IO a
  6774. putMVar      :: MVar a -> a -> IO ()
  6775. instance Eq (MVar a) where
  6776.   (==) = primEqMVar
  6777. -- Spawn a thread and wait for it to return or block
  6778. runOrBlockIO :: IO a -> IO (IOResult a)
  6779. swapMVar :: MVar a -> a -> IO a
  6780. readMVar :: MVar a -> IO a
  6781. isEmptyMVar :: MVar a -> IO Bool
  6782. ----------------------------------------------------------------
  6783. -- Easy implementations (definable using the primitive operations)
  6784. ----------------------------------------------------------------
  6785. swapMVar var new = do
  6786.   old <- takeMVar var
  6787.   putMVar var new
  6788.   return old
  6789. readMVar mvar =
  6790.     takeMVar mvar    >>= \ value ->
  6791.     putMVar mvar value    >>
  6792.     return value
  6793. ----------------------------------------------------------------
  6794. -- Implementation
  6795. ----------------------------------------------------------------
  6796. suspend :: IO a
  6797. suspend = IO (\f s -> Hugs_SuspendThread)
  6798. yield   :: IO ()
  6799. yield    = suspend
  6800. -- The thread is scheduled immediately and runs with its own success/error
  6801. -- continuations.
  6802. runOrBlockIO (IO m) = IO (\f s -> s $! (m Hugs_Error Hugs_Return))  
  6803. -- suspend current thread passing its continuation to m
  6804. blockIO :: ((a -> IOResult a) -> IO a) -> IO a
  6805. blockIO m = IO (\ f s -> 
  6806.   case m s of { IO ms -> ms f (const Hugs_SuspendThread) }
  6807. -- continue the continuation, then go on
  6808. continueIO :: IOResult a -> IO ()
  6809. continueIO cc = IO (\ f s -> cc `seq` s ())
  6810. -- The thread is scheduled immediately and runs with its own success/error
  6811. -- continuations.
  6812. forkIO m = runOrBlockIO (m `catch` forkErrHandler) >> return ()
  6813. forkErrHandler :: IOError -> IO a
  6814. forkErrHandler e = do
  6815.     putStr "Uncaught error in forked process: \n  "
  6816.     putStr (ioeGetErrorString e)
  6817.     putStr "\n"           
  6818.     suspend
  6819. newtype MVar a = MkMVar (IORef (Either a [a -> IOResult a]))
  6820. newEmptyMVar = fmap MkMVar (newIORef (Right []))
  6821. newMVar x    = fmap MkMVar (newIORef (Left x))
  6822. takeMVar (MkMVar v) =
  6823.   readIORef v >>= \ state ->
  6824.   case state of
  6825.   Left a ->
  6826.     writeIORef v (Right []) >>
  6827.     return a
  6828.   Right cs ->
  6829.     blockIO (\cc ->
  6830.       writeIORef v (Right (cc:cs)) >>
  6831.       suspend
  6832.     )
  6833. putMVar (MkMVar v) a =
  6834.   readIORef v >>= \ state ->
  6835.   case state of
  6836.   Left a ->
  6837.     error "putMVar {full MVar}"
  6838.   Right [] ->
  6839.     writeIORef v (Left a)   >>
  6840.     return ()
  6841.   Right (c:cs) ->
  6842.     writeIORef v (Right cs) >>
  6843.     continueIO (c a)       >> -- schedule the blocked process
  6844.     return ()                 -- continue with this process
  6845. primEqMVar   :: MVar a -> MVar a -> Bool
  6846. MkMVar v1 `primEqMVar` MkMVar v2 = v1 == v2
  6847. isEmptyMVar (MkMVar v) =
  6848.   readIORef v >>= \state -> case state of
  6849.                               Left a  -> return False
  6850.                               Right a -> return True
  6851. -----------------------------------------------------------------------------
  6852. % (c) The GRASP/AQUA Project, Glasgow University, 1995
  6853. \section[ChannelVar]{Channel variables}
  6854. Channel variables, are one-element channels described in the Concurrent
  6855. Haskell paper (available from @ftp://ftp.dcs.gla.ac.uk/pub/glasgow-fp/drafts@)
  6856. \begin{code}
  6857. module ChannelVar
  6858.        (
  6859.      {- abstract -}
  6860.          CVar,
  6861.      newCVar,    --:: IO (CVar a)
  6862.      writeCVar,    --:: CVar a -> a -> IO ()
  6863.      readCVar,    --:: CVar a -> IO a
  6864.      MVar
  6865.        ) where
  6866. import Prelude
  6867. import ConcBase
  6868. \end{code}
  6869. @MVars@ provide the basic mechanisms for synchronising access to a shared
  6870. resource. @CVars@, or channel variables, provide an abstraction that guarantee
  6871. that the producer is not allowed to run riot, but enforces the interleaved
  6872. access to the channel variable,i.e., a producer is forced to wait up for
  6873. a consumer to remove the previous value before it can deposit a new one in the @CVar@.
  6874. \begin{code}
  6875. data CVar a
  6876.  = CVar (MVar a)     -- prod -> cons
  6877.         (MVar ())    -- cons -> prod
  6878. newCVar :: IO (CVar a)
  6879. writeCVar :: CVar a -> a -> IO ()
  6880. readCVar :: CVar a -> IO a
  6881. newCVar 
  6882.  = newEmptyMVar >>= \ datum ->
  6883.    newMVar ()   >>= \ ack ->
  6884.    return (CVar datum ack)
  6885. writeCVar (CVar datum ack) val
  6886.  = takeMVar ack      >> 
  6887.    putMVar datum val >>
  6888.    return ()
  6889. readCVar (CVar datum ack)
  6890.  = takeMVar datum >>= \ val ->
  6891.    putMVar ack () >> 
  6892.    return val
  6893. \end{code}
  6894. % (c) The GRASP/AQUA Project, Glasgow University, 1995
  6895. \section[Channel]{Unbounded Channels}
  6896. Standard, unbounded channel abstraction.
  6897. \begin{code}
  6898. module Channel
  6899.        (
  6900.      {- abstract type defined -}
  6901.         Chan,
  6902.      {- creator -}
  6903.     newChan,     -- :: IO (Chan a)
  6904.      {- operators -}
  6905.     writeChan,     -- :: Chan a -> a -> IO ()
  6906.     readChan,     -- :: Chan a -> IO a
  6907.     dupChan,     -- :: Chan a -> IO (Chan a)
  6908.     unReadChan,     -- :: Chan a -> a -> IO ()
  6909.         isEmptyChan,     -- :: Chan a -> IO Bool    -- PRH
  6910.      {- stream interface -}
  6911.     getChanContents, -- :: Chan a -> IO [a]
  6912.     writeList2Chan     -- :: Chan a -> [a] -> IO ()
  6913.        ) where
  6914. import Prelude
  6915. import IOExts( unsafeInterleaveIO )
  6916. import ConcBase
  6917. \end{code}
  6918. A channel is represented by two @MVar@s keeping track of the two ends
  6919. of the channel contents,i.e.,  the read- and write ends. Empty @MVar@s
  6920. are used to handle consumers trying to read from an empty channel.
  6921. \begin{code}
  6922. data Chan a
  6923.  = Chan (MVar (Stream a))
  6924.         (MVar (Stream a))
  6925. type Stream a = MVar (ChItem a)
  6926. data ChItem a = ChItem a (Stream a)
  6927. \end{code}
  6928. See the Concurrent Haskell paper for a diagram explaining the
  6929. how the different channel operations proceed.
  6930. @newChan@ sets up the read and write end of a channel by initialising
  6931. these two @MVar@s with an empty @MVar@.
  6932. \begin{code}
  6933. newChan :: IO (Chan a)
  6934. newChan
  6935.  = newEmptyMVar         >>= \ hole ->
  6936.    newMVar hole      >>= \ read ->
  6937.    newMVar hole      >>= \ write ->
  6938.    return (Chan read write)
  6939. \end{code}
  6940. To write an element on a channel, a new hole at the write end is created.
  6941. What was previously the empty @MVar@ at the back of the channel is then
  6942. filled in with a new stream element holding the entered value and the
  6943. new hole.
  6944. \begin{code}
  6945. writeChan :: Chan a -> a -> IO ()
  6946. writeChan (Chan read write) val
  6947.  = newEmptyMVar            >>= \ new_hole ->
  6948.    takeMVar write        >>= \ old_hole ->
  6949.    putMVar write new_hole   >> 
  6950.    putMVar old_hole (ChItem val new_hole) >>
  6951.    return ()
  6952. readChan :: Chan a -> IO a
  6953. readChan (Chan read write)
  6954.  = takeMVar read      >>= \ rend ->
  6955.    takeMVar rend          >>= \ (ChItem val new_rend) ->
  6956.    putMVar read new_rend  >>
  6957.    return val
  6958. isEmptyChan :: Chan a -> IO Bool
  6959. isEmptyChan (Chan read write)
  6960.  = takeMVar read      >>= \r ->
  6961.    readMVar write     >>= \w ->
  6962.    putMVar read r     >>
  6963.    return (r == w)
  6964. -- PRH:
  6965. isEmptyChan :: Chan a -> IO Bool
  6966. isEmptyChan (Chan read write)
  6967.  = readMVar read      >>= \ rend ->
  6968.    isEmptyMVar rend   >>= \ yes  ->
  6969.    return yes
  6970. -- or just:
  6971. -- isEmptyChan (Chan read write)
  6972. --  = readMVar read      >>=
  6973. --    isEmptyMVar
  6974. dupChan :: Chan a -> IO (Chan a)
  6975. dupChan (Chan read write)
  6976.  = newEmptyMVar          >>= \ new_read ->
  6977.    takeMVar write      >>= \ hole ->
  6978.    putMVar new_read hole  >>
  6979.    return (Chan new_read write)
  6980. unReadChan :: Chan a -> a -> IO ()
  6981. unReadChan (Chan read write) val
  6982.  = newEmptyMVar                  >>= \ new_rend ->
  6983.    takeMVar read              >>= \ rend ->
  6984.    putMVar new_rend (ChItem val rend) >> 
  6985.    putMVar read new_rend              >>
  6986.    return ()
  6987. \end{code}
  6988. Operators for interfacing with functional streams.
  6989. \begin{code}
  6990. getChanContents :: Chan a -> IO [a]
  6991. -- Rewritten by ADR to use IO monad instead of PrimIO Monad
  6992. getChanContents ch = unsafeInterleaveIO $ do
  6993.          x  <- readChan ch
  6994.          xs <- getChanContents ch
  6995.          return (x:xs)
  6996. --ADR: my_2_IO :: PrimIO (Either IOError a) -> IO a -- simple; primIOToIO does too much!
  6997. --ADR: my_2_IO m = IO m
  6998. --ADR: 
  6999. --ADR: readChan_prim         :: Chan a -> PrimIO (Either IOError  a)
  7000. --ADR: readChanContents_prim :: Chan a -> PrimIO (Either IOError [a])
  7001. --ADR: 
  7002. --ADR: readChan_prim ch = ST $ \ s ->
  7003. --ADR:        case (readChan ch) of { IO (ST read) ->
  7004. --ADR:        read s }
  7005. --ADR: 
  7006. --ADR: readChanContents_prim ch = ST $ \ s ->
  7007. --ADR:        case (readChanContents ch) of { IO (ST read) ->
  7008. --ADR:        read s }
  7009. -------------
  7010. writeList2Chan :: Chan a -> [a] -> IO ()
  7011. writeList2Chan ch ls = sequence_ (map (writeChan ch) ls)
  7012. \end{code}
  7013. -----------------------------------------------------------------------------
  7014. -- Bit twiddling operations
  7015. -- This library defines bitwise operations for signed and unsigned ints.
  7016. -- Suitable for use with Hugs 98.
  7017. -----------------------------------------------------------------------------
  7018. module Bits where
  7019. infixl 8 `shift`, `rotate`
  7020. infixl 7 .&.
  7021. infixl 6 `xor`
  7022. infixl 5 .|.
  7023. class Bits a where
  7024.   (.&.), (.|.), xor :: a -> a -> a
  7025.   complement        :: a -> a
  7026.   shift             :: a -> Int -> a
  7027.   rotate            :: a -> Int -> a
  7028.   bit               :: Int -> a        
  7029.   setBit            :: a -> Int -> a   
  7030.   clearBit          :: a -> Int -> a   
  7031.   complementBit     :: a -> Int -> a   
  7032.   testBit           :: a -> Int -> Bool
  7033.   bitSize           :: a -> Int
  7034.   isSigned          :: a -> Bool
  7035. shiftL, shiftR   :: Bits a => a -> Int -> a
  7036. rotateL, rotateR :: Bits a => a -> Int -> a
  7037. shiftL  a i = shift  a i
  7038. shiftR  a i = shift  a (-i)
  7039. rotateL a i = rotate a i
  7040. rotateR a i = rotate a (-i)
  7041. -----------------------------------------------------------------------------
  7042. -----------------------------------------------------------------------------
  7043. -- Machine Addresses:
  7044. -- Suitable for use with Hugs 98 on 32 bit machines.
  7045. -----------------------------------------------------------------------------
  7046. module Addr
  7047.     ( Addr
  7048.     , nullAddr -- :: Addr
  7049.      , plusAddr -- :: Addr -> Int -> Addr
  7050.     , addrToInt -- :: Addr -> Int
  7051.     -- instance Eq   Addr
  7052.     -- instance Show Addr
  7053.     ) where
  7054. -- data Addr -- in Prelude
  7055. instance Eq   Addr where (==)      = primEqAddr
  7056. instance Show Addr where showsPrec = primShowsAddr
  7057. primitive nullAddr      :: Addr
  7058. primitive plusAddr      :: Addr -> Int -> Addr
  7059. primitive primShowsAddr :: Int -> Addr -> ShowS
  7060. primitive primEqAddr    :: Addr -> Addr -> Bool
  7061. primitive addrToInt     :: Addr -> Int
  7062. -----------------------------------------------------------------------------
  7063. -----------------------------------------------------------------------------
  7064. -- Standard Library: System operations
  7065. -- Warning: the implementation of these functions in Hugs 98 is very weak.
  7066. -- The functions themselves are best suited to uses in compiled programs,
  7067. -- and not to use in an interpreter-based environment like Hugs.
  7068. -- Suitable for use with Hugs 98
  7069. -----------------------------------------------------------------------------
  7070. module System (
  7071.     ExitCode(..), exitWith, exitFailure,
  7072.     getArgs, getProgName, getEnv, 
  7073.     system
  7074.     ) where
  7075. data ExitCode = ExitSuccess | ExitFailure Int
  7076.                 deriving (Eq, Ord, Read, Show)
  7077. primitive primArgc          :: IO Int
  7078. primitive primArgv          :: Int -> IO String
  7079. getArgs                     :: IO [String]
  7080. getArgs                      = do argc <- primArgc
  7081.                                  mapM primArgv [1..argc-1]
  7082. getProgName                 :: IO String
  7083. getProgName                  = primArgv 0
  7084. primitive getEnv            :: String -> IO String
  7085. system                      :: String -> IO ExitCode
  7086. system s                     = do r <- primSystem s
  7087.                                   return (toExitCode r)
  7088. exitWith                    :: ExitCode -> IO a
  7089. exitWith c                   = primExitWith (fromExitCode c)
  7090. exitFailure            :: IO a
  7091. exitFailure             = exitWith (ExitFailure 1)
  7092. primitive primSystem        :: String -> IO Int
  7093. toExitCode                  :: Int -> ExitCode
  7094. toExitCode 0                 = ExitSuccess
  7095. toExitCode n                 = ExitFailure n
  7096. fromExitCode                :: ExitCode -> Int
  7097. fromExitCode ExitSuccess     = 0
  7098. fromExitCode (ExitFailure n) = n
  7099. -----------------------------------------------------------------------------
  7100. -----------------------------------------------------------------------------
  7101. -- Standard Library: Ratio and Rational types and operations
  7102. -- Suitable for use with Hugs 98
  7103. -----------------------------------------------------------------------------
  7104. module    Ratio (
  7105.     Ratio, Rational, (%), numerator, denominator, approxRational ) where
  7106. -- This module is empty; Rational is currently defined in the prelude,
  7107. -- but should eventually be moved to this library file instead.
  7108. -----------------------------------------------------------------------------
  7109. ------------------------------------------------------------------------------
  7110. -- Standard Library: Random numbers
  7111. -- Suitable for use with Hugs 98
  7112. -- The code in this file draws heavily from several different sources,
  7113. -- including the implementations in previous Hugs and GHC implementations.
  7114. -- Much of this was done by Sigbjorn Finne.  If there are mistakes here,
  7115. -- blame me.  The random number generation itself is based on a published
  7116. -- article by L'Ecuyer that was transliterated into Haskell by Lennart
  7117. -- Augustsson.  See the comments below for further details.
  7118. ------------------------------------------------------------------------------
  7119. module Random(
  7120.     RandomGen(next, split),
  7121.     StdGen, mkStdGen,
  7122.     Random( random,   randomR,
  7123.         randoms,  randomRs,
  7124.         randomIO, randomRIO ),
  7125.     getStdRandom, getStdGen, setStdGen, newStdGen
  7126.   ) where
  7127. import IOExts
  7128. -- The RandomGen class: ------------------------------------------------------
  7129. class RandomGen g where
  7130.    next  :: g -> (Int, g)
  7131.    split :: g -> (g, g)
  7132. -- An efficient and portable combined random number generator: ---------------
  7133. -- The June 1988 (v31 #6) issue of the Communications of the ACM has an
  7134. -- article by Pierre L'Ecuyer called, "Efficient and Portable Combined
  7135. -- Random Number Generators".  Here is the Portable Combined Generator of
  7136. -- L'Ecuyer for 32-bit computers.  It has a period of roughly 2.30584e18.
  7137. -- Transliterator: Lennart Augustsson
  7138. -- sof 1/99 - code brought (kicking and screaming) into the new Random
  7139. -- world..
  7140. ------------------------------------------------------------------------------
  7141. data StdGen = StdGen Int Int
  7142. mkStdGen          :: Int -> StdGen
  7143. mkStdGen seed          = StdGen (s1+1) (s2+1)
  7144.                          where s       = abs seed
  7145.                    (q, s1) = s `divMod` 2147483562
  7146.                    s2      = q `mod` 2147483398
  7147. stdFromString         :: String -> (StdGen, String)
  7148. stdFromString s        = (mkStdGen num, rest)
  7149.     where (cs, rest) = splitAt 6 s
  7150.               num        = foldl (\a x -> x + 3 * a) 1 (map ord cs)
  7151. stdNext               :: StdGen -> (Int, StdGen)
  7152. stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')
  7153.     where    z'   = if z < 1 then z + 2147483562 else z
  7154.         z    = s1'' - s2''
  7155.         k    = s1 `quot` 53668
  7156.         s1'  = 40014 * (s1 - k * 53668) - k * 12211
  7157.         s1'' = if s1' < 0 then s1' + 2147483563 else s1'
  7158.         k'   = s2 `quot` 52774
  7159.         s2'  = 40692 * (s2 - k' * 52774) - k' * 3791
  7160.         s2'' = if s2' < 0 then s2' + 2147483399 else s2'
  7161. stdSplit            :: StdGen -> (StdGen, StdGen)
  7162. stdSplit std@(StdGen s1 s2)
  7163.                      = (left, right)
  7164.                        where
  7165.                         -- no statistical foundation for this!
  7166.                         left    = StdGen new_s1 t2
  7167.                         right   = StdGen t1 new_s2
  7168.                         new_s1 | s1 == 2147483562 = 1
  7169.                                | otherwise        = s1 + 1
  7170.                         new_s2 | s2 == 1          = 2147483398
  7171.                                | otherwise        = s2 - 1
  7172.                         StdGen t1 t2 = snd (next std)
  7173. -- A standard instance of RandomGen: -----------------------------------------
  7174. instance RandomGen StdGen where
  7175.   next  = stdNext
  7176.   split = stdSplit
  7177. instance Show StdGen where
  7178.   showsPrec p (StdGen s1 s2)
  7179.     = showSigned showInt p s1 .  showChar ' ' . showSigned showInt p s2
  7180. instance Read StdGen where
  7181.   readsPrec p = \ r ->
  7182.     case try_read r of
  7183.        r@[_] -> r
  7184.        _     -> [stdFromString r] -- because it shouldn't ever fail.
  7185.     where 
  7186.       try_read r = do
  7187.          (s1, r1) <- readDec (dropWhile isSpace r)
  7188.      (s2, r2) <- readDec (dropWhile isSpace r1)
  7189.      return (StdGen s1 s2, r2)
  7190. -- The Random class: ---------------------------------------------------------
  7191. class Random a where
  7192.   -- Minimal complete definition: random and randomR
  7193.   random          :: RandomGen g => g -> (a, g)
  7194.   randomR         :: RandomGen g => (a,a) -> g -> (a,g)
  7195.   randoms         :: RandomGen g => g -> [a]
  7196.   randoms  g       = x : randoms g' where (x,g') = random g
  7197.   randomRs        :: RandomGen g => (a,a) -> g -> [a]
  7198.   randomRs ival g  = x : randomRs ival g' where (x,g') = randomR ival g
  7199.   randomIO        :: IO a
  7200.   randomIO       = getStdRandom random
  7201.   randomRIO       :: (a,a) -> IO a
  7202.   randomRIO range  = getStdRandom (randomR range)
  7203. instance Random Int where
  7204.   random g        = randomR (minBound,maxBound) g
  7205.   randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g
  7206. instance Random Char where
  7207.   random g      = randomR (minBound,maxBound) g
  7208.   randomR (a,b) g = 
  7209.       case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of
  7210.         (x,g) -> (chr x, g)
  7211. instance Random Bool where
  7212.   random g      = randomR (minBound,maxBound) g
  7213.   randomR (a,b) g = 
  7214.       case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of
  7215.         (x, g) -> (int2Bool x, g)
  7216.        where
  7217.          bool2Int False = 0
  7218.          bool2Int True  = 1
  7219.      int2Bool 0    = False
  7220.      int2Bool _    = True
  7221. instance Random Integer where
  7222.   random g     = randomR (toInteger (minBound::Int),
  7223.                             toInteger (maxBound::Int)) g
  7224.   randomR ival g = randomIvalInteger ival g
  7225. instance Random Double where
  7226.   random g       = randomR (0::Double,1) g
  7227.   randomR ival g = randomIvalDouble ival id g
  7228. -- hah, so you thought you were saving cycles by using Float?
  7229. instance Random Float where
  7230.   random g        = randomIvalDouble (0::Double,1) realToFrac g
  7231.   randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g
  7232. -- Auxiliary functions: ------------------------------------------------------
  7233. randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)
  7234. randomIvalInteger (l,h) rng
  7235.  | l > h     = randomIvalInteger (h,l) rng
  7236.  | otherwise = case (f n 1 rng) of
  7237.                  (v, rng') -> (fromInteger (l + v `mod` k), rng')
  7238.    where
  7239.      k = h - l + 1
  7240.      b = 2147483561
  7241.      n = iLogBase b k
  7242.      f 0 acc g = (acc, g)
  7243.      f n acc g = let (x,g') = next g
  7244.          in f (n-1) (fromInt x + acc * b) g'
  7245. randomIvalDouble :: (RandomGen g, Fractional a)
  7246.             => (Double, Double) -> (Double -> a) -> g -> (a, g)
  7247. randomIvalDouble (l,h) fromDouble rng 
  7248.   | l > h     = randomIvalDouble (h,l) fromDouble rng
  7249.   | otherwise = 
  7250.        case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of
  7251.          (x, rng') -> 
  7252.         let
  7253.          scaled_x = 
  7254.         fromDouble ((l+h)/2) + 
  7255.                 fromDouble ((h-l) / realToFrac intRange) *
  7256.         fromIntegral (x::Int)
  7257.         in
  7258.         (scaled_x, rng')
  7259. intRange :: Integer
  7260. intRange  = toInteger (maxBound::Int) - toInteger (minBound::Int)
  7261. iLogBase :: Integer -> Integer -> Integer
  7262. iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)
  7263. -- The global standard random number generator: ------------------------------
  7264. primitive getRandomSeed :: IO Integer
  7265. global_rng    :: IORef StdGen
  7266. global_rng     = unsafePerformIO (do seed <- getRandomSeed
  7267.                                      newIORef (mkStdGen (toInt seed)))
  7268. setStdGen     :: StdGen -> IO ()
  7269. setStdGen sgen = writeIORef global_rng sgen
  7270. getStdGen     :: IO StdGen
  7271. getStdGen      = readIORef global_rng
  7272. newStdGen     :: IO StdGen
  7273. newStdGen      = do rng <- getStdGen
  7274.                     let (a,b) = split rng
  7275.                     setStdGen a
  7276.                     return b
  7277. getStdRandom  :: (StdGen -> (a,StdGen)) -> IO a
  7278. getStdRandom f = do rng    <- getStdGen
  7279.                     let (v, new_rng) = f rng
  7280.                     setStdGen new_rng
  7281.                     return v
  7282. ------------------------------------------------------------------------------
  7283. {----------------------------------------------------------------------------
  7284. __   __ __  __  ____   ___    _______________________________________________
  7285. ||   || ||  || ||  || ||__    Hugs 98: The Nottingham and Yale Haskell system
  7286. ||___|| ||__|| ||__||  __||   Copyright (c) 1994-1999
  7287. ||---||         ___||         World Wide Web: http://haskell.org/hugs
  7288. ||   ||                       Report bugs to: hugs-bugs@haskell.org
  7289. ||   || Version: February 1999_______________________________________________
  7290.  This is the Hugs 98 Standard Prelude, based very closely on the Standard
  7291.  Prelude for Haskell 98.
  7292.  WARNING: This file is an integral part of the Hugs source code.  Changes to
  7293.  the definitions in this file without corresponding modifications in other
  7294.  parts of the program may cause the interpreter to fail unexpectedly.  Under
  7295.  normal circumstances, you should not attempt to modify this file in any way!
  7296. -----------------------------------------------------------------------------
  7297.  The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
  7298.  Yale Haskell Group, and the Oregon Graduate Institute of Science and
  7299.  Technology, 1994-1999, All rights reserved.  It is distributed as
  7300.  free software under the license in the file "License", which is
  7301.  included in the distribution.
  7302. ----------------------------------------------------------------------------}
  7303. module Prelude (
  7304. --  module PreludeList,
  7305.     map, (++), concat, filter,
  7306.     head, last, tail, init, null, length, (!!),
  7307.     foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
  7308.     iterate, repeat, replicate, cycle,
  7309.     take, drop, splitAt, takeWhile, dropWhile, span, break,
  7310.     lines, words, unlines, unwords, reverse, and, or,
  7311.     any, all, elem, notElem, lookup,
  7312.     sum, product, maximum, minimum, concatMap, 
  7313.     zip, zip3, zipWith, zipWith3, unzip, unzip3,
  7314. --  module PreludeText, 
  7315.     ReadS, ShowS,
  7316.     Read(readsPrec, readList),
  7317.     Show(show, showsPrec, showList),
  7318.     reads, shows, read, lex,
  7319.     showChar, showString, readParen, showParen,
  7320. --  module PreludeIO,
  7321.     FilePath, IOError, ioError, userError, catch,
  7322.     putChar, putStr, putStrLn, print,
  7323.     getChar, getLine, getContents, interact,
  7324.     readFile, writeFile, appendFile, readIO, readLn,
  7325. --  module Ix,
  7326.     Ix(range, index, inRange, rangeSize),
  7327. --  module Char,
  7328.     isAscii, isControl, isPrint, isSpace, isUpper, isLower,
  7329.     isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
  7330.     digitToInt, intToDigit,
  7331.     toUpper, toLower,
  7332.     ord, chr,
  7333.     readLitChar, showLitChar, lexLitChar,
  7334. --  module Numeric
  7335.     showSigned, showInt,
  7336.     readSigned, readInt,
  7337.     readDec, readOct, readHex, readSigned,
  7338.     readFloat, lexDigits, 
  7339. --  module Ratio,
  7340.     Ratio, Rational, (%), numerator, denominator, approxRational,
  7341. --  Non-standard exports
  7342.     IO(..), IOResult(..), primExitWith, Addr,
  7343.     Bool(False, True),
  7344.     Maybe(Nothing, Just),
  7345.     Either(Left, Right),
  7346.     Ordering(LT, EQ, GT),
  7347.     Char, String, Int, Integer, Float, Double, IO,
  7348. --  List type: []((:), [])
  7349.     (:),
  7350. --  Tuple types: (,), (,,), etc.
  7351. --  Trivial type: ()
  7352. --  Functions: (->)
  7353.     Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
  7354.     Eq((==), (/=)),
  7355.     Ord(compare, (<), (<=), (>=), (>), max, min),
  7356.     Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
  7357.          enumFromTo, enumFromThenTo),
  7358.     Bounded(minBound, maxBound),
  7359. --  Num((+), (-), (*), negate, abs, signum, fromInteger),
  7360.     Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
  7361.     Real(toRational),
  7362. --  Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
  7363.     Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
  7364. --  Fractional((/), recip, fromRational),
  7365.     Fractional((/), recip, fromRational, fromDouble),
  7366.     Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
  7367.              asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
  7368.     RealFrac(properFraction, truncate, round, ceiling, floor),
  7369.     RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
  7370.               encodeFloat, exponent, significand, scaleFloat, isNaN,
  7371.               isInfinite, isDenormalized, isIEEE, isNegativeZero, atan2),
  7372.     Monad((>>=), (>>), return, fail),
  7373.     Functor(fmap),
  7374.     mapM, mapM_, sequence, sequence_, (=<<),
  7375.     maybe, either,
  7376.     (&&), (||), not, otherwise,
  7377.     subtract, even, odd, gcd, lcm, (^), (^^), 
  7378.     fromIntegral, realToFrac,
  7379.     fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
  7380.     asTypeOf, error, undefined,
  7381.     seq, ($!)
  7382.   ) where
  7383. -- Standard value bindings {Prelude} ----------------------------------------
  7384. infixr 9  .
  7385. infixl 9  !!
  7386. infixr 8  ^, ^^, **
  7387. infixl 7  *, /, `quot`, `rem`, `div`, `mod`, :%, %
  7388. infixl 6  +, -
  7389. --infixr 5  :    -- this fixity declaration is hard-wired into Hugs
  7390. infixr 5  ++
  7391. infix  4  ==, /=, <, <=, >=, >, `elem`, `notElem`
  7392. infixr 3  &&
  7393. infixr 2  ||
  7394. infixl 1  >>, >>=
  7395. infixr 1  =<<
  7396. infixr 0  $, $!, `seq`
  7397. -- Equality and Ordered classes ---------------------------------------------
  7398. class Eq a where
  7399.     (==), (/=) :: a -> a -> Bool
  7400.     -- Minimal complete definition: (==) or (/=)
  7401.     x == y      = not (x/=y)
  7402.     x /= y      = not (x==y)
  7403. class (Eq a) => Ord a where
  7404.     compare                :: a -> a -> Ordering
  7405.     (<), (<=), (>=), (>)   :: a -> a -> Bool
  7406.     max, min               :: a -> a -> a
  7407.     -- Minimal complete definition: (<=) or compare
  7408.     -- using compare can be more efficient for complex types
  7409.     compare x y | x==y      = EQ
  7410.         | x<=y      = LT
  7411.         | otherwise = GT
  7412.     x <= y                  = compare x y /= GT
  7413.     x <  y                  = compare x y == LT
  7414.     x >= y                  = compare x y /= LT
  7415.     x >  y                  = compare x y == GT
  7416.     max x y   | x >= y      = x
  7417.           | otherwise   = y
  7418.     min x y   | x <= y      = x
  7419.           | otherwise   = y
  7420. class Bounded a where
  7421.     minBound, maxBound :: a
  7422.     -- Minimal complete definition: All
  7423. -- Numeric classes ----------------------------------------------------------
  7424. class (Eq a, Show a) => Num a where
  7425.     (+), (-), (*)  :: a -> a -> a
  7426.     negate         :: a -> a
  7427.     abs, signum    :: a -> a
  7428.     fromInteger    :: Integer -> a
  7429.     fromInt        :: Int -> a
  7430.     -- Minimal complete definition: All, except negate or (-)
  7431.     x - y           = x + negate y
  7432.     fromInt         = fromIntegral
  7433.     negate x        = 0 - x
  7434. class (Num a, Ord a) => Real a where
  7435.     toRational     :: a -> Rational
  7436. class (Real a, Enum a) => Integral a where
  7437.     quot, rem, div, mod :: a -> a -> a
  7438.     quotRem, divMod     :: a -> a -> (a,a)
  7439.     even, odd           :: a -> Bool
  7440.     toInteger           :: a -> Integer
  7441.     toInt               :: a -> Int
  7442.     -- Minimal complete definition: quotRem and toInteger
  7443.     n `quot` d           = q where (q,r) = quotRem n d
  7444.     n `rem` d            = r where (q,r) = quotRem n d
  7445.     n `div` d            = q where (q,r) = divMod n d
  7446.     n `mod` d            = r where (q,r) = divMod n d
  7447.     divMod n d           = if signum r == - signum d then (q-1, r+d) else qr
  7448.                where qr@(q,r) = quotRem n d
  7449.     even n               = n `rem` 2 == 0
  7450.     odd                  = not . even
  7451.     toInt                = toInt . toInteger
  7452. class (Num a) => Fractional a where
  7453.     (/)          :: a -> a -> a
  7454.     recip        :: a -> a
  7455.     fromRational :: Rational -> a
  7456.     fromDouble   :: Double -> a
  7457.     -- Minimal complete definition: fromRational and ((/) or recip)
  7458.     recip x       = 1 / x
  7459.     fromDouble    = fromRational . toRational
  7460.     x / y         = x * recip y
  7461. class (Fractional a) => Floating a where
  7462.     pi                  :: a
  7463.     exp, log, sqrt      :: a -> a
  7464.     (**), logBase       :: a -> a -> a
  7465.     sin, cos, tan       :: a -> a
  7466.     asin, acos, atan    :: a -> a
  7467.     sinh, cosh, tanh    :: a -> a
  7468.     asinh, acosh, atanh :: a -> a
  7469.     -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
  7470.     --                    asinh, acosh, atanh
  7471.     pi                   = 4 * atan 1
  7472.     x ** y               = exp (log x * y)
  7473.     logBase x y          = log y / log x
  7474.     sqrt x               = x ** 0.5
  7475.     tan x                = sin x / cos x
  7476.     sinh x               = (exp x - exp (-x)) / 2
  7477.     cosh x               = (exp x + exp (-x)) / 2
  7478.     tanh x               = sinh x / cosh x
  7479.     asinh x              = log (x + sqrt (x*x + 1))
  7480.     acosh x              = log (x + sqrt (x*x - 1))
  7481.     atanh x              = (log (1 + x) - log (1 - x)) / 2
  7482. class (Real a, Fractional a) => RealFrac a where
  7483.     properFraction   :: (Integral b) => a -> (b,a)
  7484.     truncate, round  :: (Integral b) => a -> b
  7485.     ceiling, floor   :: (Integral b) => a -> b
  7486.     -- Minimal complete definition: properFraction
  7487.     truncate x        = m where (m,_) = properFraction x
  7488.     round x           = let (n,r) = properFraction x
  7489.                 m     = if r < 0 then n - 1 else n + 1
  7490.             in case signum (abs r - 0.5) of
  7491.                 -1 -> n
  7492.                 0  -> if even n then n else m
  7493.                 1  -> m
  7494.     ceiling x         = if r > 0 then n + 1 else n
  7495.             where (n,r) = properFraction x
  7496.     floor x           = if r < 0 then n - 1 else n
  7497.             where (n,r) = properFraction x
  7498. class (RealFrac a, Floating a) => RealFloat a where
  7499.     floatRadix       :: a -> Integer
  7500.     floatDigits      :: a -> Int
  7501.     floatRange       :: a -> (Int,Int)
  7502.     decodeFloat      :: a -> (Integer,Int)
  7503.     encodeFloat      :: Integer -> Int -> a
  7504.     exponent         :: a -> Int
  7505.     significand      :: a -> a
  7506.     scaleFloat       :: Int -> a -> a
  7507.     isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
  7508.              :: a -> Bool
  7509.     atan2         :: a -> a -> a
  7510.     -- Minimal complete definition: All, except exponent, signficand,
  7511.     --                    scaleFloat, atan2
  7512.     exponent x        = if m==0 then 0 else n + floatDigits x
  7513.             where (m,n) = decodeFloat x
  7514.     significand x     = encodeFloat m (- floatDigits x)
  7515.             where (m,_) = decodeFloat x
  7516.     scaleFloat k x    = encodeFloat m (n+k)
  7517.             where (m,n) = decodeFloat x
  7518.     atan2 y x
  7519.       | x>0           = atan (y/x)
  7520.       | x==0 && y>0   = pi/2
  7521.       | x<0 && y>0    = pi + atan (y/x)
  7522.       | (x<=0 && y<0) ||
  7523.         (x<0 && isNegativeZero y) ||
  7524.         (isNegativeZero x && isNegativeZero y)
  7525.               = - atan2 (-y) x
  7526.       | y==0 && (x<0 || isNegativeZero x)
  7527.               = pi    -- must be after the previous test on zero y
  7528.       | x==0 && y==0  = y     -- must be after the other double zero tests
  7529.       | otherwise     = x + y -- x or y is a NaN, return a NaN (via +)
  7530. -- Numeric functions --------------------------------------------------------
  7531. subtract       :: Num a => a -> a -> a
  7532. subtract        = flip (-)
  7533. gcd            :: Integral a => a -> a -> a
  7534. gcd 0 0         = error "Prelude.gcd: gcd 0 0 is undefined"
  7535. gcd x y         = gcd' (abs x) (abs y)
  7536.           where gcd' x 0 = x
  7537.             gcd' x y = gcd' y (x `rem` y)
  7538. lcm            :: (Integral a) => a -> a -> a
  7539. lcm _ 0         = 0
  7540. lcm 0 _         = 0
  7541. lcm x y         = abs ((x `quot` gcd x y) * y)
  7542. (^)            :: (Num a, Integral b) => a -> b -> a
  7543. x ^ 0           = 1
  7544. x ^ n  | n > 0  = f x (n-1) x
  7545.           where f _ 0 y = y
  7546.             f x n y = g x n where
  7547.                   g x n | even n    = g (x*x) (n`quot`2)
  7548.                     | otherwise = f x (n-1) (x*y)
  7549. _ ^ _           = error "Prelude.^: negative exponent"
  7550. (^^)           :: (Fractional a, Integral b) => a -> b -> a
  7551. x ^^ n          = if n >= 0 then x ^ n else recip (x^(-n))
  7552. fromIntegral   :: (Integral a, Num b) => a -> b
  7553. fromIntegral    = fromInteger . toInteger
  7554. realToFrac     :: (Real a, Fractional b) => a -> b
  7555. realToFrac      = fromRational . toRational
  7556. -- Index and Enumeration classes --------------------------------------------
  7557. class (Ord a) => Ix a where
  7558.     range                :: (a,a) -> [a]
  7559.     index                :: (a,a) -> a -> Int
  7560.     inRange              :: (a,a) -> a -> Bool
  7561.     rangeSize            :: (a,a) -> Int
  7562.     rangeSize r@(l,u)
  7563.              | l > u      = 0
  7564.              | otherwise  = index r u + 1
  7565. class Enum a where
  7566.     succ, pred           :: a -> a
  7567.     toEnum               :: Int -> a
  7568.     fromEnum             :: a -> Int
  7569.     enumFrom             :: a -> [a]              -- [n..]
  7570.     enumFromThen         :: a -> a -> [a]         -- [n,m..]
  7571.     enumFromTo           :: a -> a -> [a]         -- [n..m]
  7572.     enumFromThenTo       :: a -> a -> a -> [a]    -- [n,n'..m]
  7573.     -- Minimal complete definition: toEnum, fromEnum
  7574.     succ                  = toEnum . (1+)       . fromEnum
  7575.     pred                  = toEnum . subtract 1 . fromEnum
  7576.     enumFromTo x y        = map toEnum [ fromEnum x .. fromEnum y ]
  7577.     enumFromThenTo x y z  = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
  7578. -- Read and Show classes ------------------------------------------------------
  7579. type ReadS a = String -> [(a,String)]
  7580. type ShowS   = String -> String
  7581. class Read a where
  7582.     readsPrec :: Int -> ReadS a
  7583.     readList  :: ReadS [a]
  7584.     -- Minimal complete definition: readsPrec
  7585.     readList   = readParen False (\r -> [pr | ("[",s) <- lex r,
  7586.                           pr      <- readl s ])
  7587.          where readl  s = [([],t)   | ("]",t) <- lex s] ++
  7588.                   [(x:xs,u) | (x,t)   <- reads s,
  7589.                           (xs,u)  <- readl' t]
  7590.                readl' s = [([],t)   | ("]",t) <- lex s] ++
  7591.                   [(x:xs,v) | (",",t) <- lex s,
  7592.                           (x,u)   <- reads t,
  7593.                           (xs,v)  <- readl' u]
  7594. class Show a where
  7595.     show      :: a -> String
  7596.     showsPrec :: Int -> a -> ShowS
  7597.     showList  :: [a] -> ShowS
  7598.     -- Minimal complete definition: show or showsPrec
  7599.     show x          = showsPrec 0 x ""
  7600.     showsPrec _ x s = show x ++ s
  7601.     showList []     = showString "[]"
  7602.     showList (x:xs) = showChar '[' . shows x . showl xs
  7603.               where showl []     = showChar ']'
  7604.                 showl (x:xs) = showChar ',' . shows x . showl xs
  7605. -- Monad classes ------------------------------------------------------------
  7606. class Functor f where
  7607.     fmap :: (a -> b) -> (f a -> f b)
  7608. class Monad m where
  7609.     return :: a -> m a
  7610.     (>>=)  :: m a -> (a -> m b) -> m b
  7611.     (>>)   :: m a -> m b -> m b
  7612.     fail   :: String -> m a
  7613.     -- Minimal complete definition: (>>=), return
  7614.     p >> q  = p >>= \ _ -> q
  7615.     fail s  = error s
  7616. sequence       :: Monad m => [m a] -> m [a]
  7617. sequence []     = return []
  7618. sequence (c:cs) = do x  <- c
  7619.              xs <- sequence cs
  7620.              return (x:xs)
  7621. sequence_        :: Monad m => [m a] -> m ()
  7622. sequence_         = foldr (>>) (return ())
  7623. mapM             :: Monad m => (a -> m b) -> [a] -> m [b]
  7624. mapM f            = sequence . map f
  7625. mapM_            :: Monad m => (a -> m b) -> [a] -> m ()
  7626. mapM_ f           = sequence_ . map f
  7627. (=<<)            :: Monad m => (a -> m b) -> m a -> m b
  7628. f =<< x           = x >>= f
  7629. -- Evaluation and strictness ------------------------------------------------
  7630. primitive seq           :: a -> b -> b
  7631. primitive ($!) "strict" :: (a -> b) -> a -> b
  7632. -- f $! x                = x `seq` f x
  7633. -- Trivial type -------------------------------------------------------------
  7634. -- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
  7635. instance Eq () where
  7636.     () == ()  =  True
  7637. instance Ord () where
  7638.     compare () () = EQ
  7639. instance Ix () where
  7640.     range ((),())      = [()]
  7641.     index ((),()) ()   = 0
  7642.     inRange ((),()) () = True
  7643. instance Enum () where
  7644.     toEnum 0           = ()
  7645.     fromEnum ()        = 0
  7646.     enumFrom ()        = [()]
  7647.     enumFromThen () () = [()]
  7648. instance Read () where
  7649.     readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
  7650.                            (")",t) <- lex s ])
  7651. instance Show () where
  7652.     showsPrec p () = showString "()"
  7653. instance Bounded () where
  7654.     minBound = ()
  7655.     maxBound = ()
  7656. -- Boolean type -------------------------------------------------------------
  7657. data Bool    = False | True
  7658.            deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
  7659. (&&), (||)  :: Bool -> Bool -> Bool
  7660. False && x   = False
  7661. True  && x   = x
  7662. False || x   = x
  7663. True  || x   = True
  7664. not         :: Bool -> Bool
  7665. not True     = False
  7666. not False    = True
  7667. otherwise   :: Bool
  7668. otherwise    = True
  7669. -- Character type -----------------------------------------------------------
  7670. data Char               -- builtin datatype of ISO Latin characters
  7671. type String = [Char]    -- strings are lists of characters
  7672. primitive primEqChar    :: Char -> Char -> Bool
  7673. primitive primCmpChar   :: Char -> Char -> Ordering
  7674. instance Eq Char  where (==)    = primEqChar
  7675. instance Ord Char where compare = primCmpChar
  7676. primitive primCharToInt :: Char -> Int
  7677. primitive primIntToChar :: Int -> Char
  7678. instance Enum Char where
  7679.     toEnum           = primIntToChar
  7680.     fromEnum         = primCharToInt
  7681.     enumFrom c       = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
  7682.     enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
  7683.                where lastChar = if d < c then minBound else maxBound
  7684. instance Ix Char where
  7685.     range (c,c')      = [c..c']
  7686.     index b@(c,c') ci
  7687.        | inRange b ci = fromEnum ci - fromEnum c
  7688.        | otherwise    = error "Ix.index: Index out of range."
  7689.     inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
  7690.             where i = fromEnum ci
  7691. instance Read Char where
  7692.     readsPrec p      = readParen False
  7693.                 (\r -> [(c,t) | ('\'':s,t) <- lex r,
  7694.                         (c,"\'")   <- readLitChar s ])
  7695.     readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
  7696.                            (l,_)      <- readl s ])
  7697.            where readl ('"':s)      = [("",s)]
  7698.              readl ('\\':'&':s) = readl s
  7699.              readl s            = [(c:cs,u) | (c ,t) <- readLitChar s,
  7700.                               (cs,u) <- readl t ]
  7701. instance Show Char where
  7702.     showsPrec p '\'' = showString "'\\''"
  7703.     showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''
  7704.     showList cs   = showChar '"' . showl cs
  7705.             where showl ""       = showChar '"'
  7706.               showl ('"':cs) = showString "\\\"" . showl cs
  7707.               showl (c:cs)   = showLitChar c . showl cs
  7708. instance Bounded Char where
  7709.     minBound = '\0'
  7710.     maxBound = '\255'
  7711. isAscii, isControl, isPrint, isSpace            :: Char -> Bool
  7712. isUpper, isLower, isAlpha, isDigit, isAlphaNum  :: Char -> Bool
  7713. isAscii c              =  fromEnum c < 128
  7714. isControl c            =  c < ' ' ||  c == '\DEL'
  7715. isPrint c              =  c >= ' ' &&  c <= '~'
  7716. isSpace c              =  c == ' ' || c == '\t' || c == '\n' ||
  7717.               c == '\r' || c == '\f' || c == '\v'
  7718. isUpper c              =  c >= 'A'   &&  c <= 'Z'
  7719. isLower c              =  c >= 'a'   &&  c <= 'z'
  7720. isAlpha c              =  isUpper c  ||  isLower c
  7721. isDigit c              =  c >= '0'   &&  c <= '9'
  7722. isAlphaNum c           =  isAlpha c  ||  isDigit c
  7723. -- Digit conversion operations
  7724. digitToInt :: Char -> Int
  7725. digitToInt c
  7726.   | isDigit c            =  fromEnum c - fromEnum '0'
  7727.   | c >= 'a' && c <= 'f' =  fromEnum c - fromEnum 'a' + 10
  7728.   | c >= 'A' && c <= 'F' =  fromEnum c - fromEnum 'A' + 10
  7729.   | otherwise            =  error "Char.digitToInt: not a digit"
  7730. intToDigit :: Int -> Char
  7731. intToDigit i
  7732.   | i >= 0  && i <=  9   =  toEnum (fromEnum '0' + i)
  7733.   | i >= 10 && i <= 15   =  toEnum (fromEnum 'a' + i - 10)
  7734.   | otherwise            =  error "Char.intToDigit: not a digit"
  7735. toUpper, toLower      :: Char -> Char
  7736. toUpper c | isLower c  = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
  7737.       | otherwise  = c
  7738. toLower c | isUpper c  = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
  7739.       | otherwise  = c
  7740. ord                   :: Char -> Int
  7741. ord                    = fromEnum
  7742. chr                   :: Int -> Char
  7743. chr                    = toEnum
  7744. -- Maybe type ---------------------------------------------------------------
  7745. data Maybe a = Nothing | Just a
  7746.            deriving (Eq, Ord, Read, Show)
  7747. maybe             :: b -> (a -> b) -> Maybe a -> b
  7748. maybe n f Nothing  = n
  7749. maybe n f (Just x) = f x
  7750. instance Functor Maybe where
  7751.     fmap f Nothing  = Nothing
  7752.     fmap f (Just x) = Just (f x)
  7753. instance Monad Maybe where
  7754.     Just x  >>= k = k x
  7755.     Nothing >>= k = Nothing
  7756.     return        = Just
  7757.     fail s        = Nothing
  7758. -- Either type --------------------------------------------------------------
  7759. data Either a b = Left a | Right b
  7760.           deriving (Eq, Ord, Read, Show)
  7761. either              :: (a -> c) -> (b -> c) -> Either a b -> c
  7762. either l r (Left x)  = l x
  7763. either l r (Right y) = r y
  7764. -- Ordering type ------------------------------------------------------------
  7765. data Ordering = LT | EQ | GT
  7766.         deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
  7767. -- Lists --------------------------------------------------------------------
  7768. -- data [a] = [] | a : [a] deriving (Eq, Ord)
  7769. instance Eq a => Eq [a] where
  7770.     []     == []     =  True
  7771.     (x:xs) == (y:ys) =  x==y && xs==ys
  7772.     _      == _      =  False
  7773. instance Ord a => Ord [a] where
  7774.     compare []     (_:_)  = LT
  7775.     compare []     []     = EQ
  7776.     compare (_:_)  []     = GT
  7777.     compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
  7778. instance Functor [] where
  7779.     fmap = map
  7780. instance Monad [ ] where
  7781.     (x:xs) >>= f = f x ++ (xs >>= f)
  7782.     []     >>= f = []
  7783.     return x     = [x]
  7784.     fail s       = []
  7785. instance Read a => Read [a]  where
  7786.     readsPrec p = readList
  7787. instance Show a => Show [a]  where
  7788.     showsPrec p = showList
  7789. -- Tuples -------------------------------------------------------------------
  7790. -- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
  7791. -- etc..
  7792. -- Standard Integral types --------------------------------------------------
  7793. data Int      -- builtin datatype of fixed size integers
  7794. data Integer  -- builtin datatype of arbitrary size integers
  7795. primitive primEqInt      :: Int -> Int -> Bool
  7796. primitive primCmpInt     :: Int -> Int -> Ordering
  7797. primitive primEqInteger  :: Integer -> Integer -> Bool
  7798. primitive primCmpInteger :: Integer -> Integer -> Ordering
  7799. instance Eq  Int     where (==)    = primEqInt
  7800. instance Eq  Integer where (==)    = primEqInteger
  7801. instance Ord Int     where compare = primCmpInt
  7802. instance Ord Integer where compare = primCmpInteger
  7803. primitive primPlusInt,
  7804.       primMinusInt,
  7805.       primMulInt       :: Int -> Int -> Int
  7806. primitive primNegInt       :: Int -> Int
  7807. primitive primIntegerToInt :: Integer -> Int
  7808. instance Num Int where
  7809.     (+)           = primPlusInt
  7810.     (-)           = primMinusInt
  7811.     negate        = primNegInt
  7812.     (*)           = primMulInt
  7813.     abs           = absReal
  7814.     signum        = signumReal
  7815.     fromInteger   = primIntegerToInt
  7816.     fromInt x     = x
  7817. primitive primMinInt, primMaxInt :: Int
  7818. instance Bounded Int where
  7819.     minBound = primMinInt
  7820.     maxBound = primMaxInt
  7821. primitive primPlusInteger,
  7822.       primMinusInteger,
  7823.       primMulInteger   :: Integer -> Integer -> Integer
  7824. primitive primNegInteger   :: Integer -> Integer
  7825. primitive primIntToInteger :: Int -> Integer
  7826. instance Num Integer where
  7827.     (+)           = primPlusInteger
  7828.     (-)           = primMinusInteger
  7829.     negate        = primNegInteger
  7830.     (*)           = primMulInteger
  7831.     abs           = absReal
  7832.     signum        = signumReal
  7833.     fromInteger x = x
  7834.     fromInt       = primIntToInteger
  7835. absReal x    | x >= 0    = x
  7836.          | otherwise = -x
  7837. signumReal x | x == 0    =  0
  7838.          | x > 0     =  1
  7839.          | otherwise = -1
  7840. instance Real Int where
  7841.     toRational x = toInteger x % 1
  7842. instance Real Integer where
  7843.     toRational x = x % 1
  7844. primitive primDivInt,
  7845.       primQuotInt,
  7846.       primRemInt,
  7847.       primModInt  :: Int -> Int -> Int
  7848. primitive primQrmInt  :: Int -> Int -> (Int,Int)
  7849. primitive primEvenInt :: Int -> Bool
  7850. instance Integral Int where
  7851.     div       = primDivInt
  7852.     quot      = primQuotInt
  7853.     rem       = primRemInt
  7854.     mod       = primModInt
  7855.     quotRem   = primQrmInt
  7856.     even      = primEvenInt
  7857.     toInteger = primIntToInteger
  7858.     toInt x   = x
  7859. primitive primQrmInteger  :: Integer -> Integer -> (Integer,Integer)
  7860. primitive primEvenInteger :: Integer -> Bool
  7861. instance Integral Integer where
  7862.     quotRem     = primQrmInteger
  7863.     even        = primEvenInteger
  7864.     toInteger x = x
  7865.     toInt       = primIntegerToInt
  7866. instance Ix Int where
  7867.     range (m,n)          = [m..n]
  7868.     index b@(m,n) i
  7869.        | inRange b i = i - m
  7870.        | otherwise   = error "index: Index out of range"
  7871.     inRange (m,n) i      = m <= i && i <= n
  7872. instance Ix Integer where
  7873.     range (m,n)          = [m..n]
  7874.     index b@(m,n) i
  7875.        | inRange b i = fromInteger (i - m)
  7876.        | otherwise   = error "index: Index out of range"
  7877.     inRange (m,n) i      = m <= i && i <= n
  7878. instance Enum Int where
  7879.     toEnum               = id
  7880.     fromEnum             = id
  7881.     enumFrom       = numericEnumFrom
  7882.     enumFromTo     = numericEnumFromTo
  7883.     enumFromThen   = numericEnumFromThen
  7884.     enumFromThenTo = numericEnumFromThenTo
  7885. instance Enum Integer where
  7886.     toEnum         = primIntToInteger
  7887.     fromEnum       = primIntegerToInt
  7888.     enumFrom       = numericEnumFrom
  7889.     enumFromTo     = numericEnumFromTo
  7890.     enumFromThen   = numericEnumFromThen
  7891.     enumFromThenTo = numericEnumFromThenTo
  7892. numericEnumFrom        :: Real a => a -> [a]
  7893. numericEnumFromThen    :: Real a => a -> a -> [a]
  7894. numericEnumFromTo      :: Real a => a -> a -> [a]
  7895. numericEnumFromThenTo  :: Real a => a -> a -> a -> [a]
  7896. numericEnumFrom n            = n : (numericEnumFrom $! (n+1))
  7897. numericEnumFromThen n m      = iterate ((m-n)+) n
  7898. numericEnumFromTo n m        = takeWhile (<= m) (numericEnumFrom n)
  7899. numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
  7900.                                where p | n' >= n   = (<= m)
  7901.                        | otherwise = (>= m)
  7902. primitive primShowsInt :: Int -> Int -> ShowS
  7903. instance Read Int where
  7904.     readsPrec p = readSigned readDec
  7905. instance Show Int where
  7906.     showsPrec   = primShowsInt
  7907. primitive primShowsInteger :: Int -> Integer -> ShowS
  7908. instance Read Integer where
  7909.     readsPrec p = readSigned readDec
  7910. instance Show Integer where
  7911.     showsPrec   = primShowsInteger
  7912. -- Standard Floating types --------------------------------------------------
  7913. data Float     -- builtin datatype of single precision floating point numbers
  7914. data Double    -- builtin datatype of double precision floating point numbers
  7915. primitive primEqFloat   :: Float -> Float -> Bool
  7916. primitive primCmpFloat  :: Float -> Float -> Ordering
  7917. primitive primEqDouble  :: Double -> Double -> Bool
  7918. primitive primCmpDouble :: Double -> Double -> Ordering
  7919. instance Eq  Float  where (==) = primEqFloat
  7920. instance Eq  Double where (==) = primEqDouble
  7921. instance Ord Float  where compare = primCmpFloat
  7922. instance Ord Double where compare = primCmpDouble
  7923. primitive primPlusFloat,
  7924.       primMinusFloat,
  7925.       primMulFloat       :: Float -> Float -> Float
  7926. primitive primNegFloat       :: Float -> Float
  7927. primitive primIntToFloat     :: Int -> Float
  7928. primitive primIntegerToFloat :: Integer -> Float
  7929. instance Num Float where
  7930.     (+)           = primPlusFloat
  7931.     (-)           = primMinusFloat
  7932.     negate        = primNegFloat
  7933.     (*)           = primMulFloat
  7934.     abs           = absReal
  7935.     signum        = signumReal
  7936.     fromInteger   = primIntegerToFloat
  7937.     fromInt       = primIntToFloat
  7938. primitive primPlusDouble,
  7939.       primMinusDouble,
  7940.       primMulDouble       :: Double -> Double -> Double
  7941. primitive primNegDouble       :: Double -> Double
  7942. primitive primIntToDouble     :: Int -> Double
  7943. primitive primIntegerToDouble :: Integer -> Double
  7944. instance Num Double where
  7945.     (+)         = primPlusDouble
  7946.     (-)         = primMinusDouble
  7947.     negate      = primNegDouble
  7948.     (*)         = primMulDouble
  7949.     abs         = absReal
  7950.     signum      = signumReal
  7951.     fromInteger = primIntegerToDouble
  7952.     fromInt     = primIntToDouble
  7953. instance Real Float where
  7954.     toRational = floatToRational
  7955. instance Real Double where
  7956.     toRational = doubleToRational
  7957. -- Calls to these functions are optimised when passed as arguments to
  7958. -- fromRational.
  7959. floatToRational  :: Float  -> Rational
  7960. doubleToRational :: Double -> Rational
  7961. floatToRational  x = realFloatToRational x 
  7962. doubleToRational x = realFloatToRational x
  7963. realFloatToRational x = (m%1)*(b%1)^^n
  7964.             where (m,n) = decodeFloat x
  7965.                   b     = floatRadix x
  7966. primitive primDivFloat      :: Float -> Float -> Float
  7967. primitive doubleToFloat     :: Double -> Float
  7968. instance Fractional Float where
  7969.     (/)          = primDivFloat
  7970.     fromRational = primRationalToFloat
  7971.     fromDouble   = doubleToFloat
  7972. primitive primDivDouble :: Double -> Double -> Double
  7973. instance Fractional Double where
  7974.     (/)          = primDivDouble
  7975.     fromRational = primRationalToDouble
  7976.     fromDouble x = x
  7977. -- These primitives are equivalent to (and are defined using) 
  7978. -- rationalTo{Float,Double}.  The difference is that they test to see
  7979. -- if their argument is of the form (fromDouble x) - which allows a much
  7980. -- more efficient implementation.
  7981. primitive primRationalToFloat  :: Rational -> Float
  7982. primitive primRationalToDouble :: Rational -> Double
  7983. -- These functions are used by Hugs - don't change their types.
  7984. rationalToFloat  :: Rational -> Float
  7985. rationalToDouble :: Rational -> Double
  7986. rationalToFloat  = rationalToRealFloat
  7987. rationalToDouble = rationalToRealFloat
  7988. rationalToRealFloat x = x'
  7989.  where x'    = f e
  7990.        f e   = if e' == e then y else f e'
  7991.            where y      = encodeFloat (round (x * (1%b)^^e)) e
  7992.              (_,e') = decodeFloat y
  7993.        (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
  7994.                  / fromInteger (denominator x))
  7995.        b     = floatRadix x'
  7996. primitive primSinFloat,  primAsinFloat, primCosFloat,
  7997.       primAcosFloat, primTanFloat,  primAtanFloat,
  7998.       primLogFloat,  primExpFloat,  primSqrtFloat :: Float -> Float
  7999. instance Floating Float where
  8000.     exp   = primExpFloat
  8001.     log   = primLogFloat
  8002.     sqrt  = primSqrtFloat
  8003.     sin   = primSinFloat
  8004.     cos   = primCosFloat
  8005.     tan   = primTanFloat
  8006.     asin  = primAsinFloat
  8007.     acos  = primAcosFloat
  8008.     atan  = primAtanFloat
  8009. primitive primSinDouble,  primAsinDouble, primCosDouble,
  8010.       primAcosDouble, primTanDouble,  primAtanDouble,
  8011.       primLogDouble,  primExpDouble,  primSqrtDouble :: Double -> Double
  8012. instance Floating Double where
  8013.     exp   = primExpDouble
  8014.     log   = primLogDouble
  8015.     sqrt  = primSqrtDouble
  8016.     sin   = primSinDouble
  8017.     cos   = primCosDouble
  8018.     tan   = primTanDouble
  8019.     asin  = primAsinDouble
  8020.     acos  = primAcosDouble
  8021.     atan  = primAtanDouble
  8022. instance RealFrac Float where
  8023.     properFraction = floatProperFraction
  8024. instance RealFrac Double where
  8025.     properFraction = floatProperFraction
  8026. floatProperFraction x
  8027.    | n >= 0      = (fromInteger m * fromInteger b ^ n, 0)
  8028.    | otherwise   = (fromInteger w, encodeFloat r n)
  8029.            where (m,n) = decodeFloat x
  8030.              b     = floatRadix x
  8031.              (w,r) = quotRem m (b^(-n))
  8032. primitive primFloatRadix  :: Integer
  8033. primitive primFloatDigits :: Int
  8034. primitive primFloatMinExp,
  8035.           primFloatMaxExp :: Int
  8036. primitive primFloatEncode :: Integer -> Int -> Float
  8037. primitive primFloatDecode :: Float -> (Integer, Int)
  8038. instance RealFloat Float where
  8039.     floatRadix  _ = primFloatRadix
  8040.     floatDigits _ = primFloatDigits
  8041.     floatRange  _ = (primFloatMinExp, primFloatMaxExp)
  8042.     encodeFloat = primFloatEncode
  8043.     decodeFloat = primFloatDecode
  8044.     isNaN       _ = False
  8045.     isInfinite  _ = False
  8046.     isDenormalized _ = False
  8047.     isNegativeZero _ = False
  8048.     isIEEE      _ = False
  8049. primitive primDoubleRadix  :: Integer
  8050. primitive primDoubleDigits :: Int
  8051. primitive primDoubleMinExp,
  8052.           primDoubleMaxExp :: Int
  8053. primitive primDoubleEncode :: Integer -> Int -> Double
  8054. primitive primDoubleDecode :: Double -> (Integer, Int)
  8055. instance RealFloat Double where
  8056.     floatRadix  _ = primDoubleRadix
  8057.     floatDigits _ = primDoubleDigits
  8058.     floatRange  _ = (primDoubleMinExp, primDoubleMaxExp)
  8059.     encodeFloat   = primDoubleEncode
  8060.     decodeFloat   = primDoubleDecode
  8061.     isNaN       _ = False
  8062.     isInfinite  _ = False
  8063.     isDenormalized _ = False
  8064.     isNegativeZero _ = False
  8065.     isIEEE      _ = False
  8066. instance Enum Float where
  8067.     toEnum          = primIntToFloat
  8068.     fromEnum          = truncate
  8069.     enumFrom          = numericEnumFrom
  8070.     enumFromThen      = numericEnumFromThen
  8071.     enumFromTo n m      = numericEnumFromTo n (m+1/2)
  8072.     enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
  8073. instance Enum Double where
  8074.     toEnum          = primIntToDouble
  8075.     fromEnum          = truncate
  8076.     enumFrom          = numericEnumFrom
  8077.     enumFromThen      = numericEnumFromThen
  8078.     enumFromTo n m      = numericEnumFromTo n (m+1/2)
  8079.     enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
  8080. primitive primShowsFloat :: Int -> Float -> ShowS
  8081. instance Read Float where
  8082.     readsPrec p = readSigned readFloat
  8083. -- Note that showFloat in Numeric isn't used here
  8084. instance Show Float where
  8085.     showsPrec   = primShowsFloat
  8086. primitive primShowsDouble :: Int -> Double -> ShowS
  8087. instance Read Double where
  8088.     readsPrec p = readSigned readFloat
  8089. -- Note that showFloat in Numeric isn't used here
  8090. instance Show Double where
  8091.     showsPrec   = primShowsDouble
  8092. -- Some standard functions --------------------------------------------------
  8093. fst            :: (a,b) -> a
  8094. fst (x,_)       = x
  8095. snd            :: (a,b) -> b
  8096. snd (_,y)       = y
  8097. curry          :: ((a,b) -> c) -> (a -> b -> c)
  8098. curry f x y     = f (x,y)
  8099. uncurry        :: (a -> b -> c) -> ((a,b) -> c)
  8100. uncurry f p     = f (fst p) (snd p)
  8101. id             :: a -> a
  8102. id    x         = x
  8103. const          :: a -> b -> a
  8104. const k _       = k
  8105. (.)            :: (b -> c) -> (a -> b) -> (a -> c)
  8106. (f . g) x       = f (g x)
  8107. flip           :: (a -> b -> c) -> b -> a -> c
  8108. flip f x y      = f y x
  8109. ($)            :: (a -> b) -> a -> b
  8110. f $ x           = f x
  8111. until          :: (a -> Bool) -> (a -> a) -> a -> a
  8112. until p f x     = if p x then x else until p f (f x)
  8113. asTypeOf       :: a -> a -> a
  8114. asTypeOf        = const
  8115. primitive error  :: String -> a
  8116. undefined        :: a
  8117. undefined | False = undefined
  8118. -- Standard functions on rational numbers {PreludeRatio} --------------------
  8119. data Integral a => Ratio a = a :% a deriving (Eq)
  8120. type Rational              = Ratio Integer
  8121. (%)                       :: Integral a => a -> a -> Ratio a
  8122. x % y                      = reduce (x * signum y) (abs y)
  8123. reduce                    :: Integral a => a -> a -> Ratio a
  8124. reduce x y | y == 0        = error "Ratio.%: zero denominator"
  8125.        | otherwise     = (x `quot` d) :% (y `quot` d)
  8126.                  where d = gcd x y
  8127. numerator, denominator    :: Integral a => Ratio a -> a
  8128. numerator (x :% y)         = x
  8129. denominator (x :% y)       = y
  8130. instance Integral a => Ord (Ratio a) where
  8131.     compare (x:%y) (x':%y') = compare (x*y') (x'*y)
  8132. instance Integral a => Num (Ratio a) where
  8133.     (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
  8134.     (x:%y) * (x':%y') = reduce (x*x') (y*y')
  8135.     negate (x :% y)   = negate x :% y
  8136.     abs (x :% y)      = abs x :% y
  8137.     signum (x :% y)   = signum x :% 1
  8138.     fromInteger x     = fromInteger x :% 1
  8139.     fromInt           = intToRatio
  8140. -- Hugs optimises code of the form fromRational (intToRatio x)
  8141. intToRatio :: Integral a => Int -> Ratio a
  8142. intToRatio x = fromInt x :% 1
  8143. instance Integral a => Real (Ratio a) where
  8144.     toRational (x:%y) = toInteger x :% toInteger y
  8145. instance Integral a => Fractional (Ratio a) where
  8146.     (x:%y) / (x':%y')   = (x*y') % (y*x')
  8147.     recip (x:%y)        = if x < 0 then (-y) :% (-x) else y :% x
  8148.     fromRational (x:%y) = fromInteger x :% fromInteger y
  8149.     fromDouble         = doubleToRatio
  8150. -- Hugs optimises code of the form fromRational (doubleToRatio x)
  8151. doubleToRatio :: Integral a => Double -> Ratio a
  8152. doubleToRatio x
  8153.         | n>=0      = (fromInteger m * fromInteger b ^ n) % 1
  8154.         | otherwise = fromInteger m % (fromInteger b ^ (-n))
  8155.               where (m,n) = decodeFloat x
  8156.                 b     = floatRadix x
  8157. instance Integral a => RealFrac (Ratio a) where
  8158.     properFraction (x:%y) = (fromIntegral q, r:%y)
  8159.                 where (q,r) = quotRem x y
  8160. instance Integral a => Enum (Ratio a) where
  8161.     toEnum       = fromInt
  8162.     fromEnum     = truncate
  8163.     enumFrom     = numericEnumFrom
  8164.     enumFromThen = numericEnumFromThen
  8165. instance (Read a, Integral a) => Read (Ratio a) where
  8166.     readsPrec p = readParen (p > 7)
  8167.                 (\r -> [(x%y,u) | (x,s)   <- reads r,
  8168.                           ("%",t) <- lex s,
  8169.                           (y,u)   <- reads t ])
  8170. instance Integral a => Show (Ratio a) where
  8171.     showsPrec p (x:%y) = showParen (p > 7)
  8172.                  (shows x . showString " % " . shows y)
  8173. approxRational      :: RealFrac a => a -> a -> Rational
  8174. approxRational x eps = simplest (x-eps) (x+eps)
  8175.  where simplest x y | y < x     = simplest y x
  8176.             | x == y    = xr
  8177.             | x > 0     = simplest' n d n' d'
  8178.             | y < 0     = - simplest' (-n') d' (-n) d
  8179.             | otherwise = 0 :% 1
  8180.                   where xr@(n:%d) = toRational x
  8181.                     (n':%d')  = toRational y
  8182.        simplest' n d n' d'        -- assumes 0 < n%d < n'%d'
  8183.             | r == 0    = q :% 1
  8184.             | q /= q'   = (q+1) :% 1
  8185.             | otherwise = (q*n''+d'') :% n''
  8186.                   where (q,r)      = quotRem n d
  8187.                     (q',r')    = quotRem n' d'
  8188.                     (n'':%d'') = simplest' d' r' d r
  8189. -- Standard list functions {PreludeList} ------------------------------------
  8190. head             :: [a] -> a
  8191. head (x:_)        = x
  8192. last             :: [a] -> a
  8193. last [x]          = x
  8194. last (_:xs)       = last xs
  8195. tail             :: [a] -> [a]
  8196. tail (_:xs)       = xs
  8197. init             :: [a] -> [a]
  8198. init [x]          = []
  8199. init (x:xs)       = x : init xs
  8200. null             :: [a] -> Bool
  8201. null []           = True
  8202. null (_:_)        = False
  8203. (++)             :: [a] -> [a] -> [a]
  8204. []     ++ ys      = ys
  8205. (x:xs) ++ ys      = x : (xs ++ ys)
  8206. map              :: (a -> b) -> [a] -> [b]
  8207. map f xs          = [ f x | x <- xs ]
  8208. filter           :: (a -> Bool) -> [a] -> [a]
  8209. filter p xs       = [ x | x <- xs, p x ]
  8210. concat           :: [[a]] -> [a]
  8211. concat            = foldr (++) []
  8212. length           :: [a] -> Int
  8213. length            = foldl' (\n _ -> n + 1) 0
  8214. (!!)             :: [b] -> Int -> b
  8215. (x:_)  !! 0       = x
  8216. (_:xs) !! n | n>0 = xs !! (n-1)
  8217. (_:_)  !! _       = error "Prelude.!!: negative index"
  8218. []     !! _       = error "Prelude.!!: index too large"
  8219. foldl            :: (a -> b -> a) -> a -> [b] -> a
  8220. foldl f z []      = z
  8221. foldl f z (x:xs)  = foldl f (f z x) xs
  8222. foldl'           :: (a -> b -> a) -> a -> [b] -> a
  8223. foldl' f a []     = a
  8224. foldl' f a (x:xs) = (foldl' f $! f a x) xs
  8225. foldl1           :: (a -> a -> a) -> [a] -> a
  8226. foldl1 f (x:xs)   = foldl f x xs
  8227. scanl            :: (a -> b -> a) -> a -> [b] -> [a]
  8228. scanl f q xs      = q : (case xs of
  8229.              []   -> []
  8230.              x:xs -> scanl f (f q x) xs)
  8231. scanl1           :: (a -> a -> a) -> [a] -> [a]
  8232. scanl1 f (x:xs)   = scanl f x xs
  8233. foldr            :: (a -> b -> b) -> b -> [a] -> b
  8234. foldr f z []      = z
  8235. foldr f z (x:xs)  = f x (foldr f z xs)
  8236. foldr1           :: (a -> a -> a) -> [a] -> a
  8237. foldr1 f [x]      = x
  8238. foldr1 f (x:xs)   = f x (foldr1 f xs)
  8239. scanr            :: (a -> b -> b) -> b -> [a] -> [b]
  8240. scanr f q0 []     = [q0]
  8241. scanr f q0 (x:xs) = f x q : qs
  8242.             where qs@(q:_) = scanr f q0 xs
  8243. scanr1           :: (a -> a -> a) -> [a] -> [a]
  8244. scanr1 f [x]      = [x]
  8245. scanr1 f (x:xs)   = f x q : qs
  8246.             where qs@(q:_) = scanr1 f xs
  8247. iterate          :: (a -> a) -> a -> [a]
  8248. iterate f x       = x : iterate f (f x)
  8249. repeat           :: a -> [a]
  8250. repeat x          = xs where xs = x:xs
  8251. replicate        :: Int -> a -> [a]
  8252. replicate n x     = take n (repeat x)
  8253. cycle            :: [a] -> [a]
  8254. cycle []          = error "Prelude.cycle: empty list"
  8255. cycle xs          = xs' where xs'=xs++xs'
  8256. take                :: Int -> [a] -> [a]
  8257. take 0 _             = []
  8258. take _ []            = []
  8259. take n (x:xs) | n>0  = x : take (n-1) xs
  8260. take _ _             = error "Prelude.take: negative argument"
  8261. drop                :: Int -> [a] -> [a]
  8262. drop 0 xs            = xs
  8263. drop _ []            = []
  8264. drop n (_:xs) | n>0  = drop (n-1) xs
  8265. drop _ _             = error "Prelude.drop: negative argument"
  8266. splitAt               :: Int -> [a] -> ([a], [a])
  8267. splitAt 0 xs           = ([],xs)
  8268. splitAt _ []           = ([],[])
  8269. splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
  8270. splitAt _ _            = error "Prelude.splitAt: negative argument"
  8271. takeWhile           :: (a -> Bool) -> [a] -> [a]
  8272. takeWhile p []       = []
  8273. takeWhile p (x:xs)
  8274.      | p x       = x : takeWhile p xs
  8275.      | otherwise = []
  8276. dropWhile           :: (a -> Bool) -> [a] -> [a]
  8277. dropWhile p []       = []
  8278. dropWhile p xs@(x:xs')
  8279.      | p x       = dropWhile p xs'
  8280.      | otherwise = xs
  8281. span, break         :: (a -> Bool) -> [a] -> ([a],[a])
  8282. span p []            = ([],[])
  8283. span p xs@(x:xs')
  8284.      | p x       = (x:ys, zs)
  8285.      | otherwise = ([],xs)
  8286.                        where (ys,zs) = span p xs'
  8287. break p              = span (not . p)
  8288. lines     :: String -> [String]
  8289. lines ""   = []
  8290. lines s    = let (l,s') = break ('\n'==) s
  8291.              in l : case s' of []      -> []
  8292.                                (_:s'') -> lines s''
  8293. words     :: String -> [String]
  8294. words s    = case dropWhile isSpace s of
  8295.           "" -> []
  8296.           s' -> w : words s''
  8297.             where (w,s'') = break isSpace s'
  8298. unlines   :: [String] -> String
  8299. unlines    = concatMap (\l -> l ++ "\n")
  8300. unwords   :: [String] -> String
  8301. unwords [] = []
  8302. unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
  8303. reverse   :: [a] -> [a]
  8304. reverse    = foldl (flip (:)) []
  8305. and, or   :: [Bool] -> Bool
  8306. and        = foldr (&&) True
  8307. or         = foldr (||) False
  8308. any, all  :: (a -> Bool) -> [a] -> Bool
  8309. any p      = or  . map p
  8310. all p      = and . map p
  8311. elem, notElem    :: Eq a => a -> [a] -> Bool
  8312. elem              = any . (==)
  8313. notElem           = all . (/=)
  8314. lookup           :: Eq a => a -> [(a,b)] -> Maybe b
  8315. lookup k []       = Nothing
  8316. lookup k ((x,y):xys)
  8317.       | k==x      = Just y
  8318.       | otherwise = lookup k xys
  8319. sum, product     :: Num a => [a] -> a
  8320. sum               = foldl' (+) 0
  8321. product           = foldl' (*) 1
  8322. maximum, minimum :: Ord a => [a] -> a
  8323. maximum           = foldl1 max
  8324. minimum           = foldl1 min
  8325. concatMap        :: (a -> [b]) -> [a] -> [b]
  8326. concatMap f       = concat . map f
  8327. zip              :: [a] -> [b] -> [(a,b)]
  8328. zip               = zipWith  (\a b -> (a,b))
  8329. zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]
  8330. zip3              = zipWith3 (\a b c -> (a,b,c))
  8331. zipWith                  :: (a->b->c) -> [a]->[b]->[c]
  8332. zipWith z (a:as) (b:bs)   = z a b : zipWith z as bs
  8333. zipWith _ _      _        = []
  8334. zipWith3                 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
  8335. zipWith3 z (a:as) (b:bs) (c:cs)
  8336.               = z a b c : zipWith3 z as bs cs
  8337. zipWith3 _ _ _ _          = []
  8338. unzip                    :: [(a,b)] -> ([a],[b])
  8339. unzip                     = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
  8340. unzip3                   :: [(a,b,c)] -> ([a],[b],[c])
  8341. unzip3                    = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
  8342.                   ([],[],[])
  8343. -- PreludeText ----------------------------------------------------------------
  8344. reads        :: Read a => ReadS a
  8345. reads         = readsPrec 0
  8346. shows        :: Show a => a -> ShowS
  8347. shows         = showsPrec 0
  8348. read         :: Read a => String -> a
  8349. read s        =  case [x | (x,t) <- reads s, ("","") <- lex t] of
  8350.               [x] -> x
  8351.               []  -> error "Prelude.read: no parse"
  8352.               _   -> error "Prelude.read: ambiguous parse"
  8353. showChar     :: Char -> ShowS
  8354. showChar      = (:)
  8355. showString   :: String -> ShowS
  8356. showString    = (++)
  8357. showParen    :: Bool -> ShowS -> ShowS
  8358. showParen b p = if b then showChar '(' . p . showChar ')' else p
  8359. showField    :: Show a => String -> a -> ShowS
  8360. showField m v = showString m . showChar '=' . shows v
  8361. readParen    :: Bool -> ReadS a -> ReadS a
  8362. readParen b g = if b then mandatory else optional
  8363.         where optional r  = g r ++ mandatory r
  8364.               mandatory r = [(x,u) | ("(",s) <- lex r,
  8365.                          (x,t)   <- optional s,
  8366.                          (")",u) <- lex t    ]
  8367. readField    :: Read a => String -> ReadS a
  8368. readField m s0 = [ r | (t,  s1) <- lex s0, t == m,
  8369.                        ("=",s2) <- lex s1,
  8370.                        r        <- reads s2 ]
  8371. lex                    :: ReadS String
  8372. lex ""                  = [("","")]
  8373. lex (c:s) | isSpace c   = lex (dropWhile isSpace s)
  8374. lex ('\'':s)            = [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
  8375.                            ch /= "'"                ]
  8376. lex ('"':s)             = [('"':str, t)      | (str,t) <- lexString s]
  8377.               where
  8378.               lexString ('"':s) = [("\"",s)]
  8379.               lexString s = [(ch++str, u)
  8380.                         | (ch,t)  <- lexStrItem s,
  8381.                           (str,u) <- lexString t  ]
  8382.               lexStrItem ('\\':'&':s) = [("\\&",s)]
  8383.               lexStrItem ('\\':c:s) | isSpace c
  8384.                   = [("",t) | '\\':t <- [dropWhile isSpace s]]
  8385.               lexStrItem s            = lexLitChar s
  8386. lex (c:s) | isSingle c  = [([c],s)]
  8387.       | isSym c     = [(c:sym,t)         | (sym,t) <- [span isSym s]]
  8388.       | isAlpha c   = [(c:nam,t)         | (nam,t) <- [span isIdChar s]]
  8389.       | isDigit c   = [(c:ds++fe,t)      | (ds,s)  <- [span isDigit s],
  8390.                            (fe,t)  <- lexFracExp s     ]
  8391.       | otherwise   = []    -- bad character
  8392.         where
  8393.         isSingle c  =  c `elem` ",;()[]{}_`"
  8394.         isSym c     =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
  8395.         isIdChar c  =  isAlphaNum c || c `elem` "_'"
  8396.         lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
  8397.                               (e,u)  <- lexExp t    ]
  8398.         lexFracExp s       = [("",s)]
  8399.         lexExp (e:s) | e `elem` "eE"
  8400.              = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
  8401.                            (ds,u) <- lexDigits t] ++
  8402.                [(e:ds,t)   | (ds,t) <- lexDigits s]
  8403.         lexExp s = [("",s)]
  8404. lexDigits               :: ReadS String
  8405. lexDigits               =  nonnull isDigit
  8406. nonnull                 :: (Char -> Bool) -> ReadS String
  8407. nonnull p s             =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
  8408. lexLitChar              :: ReadS String
  8409. lexLitChar ('\\':s)     =  [('\\':esc, t) | (esc,t) <- lexEsc s] 
  8410.     where
  8411.     lexEsc (c:s)     | c `elem` "abfnrtv\\\"'" = [([c],s)]
  8412.         lexEsc ('^':c:s) | c >= '@' && c <= '_'    = [(['^',c],s)]
  8413.     lexEsc s@(d:_)   | isDigit d               = lexDigits s
  8414.         lexEsc s@(c:_)   | isUpper c
  8415.                           = let table = ('\DEL',"DEL") : asciiTab
  8416.                 in case [(mne,s') | (c, mne) <- table,
  8417.                              ([],s') <- [lexmatch mne s]]
  8418.                    of (pr:_) -> [pr]
  8419.                       []     -> []
  8420.     lexEsc _                                   = []
  8421. lexLitChar (c:s)        =  [([c],s)]
  8422. lexLitChar ""           =  []
  8423. isOctDigit c  =  c >= '0' && c <= '7'
  8424. isHexDigit c  =  isDigit c || c >= 'A' && c <= 'F'
  8425.                || c >= 'a' && c <= 'f'
  8426. lexmatch                   :: (Eq a) => [a] -> [a] -> ([a],[a])
  8427. lexmatch (x:xs) (y:ys) | x == y  =  lexmatch xs ys
  8428. lexmatch xs     ys               =  (xs,ys)
  8429. asciiTab = zip ['\NUL'..' ']
  8430.        ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
  8431.         "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
  8432.         "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
  8433.         "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
  8434.         "SP"]
  8435. readLitChar            :: ReadS Char
  8436. readLitChar ('\\':s)    = readEsc s
  8437.  where
  8438.        readEsc ('a':s)  = [('\a',s)]
  8439.        readEsc ('b':s)  = [('\b',s)]
  8440.        readEsc ('f':s)  = [('\f',s)]
  8441.        readEsc ('n':s)  = [('\n',s)]
  8442.        readEsc ('r':s)  = [('\r',s)]
  8443.        readEsc ('t':s)  = [('\t',s)]
  8444.        readEsc ('v':s)  = [('\v',s)]
  8445.        readEsc ('\\':s) = [('\\',s)]
  8446.        readEsc ('"':s)  = [('"',s)]
  8447.        readEsc ('\'':s) = [('\'',s)]
  8448.        readEsc ('^':c:s) | c >= '@' && c <= '_'
  8449.             = [(toEnum (fromEnum c - fromEnum '@'), s)]
  8450.        readEsc s@(d:_) | isDigit d
  8451.             = [(toEnum n, t) | (n,t) <- readDec s]
  8452.        readEsc ('o':s)  = [(toEnum n, t) | (n,t) <- readOct s]
  8453.        readEsc ('x':s)  = [(toEnum n, t) | (n,t) <- readHex s]
  8454.        readEsc s@(c:_) | isUpper c
  8455.             = let table = ('\DEL',"DEL") : asciiTab
  8456.               in case [(c,s') | (c, mne) <- table,
  8457.                         ([],s') <- [lexmatch mne s]]
  8458.                  of (pr:_) -> [pr]
  8459.                 []     -> []
  8460.        readEsc _        = []
  8461. readLitChar (c:s)       = [(c,s)]
  8462. showLitChar               :: Char -> ShowS
  8463. showLitChar c | c > '\DEL' = showChar '\\' .
  8464.                  protectEsc isDigit (shows (fromEnum c))
  8465. showLitChar '\DEL'         = showString "\\DEL"
  8466. showLitChar '\\'           = showString "\\\\"
  8467. showLitChar c | c >= ' '   = showChar c
  8468. showLitChar '\a'           = showString "\\a"
  8469. showLitChar '\b'           = showString "\\b"
  8470. showLitChar '\f'           = showString "\\f"
  8471. showLitChar '\n'           = showString "\\n"
  8472. showLitChar '\r'           = showString "\\r"
  8473. showLitChar '\t'           = showString "\\t"
  8474. showLitChar '\v'           = showString "\\v"
  8475. showLitChar '\SO'          = protectEsc ('H'==) (showString "\\SO")
  8476. showLitChar c              = showString ('\\' : snd (asciiTab!!fromEnum c))
  8477. protectEsc p f             = f . cont
  8478.  where cont s@(c:_) | p c  = "\\&" ++ s
  8479.        cont s              = s
  8480. -- Unsigned readers for various bases
  8481. readDec, readOct, readHex :: Integral a => ReadS a
  8482. readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
  8483. readOct = readInt  8 isOctDigit (\d -> fromEnum d - fromEnum '0')
  8484. readHex = readInt 16 isHexDigit hex
  8485.       where hex d = fromEnum d -
  8486.             (if isDigit d
  8487.                then fromEnum '0'
  8488.                else fromEnum (if isUpper d then 'A' else 'a') - 10)
  8489. -- readInt reads a string of digits using an arbitrary base.  
  8490. -- Leading minus signs must be handled elsewhere.
  8491. readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
  8492. readInt radix isDig digToInt s =
  8493.     [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
  8494.     | (ds,r) <- nonnull isDig s ]
  8495. -- showInt is used for positive numbers only
  8496. showInt    :: Integral a => a -> ShowS
  8497. showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers"
  8498.             | otherwise =
  8499.               let (n',d) = quotRem n 10
  8500.           r'     = toEnum (fromEnum '0' + fromIntegral d) : r
  8501.           in  if n' == 0 then r' else showInt n' r'
  8502. readSigned:: Real a => ReadS a -> ReadS a
  8503. readSigned readPos = readParen False read'
  8504.              where read' r  = read'' r ++
  8505.                       [(-x,t) | ("-",s) <- lex r,
  8506.                         (x,t)   <- read'' s]
  8507.                read'' r = [(n,s)  | (str,s) <- lex r,
  8508.                         (n,"")  <- readPos str]
  8509. showSigned    :: Real a => (a -> ShowS) -> Int -> a -> ShowS
  8510. showSigned showPos p x = if x < 0 then showParen (p > 6)
  8511.                          (showChar '-' . showPos (-x))
  8512.                   else showPos x
  8513. readFloat     :: RealFloat a => ReadS a
  8514. readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
  8515.                                (k,t)   <- readExp s]
  8516.          where readFix r = [(read (ds++ds'), length ds', t)
  8517.                     | (ds, s) <- lexDigits r
  8518.                                         , (ds',t) <- lexFrac s   ]
  8519.                        lexFrac ('.':s) = lexDigits s
  8520.                lexFrac s       = [("",s)]
  8521.                readExp (e:s) | e `elem` "eE" = readExp' s
  8522.                readExp s                     = [(0,s)]
  8523.                readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
  8524.                readExp' ('+':s) = readDec s
  8525.                readExp' s       = readDec s
  8526. -- Monadic I/O: --------------------------------------------------------------
  8527. --data IO a             -- builtin datatype of IO actions
  8528. data IOError            -- builtin datatype of IO error codes
  8529. type FilePath = String  -- file pathnames are represented by strings
  8530. instance Show (IO a) where
  8531.     showsPrec p f = showString "<<IO action>>"
  8532. primitive primbindIO   "rbindIO" :: IO a -> (a -> IO b) -> IO b
  8533. primitive primretIO    "runitIO" :: a -> IO a
  8534. primitive catch        "lbindIO" :: IO a -> (IOError -> IO a) -> IO a
  8535. primitive ioError      "lunitIO" :: IOError -> IO a
  8536. primitive putChar         :: Char -> IO ()
  8537. primitive putStr         :: String -> IO ()
  8538. primitive getChar            :: IO Char
  8539. primitive userError             :: String -> IOError
  8540. print     :: Show a => a -> IO ()
  8541. print      = putStrLn . show
  8542. putStrLn  :: String -> IO ()
  8543. putStrLn s = do putStr s
  8544.         putChar '\n'
  8545. getLine   :: IO String
  8546. getLine    = do c <- getChar
  8547.         if c=='\n' then return ""
  8548.                else do cs <- getLine
  8549.                    return (c:cs)
  8550. -- raises an exception instead of an error
  8551. readIO          :: Read a => String -> IO a
  8552. readIO s         = case [x | (x,t) <- reads s, ("","") <- lex t] of
  8553.                         [x] -> return x
  8554.                         []  -> ioError (userError "PreludeIO.readIO: no parse")
  8555.                         _   -> ioError (userError 
  8556.                                        "PreludeIO.readIO: ambiguous parse")
  8557. readLn          :: Read a => IO a
  8558. readLn           = do l <- getLine
  8559.                       r <- readIO l
  8560.                       return r
  8561. primitive getContents          :: IO String
  8562. primitive writeFile            :: FilePath -> String -> IO ()
  8563. primitive appendFile           :: FilePath -> String -> IO ()
  8564. primitive readFile             :: FilePath -> IO String
  8565. interact  :: (String -> String) -> IO ()
  8566. interact f = getContents >>= (putStr . f)
  8567. instance Functor IO where
  8568.     fmap f x = x >>= (return . f)
  8569. instance Monad IO where
  8570.     (>>=)  = primbindIO
  8571.     return = primretIO
  8572. -- Hooks for primitives: -----------------------------------------------------
  8573. -- Do not mess with these!
  8574. data Addr     -- builtin datatype of C pointers
  8575. newtype IO a = IO ((IOError -> IOResult a) -> (a -> IOResult a) -> IOResult a)
  8576. data IOResult a 
  8577.   = Hugs_ExitWith Int
  8578.   | Hugs_SuspendThread
  8579.   | Hugs_Error    IOError
  8580.   | Hugs_Return   a
  8581. hugsPutStr :: String -> IO ()
  8582. hugsPutStr  = putStr
  8583. hugsIORun  :: IO a -> Either Int a
  8584. hugsIORun m = performIO (runAndShowError m)
  8585.  where
  8586.   performIO       :: IO a -> Either Int a
  8587.   performIO (IO m) = case m Hugs_Error Hugs_Return of
  8588.                  Hugs_Return a   -> Right a
  8589.              Hugs_ExitWith e -> Left  e
  8590.              _               -> Left  1
  8591.   runAndShowError :: IO a -> IO a
  8592.   runAndShowError m =
  8593.     m `catch` \err -> do 
  8594.     putChar '\n'
  8595.     putStr (ioeGetErrorString err)
  8596.     primExitWith 1 -- alternatively: (IO (\f s -> Hugs_SuspendThread))
  8597. primExitWith     :: Int -> IO a
  8598. primExitWith c    = IO (\ f s -> Hugs_ExitWith c)
  8599. primitive ioeGetErrorString "primShowIOError" :: IOError -> String
  8600. instance Show IOError where
  8601.   showsPrec p x = showString (ioeGetErrorString x)
  8602. primCompAux      :: Ord a => a -> a -> Ordering -> Ordering
  8603. primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
  8604. primPmInt        :: Num a => Int -> a -> Bool
  8605. primPmInt n x     = fromInt n == x
  8606. primPmInteger    :: Num a => Integer -> a -> Bool
  8607. primPmInteger n x = fromInteger n == x
  8608. primPmFlt        :: Fractional a => Double -> a -> Bool
  8609. primPmFlt n x     = fromDouble n == x
  8610. -- The following primitives are only needed if (n+k) patterns are enabled:
  8611. primPmNpk        :: Integral a => Int -> a -> Maybe a
  8612. primPmNpk n x     = if n'<=x then Just (x-n') else Nothing
  8613.             where n' = fromInt n
  8614. primPmSub        :: Integral a => Int -> a -> a
  8615. primPmSub n x     = x - fromInt n
  8616. -- End of Hugs standard prelude ----------------------------------------------
  8617. -----------------------------------------------------------------------------
  8618. -- Standard Library: Numeric operations
  8619. -- Suitable for use with Hugs 98
  8620. -----------------------------------------------------------------------------
  8621. module Numeric(fromRat,
  8622.                showSigned, showInt,
  8623.                readSigned, readInt,
  8624.                readDec, readOct, readHex, 
  8625.                floatToDigits,
  8626.                showEFloat, showFFloat, showGFloat, showFloat, 
  8627.                readFloat, lexDigits) where
  8628. -- Many of these functions have been moved to the Prelude.
  8629. -- The RealFloat instances in the Prelude do not use this floating
  8630. -- point format routine.
  8631. import Char
  8632. import Array
  8633. -- This converts a rational to a floating.  This should be used in the
  8634. -- Fractional instances of Float and Double.
  8635. fromRat :: (RealFloat a) => Rational -> a
  8636. fromRat x = 
  8637.     if x == 0 then encodeFloat 0 0              -- Handle exceptional cases
  8638.     else if x < 0 then - fromRat' (-x)          -- first.
  8639.     else fromRat' x
  8640. -- Conversion process:
  8641. -- Scale the rational number by the RealFloat base until
  8642. -- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
  8643. -- Then round the rational to an Integer and encode it with the exponent
  8644. -- that we got from the scaling.
  8645. -- To speed up the scaling process we compute the log2 of the number to get
  8646. -- a first guess of the exponent.
  8647. fromRat' :: (RealFloat a) => Rational -> a
  8648. fromRat' x = r
  8649.   where b = floatRadix r
  8650.         p = floatDigits r
  8651.         (minExp0, _) = floatRange r
  8652.         minExp = minExp0 - p            -- the real minimum exponent
  8653.         xMin = toRational (expt b (p-1))
  8654.         xMax = toRational (expt b p)
  8655.         p0 = (integerLogBase b (numerator x) -
  8656.               integerLogBase b (denominator x) - p) `max` minExp
  8657.         f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
  8658.         (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
  8659.         r = encodeFloat (round x') p'
  8660. -- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
  8661. scaleRat :: Rational -> Int -> Rational -> Rational -> 
  8662.              Int -> Rational -> (Rational, Int)
  8663. scaleRat b minExp xMin xMax p x =
  8664.     if p <= minExp then
  8665.         (x, p)
  8666.     else if x >= xMax then
  8667.         scaleRat b minExp xMin xMax (p+1) (x/b)
  8668.     else if x < xMin  then
  8669.         scaleRat b minExp xMin xMax (p-1) (x*b)
  8670.     else
  8671.         (x, p)
  8672. -- Exponentiation with a cache for the most common numbers.
  8673. minExpt = 0::Int
  8674. maxExpt = 1100::Int
  8675. expt :: Integer -> Int -> Integer
  8676. expt base n =
  8677.     if base == 2 && n >= minExpt && n <= maxExpt then
  8678.         expts!n
  8679.     else
  8680.         base^n
  8681. expts :: Array Int Integer
  8682. expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
  8683. -- Compute the (floor of the) log of i in base b.
  8684. -- Simplest way would be just divide i by b until it's smaller then b,
  8685. -- but that would be very slow!  We are just slightly more clever.
  8686. integerLogBase :: Integer -> Integer -> Int
  8687. integerLogBase b i =
  8688.      if i < b then
  8689.         0
  8690.      else
  8691.         -- Try squaring the base first to cut down the number of divisions.
  8692.         let l = 2 * integerLogBase (b*b) i
  8693.             doDiv :: Integer -> Int -> Int
  8694.             doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
  8695.         in  doDiv (i `div` (b^l)) l
  8696. -- Misc utilities to show integers and floats 
  8697. showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
  8698. showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
  8699. showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
  8700. showFloat      :: (RealFloat a) => a -> ShowS
  8701. showEFloat d x =  showString (formatRealFloat FFExponent d x)
  8702. showFFloat d x =  showString (formatRealFloat FFFixed d x)
  8703. showGFloat d x =  showString (formatRealFloat FFGeneric d x)
  8704. showFloat      =  showGFloat Nothing 
  8705. -- These are the format types.  This type is not exported.
  8706. data FFFormat = FFExponent | FFFixed | FFGeneric
  8707. formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
  8708. formatRealFloat fmt decs x = s
  8709.   where base = 10
  8710.         s = if isNaN x then 
  8711.                 "NaN"
  8712.             else if isInfinite x then 
  8713.                 if x < 0 then "-Infinity" else "Infinity"
  8714.             else if x < 0 || isNegativeZero x then 
  8715.                 '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
  8716.             else 
  8717.                 doFmt fmt (floatToDigits (toInteger base) x)
  8718.         doFmt fmt (is, e) =
  8719.             let ds = map intToDigit is
  8720.             in  case fmt of
  8721.                 FFGeneric -> 
  8722.                     doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
  8723.                           (is, e)
  8724.                 FFExponent ->
  8725.                     case decs of
  8726.                     Nothing ->
  8727.                         case ds of
  8728.                          ['0'] -> "0.0e0"
  8729.                          [d]   -> d : ".0e" ++ show (e-1)
  8730.                          d:ds  -> d : '.' : ds ++ 'e':show (e-1)
  8731.                     Just dec ->
  8732.                         let dec' = max dec 1 in
  8733.                         case is of
  8734.                          [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
  8735.                          _ ->
  8736.                           let (ei, is') = roundTo base (dec'+1) is
  8737.                               d:ds = map intToDigit
  8738.                                          (if ei > 0 then init is' else is')
  8739.                           in d:'.':ds  ++ "e" ++ show (e-1+ei)
  8740.                 FFFixed ->
  8741.                     case decs of
  8742.                     Nothing ->
  8743.                         let f 0 s ds = mk0 s ++ "." ++ mk0 ds
  8744.                             f n s "" = f (n-1) (s++"0") ""
  8745.                             f n s (d:ds) = f (n-1) (s++[d]) ds
  8746.                             mk0 "" = "0"
  8747.                             mk0 s = s
  8748.                         in  f e "" ds
  8749.                     Just dec ->
  8750.                         let dec' = max dec 0 in
  8751.                         if e >= 0 then
  8752.                             let (ei, is') = roundTo base (dec' + e) is
  8753.                                 (ls, rs) = splitAt (e+ei) (map intToDigit is')
  8754.                             in  (if null ls then "0" else ls) ++ 
  8755.                                 (if null rs then "" else '.' : rs)
  8756.                         else
  8757.                             let (ei, is') = roundTo base dec'
  8758.                                               (replicate (-e) 0 ++ is)
  8759.                                 d : ds = map intToDigit
  8760.                                             (if ei > 0 then is' else 0:is')
  8761.                             in  d : '.' : ds
  8762. roundTo :: Int -> Int -> [Int] -> (Int, [Int])
  8763. roundTo base d is = case f d is of
  8764.                 (0, is) -> (0, is)
  8765.                 (1, is) -> (1, 1 : is)
  8766.   where b2 = base `div` 2
  8767.         f n [] = (0, replicate n 0)
  8768.         f 0 (i:_) = (if i >= b2 then 1 else 0, [])
  8769.         f d (i:is) = 
  8770.             let (c, ds) = f (d-1) is
  8771.                 i' = c + i
  8772.             in  if i' == base then (1, 0:ds) else (0, i':ds)
  8773. -- Based on "Printing Floating-Point Numbers Quickly and Accurately"
  8774. -- by R.G. Burger and R. K. Dybvig, in PLDI 96.
  8775. -- This version uses a much slower logarithm estimator.  It should be improved.
  8776. -- This function returns a list of digits (Ints in [0..base-1]) and an
  8777. -- exponent.
  8778. floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
  8779. floatToDigits _ 0 = ([0], 0)
  8780. floatToDigits base x =
  8781.     let (f0, e0) = decodeFloat x
  8782.         (minExp0, _) = floatRange x
  8783.         p = floatDigits x
  8784.         b = floatRadix x
  8785.         minExp = minExp0 - p            -- the real minimum exponent
  8786.         -- Haskell requires that f be adjusted so denormalized numbers
  8787.         -- will have an impossibly low exponent.  Adjust for this.
  8788.         (f, e) = let n = minExp - e0
  8789.                  in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
  8790.         (r, s, mUp, mDn) =
  8791.            if e >= 0 then
  8792.                let be = b^e in
  8793.                if f == b^(p-1) then
  8794.                    (f*be*b*2, 2*b, be*b, b)
  8795.                else
  8796.                    (f*be*2, 2, be, be)
  8797.            else
  8798.                if e > minExp && f == b^(p-1) then
  8799.                    (f*b*2, b^(-e+1)*2, b, 1)
  8800.                else
  8801.                    (f*2, b^(-e)*2, 1, 1)
  8802.         k = 
  8803.             let k0 =
  8804.                     if b==2 && base==10 then
  8805.                         -- logBase 10 2 is slightly bigger than 3/10 so
  8806.                         -- the following will err on the low side.  Ignoring
  8807.                         -- the fraction will make it err even more.
  8808.                         -- Haskell promises that p-1 <= logBase b f < p.
  8809.                         (p - 1 + e0) * 3 `div` 10
  8810.                     else
  8811.                         ceiling ((log (fromInteger (f+1)) + 
  8812.                                  fromInt e * log (fromInteger b)) / 
  8813.                                   log (fromInteger base))
  8814.                 fixup n =
  8815.                     if n >= 0 then
  8816.                         if r + mUp <= expt base n * s then n else fixup (n+1)
  8817.                     else
  8818.                         if expt base (-n) * (r + mUp) <= s then n
  8819.                                                            else fixup (n+1)
  8820.             in  fixup k0
  8821.         gen ds rn sN mUpN mDnN =
  8822.             let (dn, rn') = (rn * base) `divMod` sN
  8823.                 mUpN' = mUpN * base
  8824.                 mDnN' = mDnN * base
  8825.             in  case (rn' < mDnN', rn' + mUpN' > sN) of
  8826.                 (True,  False) -> dn : ds
  8827.                 (False, True)  -> dn+1 : ds
  8828.                 (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds
  8829.                 (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
  8830.         rds =
  8831.             if k >= 0 then
  8832.                 gen [] r (s * expt base k) mUp mDn
  8833.             else
  8834.                 let bk = expt base (-k)
  8835.                 in  gen [] (r * bk) s (mUp * bk) (mDn * bk)
  8836.     in  (map toInt (reverse rds), k)
  8837. -----------------------------------------------------------------------------
  8838. -- Standard Library: Monad operations
  8839. -- Suitable for use with Hugs 98
  8840. -----------------------------------------------------------------------------
  8841. module Monad (
  8842.     MonadPlus(mzero, mplus),
  8843.     join, guard, when, unless, ap,
  8844.     msum,
  8845.     filterM, mapAndUnzipM, zipWithM, zipWithM_, foldM,
  8846.     liftM, liftM2, liftM3, liftM4, liftM5,
  8847.     -- ... and what the Prelude exports
  8848.     Monad((>>=), (>>), return, fail),
  8849.     Functor(fmap),
  8850.     mapM, mapM_, sequence, sequence_, (=<<),
  8851.     ) where
  8852. -- The MonadPlus class definition
  8853. class Monad m => MonadPlus m where
  8854.     mzero :: m a
  8855.     mplus :: m a -> m a -> m a
  8856. -- Instances of MonadPlus
  8857. instance MonadPlus Maybe where
  8858.     mzero              = Nothing
  8859.     Nothing `mplus` ys = ys
  8860.     xs      `mplus` ys = xs
  8861. instance MonadPlus [ ] where
  8862.     mzero = []
  8863.     mplus = (++)
  8864. -- Functions
  8865. msum             :: MonadPlus m => [m a] -> m a
  8866. msum              = foldr mplus mzero
  8867. join             :: (Monad m) => m (m a) -> m a
  8868. join x            = x >>= id
  8869. when          :: (Monad m) => Bool -> m () -> m ()
  8870. when p s      = if p then s else return ()
  8871. unless          :: (Monad m) => Bool -> m () -> m ()
  8872. unless p s      = when (not p) s
  8873. ap               :: (Monad m) => m (a -> b) -> m a -> m b
  8874. ap                = liftM2 ($)
  8875. guard            :: MonadPlus m => Bool -> m ()
  8876. guard p           = if p then return () else mzero
  8877. mapAndUnzipM     :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
  8878. mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip
  8879. zipWithM         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
  8880. zipWithM f xs ys  = sequence (zipWith f xs ys)
  8881. zipWithM_        :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()
  8882. zipWithM_ f xs ys = sequence_ (zipWith f xs ys)
  8883. foldM            :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
  8884. foldM f a []      = return a
  8885. foldM f a (x:xs)  = f a x >>= \ y -> foldM f y xs
  8886. filterM          :: Monad m => (a -> m Bool) -> [a] -> m [a]
  8887. filterM p []      = return []
  8888. filterM p (x:xs)  = do b <- p x
  8889.                        ys <- filterM p xs
  8890.                        return (if b then (x:ys) else ys)
  8891. liftM            :: (Monad m) => (a -> b) -> (m a -> m b)
  8892. liftM f           = \a -> do { a' <- a; return (f a') }
  8893. liftM2           :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)
  8894. liftM2 f          = \a b -> do { a' <- a; b' <- b; return (f a' b') }
  8895. liftM3           :: (Monad m) => (a -> b -> c -> d) ->
  8896.                                  (m a -> m b -> m c -> m d)
  8897. liftM3 f          = \a b c -> do { a' <- a; b' <- b; c' <- c;
  8898.                    return (f a' b' c')}
  8899. liftM4           :: (Monad m) => (a -> b -> c -> d -> e) ->
  8900.                                  (m a -> m b -> m c -> m d -> m e)
  8901. liftM4 f          = \a b c d -> do { a' <- a; b' <- b; c' <- c; d' <- d;
  8902.                      return (f a' b' c' d')}
  8903. liftM5           :: (Monad m) => (a -> b -> c -> d -> e -> f) ->
  8904.                                  (m a -> m b -> m c -> m d -> m e -> m f)
  8905. liftM5 f          = \a b c d e -> do { a' <- a; b' <- b; c' <- c; d' <- d;
  8906.                        e' <- e; return (f a' b' c' d' e')}
  8907. -----------------------------------------------------------------------------
  8908. -----------------------------------------------------------------------------
  8909. -- Standard Library: Operations on the Maybe datatype
  8910. -- Suitable for use with Hugs 98
  8911. -----------------------------------------------------------------------------
  8912. module Maybe(
  8913.     isJust, isNothing,
  8914.     fromJust, fromMaybe, listToMaybe, maybeToList,
  8915.     catMaybes, mapMaybe,
  8916.     -- ... and what the Prelude exports
  8917.     Maybe(Nothing, Just),
  8918.     maybe
  8919.     ) where
  8920. isJust              :: Maybe a -> Bool
  8921. isJust (Just a)        = True
  8922. isJust Nothing         = False
  8923. isNothing             :: Maybe a -> Bool
  8924. isNothing Nothing      = True
  8925. isNothing (Just a)     = False
  8926. fromJust              :: Maybe a -> a
  8927. fromJust (Just a)      = a
  8928. fromJust Nothing       = error "Maybe.fromJust: Nothing"
  8929. fromMaybe             :: a -> Maybe a -> a
  8930. fromMaybe d Nothing    = d
  8931. fromMaybe d (Just a)   = a
  8932. maybeToList           :: Maybe a -> [a]
  8933. maybeToList Nothing    = []
  8934. maybeToList (Just a)   = [a]
  8935. listToMaybe           :: [a] -> Maybe a
  8936. listToMaybe []         = Nothing
  8937. listToMaybe (a:as)     = Just a
  8938. catMaybes             :: [Maybe a] -> [a]
  8939. catMaybes ms           = [ m | Just m <- ms ]
  8940. mapMaybe              :: (a -> Maybe b) -> [a] -> [b]
  8941. mapMaybe f             = catMaybes . map f
  8942. -----------------------------------------------------------------------------
  8943. % (c) The GRASP/AQUA Project, Glasgow University, 1995-99
  8944. \section[Time]{Haskell 1.4 Locale Library}
  8945. \begin{code}
  8946. module Locale(TimeLocale(..), defaultTimeLocale) where
  8947. import Prelude  -- so as to force recompilations when reqd.
  8948. data TimeLocale = TimeLocale {
  8949.         wDays  :: [(String, String)],   -- full and abbreviated week days
  8950.         months :: [(String, String)],   -- full and abbreviated months
  8951.         amPm   :: (String, String),     -- AM/PM symbols
  8952.         dateTimeFmt, dateFmt,           -- formatting strings
  8953.         timeFmt, time12Fmt :: String     
  8954.         } deriving (Eq, Ord, Show)
  8955. defaultTimeLocale :: TimeLocale 
  8956. defaultTimeLocale =  TimeLocale { 
  8957.         wDays  = [("Sunday",   "Sun"),  ("Monday",    "Mon"),   
  8958.                   ("Tuesday",  "Tue"),  ("Wednesday", "Wed"), 
  8959.                   ("Thursday", "Thu"),  ("Friday",    "Fri"), 
  8960.                   ("Saturday", "Sat")],
  8961.         months = [("January",   "Jan"), ("February",  "Feb"),
  8962.                   ("March",     "Mar"), ("April",     "Apr"),
  8963.                   ("May",       "May"), ("June",      "Jun"),
  8964.                   ("July",      "Jul"), ("August",    "Aug"),
  8965.                   ("September", "Sep"), ("October",   "Oct"),
  8966.                   ("November",  "Nov"), ("December",  "Dec")],
  8967.         amPm = ("AM", "PM"),
  8968.         dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y",
  8969.         dateFmt = "%m/%d/%y",
  8970.         timeFmt = "%H:%M:%S",
  8971.         time12Fmt = "%I:%M:%S %p"
  8972.         }
  8973. \end{code}
  8974. -----------------------------------------------------------------------------
  8975. -- Standard Library: List operations
  8976. -- Suitable for use with Hugs 98
  8977. -----------------------------------------------------------------------------
  8978. module List ( 
  8979.     elemIndex, elemIndices,
  8980.     find, findIndex, findIndices,
  8981.     nub, nubBy, delete, deleteBy, (\\), deleteFirstsBy,
  8982.     union, unionBy, intersect, intersectBy,
  8983.     intersperse, transpose, partition, group, groupBy,
  8984.     inits, tails, isPrefixOf, isSuffixOf,
  8985.     mapAccumL, mapAccumR,
  8986.     sort, sortBy, insert, insertBy, maximumBy, minimumBy,
  8987.     genericLength, genericTake, genericDrop,
  8988.     genericSplitAt, genericIndex, genericReplicate,
  8989.     zip4, zip5, zip6, zip7,
  8990.     zipWith4, zipWith5, zipWith6, zipWith7,
  8991.     unzip4, unzip5, unzip6, unzip7, unfoldr,
  8992.     -- ... and what the Prelude exports
  8993.     --  List type: []((:), [])
  8994.     (:),
  8995.     map, (++), concat, filter,
  8996.     head, last, tail, init, null, length, (!!),
  8997.     foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
  8998.     iterate, repeat, replicate, cycle,
  8999.     take, drop, splitAt, takeWhile, dropWhile, span, break,
  9000.     lines, words, unlines, unwords, reverse, and, or,
  9001.     any, all, elem, notElem, lookup,
  9002.     sum, product, maximum, minimum, concatMap, 
  9003.     zip, zip3, zipWith, zipWith3, unzip, unzip3
  9004.     ) where
  9005. import Maybe( listToMaybe )
  9006. infix 5 \\
  9007. elemIndex               :: Eq a => a -> [a] -> Maybe Int
  9008. elemIndex x              = findIndex (x ==)
  9009.         
  9010. elemIndices             :: Eq a => a -> [a] -> [Int]
  9011. elemIndices x            = findIndices (x ==)
  9012.                 
  9013. find                    :: (a -> Bool) -> [a] -> Maybe a
  9014. find p                   = listToMaybe . filter p
  9015. findIndex               :: (a -> Bool) -> [a] -> Maybe Int
  9016. findIndex p              = listToMaybe . findIndices p
  9017. findIndices             :: (a -> Bool) -> [a] -> [Int]
  9018. findIndices p xs         = [ i | (x,i) <- zip xs [0..], p x ]
  9019. nub                     :: (Eq a) => [a] -> [a]
  9020. nub                      = nubBy (==)
  9021. nubBy            :: (a -> a -> Bool) -> [a] -> [a]
  9022. nubBy eq []              = []
  9023. nubBy eq (x:xs)          = x : nubBy eq (filter (\y -> not (eq x y)) xs)
  9024. delete                  :: (Eq a) => a -> [a] -> [a]
  9025. delete                   = deleteBy (==)
  9026. deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a]
  9027. deleteBy eq x []         = []
  9028. deleteBy eq x (y:ys)     = if x `eq` y then ys else y : deleteBy eq x ys
  9029. (\\)                    :: (Eq a) => [a] -> [a] -> [a]
  9030. (\\)                     = foldl (flip delete)
  9031. deleteFirstsBy          :: (a -> a -> Bool) -> [a] -> [a] -> [a]
  9032. deleteFirstsBy eq        = foldl (flip (deleteBy eq))
  9033. union                   :: (Eq a) => [a] -> [a] -> [a]
  9034. union                    = unionBy (==)    
  9035. unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]
  9036. unionBy eq xs ys         = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs
  9037. intersect               :: (Eq a) => [a] -> [a] -> [a]
  9038. intersect                = intersectBy (==)
  9039. intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]
  9040. intersectBy eq xs ys     = [x | x <- xs, any (eq x) ys]
  9041. intersperse             :: a -> [a] -> [a]
  9042. intersperse sep []       = []
  9043. intersperse sep [x]      = [x]
  9044. intersperse sep (x:xs)   = x : sep : intersperse sep xs
  9045. transpose               :: [[a]] -> [[a]]
  9046. transpose []             = []
  9047. transpose ([] : xss)     = transpose xss
  9048. transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) :
  9049.                            transpose (xs : [ t | (h:t) <- xss])
  9050. partition               :: (a -> Bool) -> [a] -> ([a],[a])
  9051. partition p xs           = foldr select ([],[]) xs
  9052.                  where select x (ts,fs) | p x       = (x:ts,fs)
  9053.                                   | otherwise = (ts,x:fs)
  9054. -- group splits its list argument into a list of lists of equal, adjacent
  9055. -- elements.  e.g.,
  9056. -- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"]
  9057. group                   :: (Eq a) => [a] -> [[a]]
  9058. group                    = groupBy (==)
  9059. groupBy                 :: (a -> a -> Bool) -> [a] -> [[a]]
  9060. groupBy eq []            = []
  9061. groupBy eq (x:xs)        = (x:ys) : groupBy eq zs
  9062.                            where (ys,zs) = span (eq x) xs
  9063. -- inits xs returns the list of initial segments of xs, shortest first.
  9064. -- e.g., inits "abc" == ["","a","ab","abc"]
  9065. inits                   :: [a] -> [[a]]
  9066. inits []                 = [[]]
  9067. inits (x:xs)             = [[]] ++ map (x:) (inits xs)
  9068. -- tails xs returns the list of all final segments of xs, longest first.
  9069. -- e.g., tails "abc" == ["abc", "bc", "c",""]
  9070. tails                   :: [a] -> [[a]]
  9071. tails []                 = [[]]
  9072. tails xxs@(_:xs)         = xxs : tails xs
  9073. isPrefixOf              :: (Eq a) => [a] -> [a] -> Bool
  9074. isPrefixOf [] _          = True
  9075. isPrefixOf _  []         = False
  9076. isPrefixOf (x:xs) (y:ys) = x == y && isPrefixOf xs ys
  9077. isSuffixOf              :: (Eq a) => [a] -> [a] -> Bool
  9078. isSuffixOf x y           = reverse x `isPrefixOf` reverse y
  9079. mapAccumL               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
  9080. mapAccumL f s []         = (s, [])
  9081. mapAccumL f s (x:xs)     = (s'',y:ys)
  9082.                          where (s', y ) = f s x
  9083.                                (s'',ys) = mapAccumL f s' xs
  9084. mapAccumR               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
  9085. mapAccumR f s []         = (s, [])
  9086. mapAccumR f s (x:xs)     = (s'', y:ys)
  9087.                          where (s'',y ) = f s' x
  9088.                                (s', ys) = mapAccumR f s xs
  9089. unfoldr                 :: (b -> Maybe (a,b)) -> b -> [a]
  9090. unfoldr f b              = case f b of Nothing    -> []
  9091.                                        Just (a,b) -> a : unfoldr f b
  9092. sort            :: (Ord a) => [a] -> [a]
  9093. sort             = sortBy compare
  9094. sortBy            :: (a -> a -> Ordering) -> [a] -> [a]
  9095. sortBy cmp         = foldr (insertBy cmp) []
  9096. insert                  :: (Ord a) => a -> [a] -> [a]
  9097. insert                   = insertBy compare
  9098. insertBy        :: (a -> a -> Ordering) -> a -> [a] -> [a]
  9099. insertBy cmp x []     = [x]
  9100. insertBy cmp x ys@(y:ys')
  9101.              = case cmp x y of
  9102.                 GT -> y : insertBy cmp x ys'
  9103.                 _  -> x : ys
  9104. maximumBy        :: (a -> a -> a) -> [a] -> a
  9105. maximumBy max []     = error "List.maximumBy: empty list"
  9106. maximumBy max xs     = foldl1 max xs
  9107. minimumBy        :: (a -> a -> a) -> [a] -> a
  9108. minimumBy min []     = error "List.minimumBy: empty list"
  9109. minimumBy min xs     = foldl1 min xs
  9110. genericLength           :: (Integral a) => [b] -> a
  9111. genericLength []         = 0
  9112. genericLength (x:xs)     = 1 + genericLength xs
  9113. genericTake             :: (Integral a) => a -> [b] -> [b]
  9114. genericTake 0 _          = []
  9115. genericTake _ []         = []
  9116. genericTake n (x:xs) 
  9117.    | n > 0               = x : genericTake (n-1) xs
  9118.    | otherwise           = error "List.genericTake: negative argument"
  9119. genericDrop             :: (Integral a) => a -> [b] -> [b]
  9120. genericDrop 0 xs         = xs
  9121. genericDrop _ []         = []
  9122. genericDrop n (_:xs) 
  9123.    | n > 0               = genericDrop (n-1) xs
  9124.    | otherwise           = error "List.genericDrop: negative argument"
  9125. genericSplitAt          :: (Integral a) => a -> [b] -> ([b],[b])
  9126. genericSplitAt 0 xs      = ([],xs)
  9127. genericSplitAt _ []      = ([],[])
  9128. genericSplitAt n (x:xs) 
  9129.    | n > 0              =  (x:xs',xs'')
  9130.    | otherwise          =  error "List.genericSplitAt: negative argument"
  9131.        where (xs',xs'') =  genericSplitAt (n-1) xs
  9132. genericIndex            :: (Integral a) => [b] -> a -> b
  9133. genericIndex (x:_)  0    = x
  9134. genericIndex (_:xs) n 
  9135.         | n > 0          = genericIndex xs (n-1)
  9136.         | otherwise      = error "List.genericIndex: negative argument"
  9137. genericIndex _ _         = error "List.genericIndex: index too large"
  9138. genericReplicate        :: (Integral a) => a -> b -> [b]
  9139. genericReplicate n x     = genericTake n (repeat x)
  9140. zip4            :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
  9141. zip4             = zipWith4 (,,,)
  9142. zip5            :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
  9143. zip5             = zipWith5 (,,,,)
  9144. zip6            :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> 
  9145.                               [(a,b,c,d,e,f)]
  9146. zip6             = zipWith6 (,,,,,)
  9147. zip7            :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
  9148.                               [g] -> [(a,b,c,d,e,f,g)]
  9149. zip7             = zipWith7 (,,,,,,)
  9150. zipWith4        :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
  9151. zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
  9152.              = z a b c d : zipWith4 z as bs cs ds
  9153. zipWith4 _ _ _ _ _     = []
  9154. zipWith5        :: (a->b->c->d->e->f) -> 
  9155.                            [a]->[b]->[c]->[d]->[e]->[f]
  9156. zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
  9157.              = z a b c d e : zipWith5 z as bs cs ds es
  9158. zipWith5 _ _ _ _ _ _     = []
  9159. zipWith6        :: (a->b->c->d->e->f->g) ->
  9160.                            [a]->[b]->[c]->[d]->[e]->[f]->[g]
  9161. zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
  9162.              = z a b c d e f : zipWith6 z as bs cs ds es fs
  9163. zipWith6 _ _ _ _ _ _ _     = []
  9164. zipWith7        :: (a->b->c->d->e->f->g->h) ->
  9165.                            [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
  9166. zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
  9167.            =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs
  9168. zipWith7 _ _ _ _ _ _ _ _ = []
  9169. unzip4            :: [(a,b,c,d)] -> ([a],[b],[c],[d])
  9170. unzip4             = foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
  9171.                     (a:as,b:bs,c:cs,d:ds))
  9172.                  ([],[],[],[])
  9173. unzip5            :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
  9174. unzip5             = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
  9175.                     (a:as,b:bs,c:cs,d:ds,e:es))
  9176.                  ([],[],[],[],[])
  9177. unzip6            :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
  9178. unzip6             = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
  9179.                     (a:as,b:bs,c:cs,d:ds,e:es,f:fs))
  9180.                  ([],[],[],[],[],[])
  9181. unzip7        :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
  9182. unzip7        =  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
  9183.                 (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
  9184.              ([],[],[],[],[],[],[])
  9185. -----------------------------------------------------------------------------
  9186. -----------------------------------------------------------------------------
  9187. -- Standard Library: Ix operations
  9188. -- Suitable for use with Hugs 98
  9189. -----------------------------------------------------------------------------
  9190. module Ix ( 
  9191.     -- official Haskell 98 interface: Ix(range, index, inRange), rangeSize 
  9192.     Ix(range, index, inRange, rangeSize)
  9193.     ) where
  9194. -- This module is empty; Ix is currently defined in the prelude, but should
  9195. -- eventually be moved to this library file instead.
  9196. -----------------------------------------------------------------------------
  9197. -----------------------------------------------------------------------------
  9198. -- Standard Library: IO operations, beyond those included in the prelude
  9199. -- WARNING: The names and semantics of functions defined in this module
  9200. -- may change as the details of the IO standard are clarified.
  9201. -- Suitable for use with Hugs 98
  9202. -----------------------------------------------------------------------------
  9203. module IO (
  9204.     Handle, HandlePosn,
  9205. --  IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),
  9206.     IOMode(ReadMode,WriteMode,AppendMode),
  9207.     BufferMode(NoBuffering,LineBuffering,BlockBuffering),
  9208.     SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
  9209.     stdin, stdout, stderr, 
  9210.     openFile, hClose, 
  9211. --  hFileSize, hIsEOF, isEOF,
  9212. --  hSetBuffering, hGetBuffering, hFlush, 
  9213.     hFlush, 
  9214.     hGetPosn, hSetPosn, 
  9215. --  hSeek, hIsSeekable,
  9216. --  hReady, hGetChar, hLookAhead, hGetContents, 
  9217.     hGetChar, hGetLine, hGetContents, 
  9218.     hPutChar, hPutStr, hPutStrLn, hPrint,
  9219.     hIsOpen, hIsClosed, hIsReadable, hIsWritable, 
  9220.     isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError, 
  9221.     isFullError, isEOFError,
  9222.     isIllegalOperation, isPermissionError, isUserError, 
  9223.     ioeGetErrorString, ioeGetHandle, ioeGetFileName,
  9224.     try, bracket, bracket_,
  9225.     -- Non-standard extensions 
  9226.     hugsIsEOF, hugsHIsEOF,
  9227.     hugsIsSearchErr, hugsIsNameErr, hugsIsWriteErr,
  9228.     -- ... and what the Prelude exports
  9229.     IO,
  9230.     FilePath, IOError, ioError, userError, catch,
  9231.     putChar, putStr, putStrLn, print,
  9232.     getChar, getLine, getContents, interact,
  9233.     readFile, writeFile, appendFile, readIO, readLn
  9234.     ) where
  9235. import Ix(Ix)
  9236. data Handle
  9237. instance Eq Handle where (==) = primEqHandle
  9238. primitive primEqHandle :: Handle -> Handle -> Bool
  9239. newtype HandlePosn = HandlePosn Int deriving Eq
  9240. --data IOMode      =  ReadMode | WriteMode | AppendMode | ReadWriteMode
  9241. data IOMode      = ReadMode | WriteMode | AppendMode
  9242.                     deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
  9243. data BufferMode  =  NoBuffering | LineBuffering 
  9244.                  |  BlockBuffering (Maybe Int)
  9245.                     deriving (Eq, Ord, Read, Show)
  9246. data SeekMode    =  AbsoluteSeek | RelativeSeek | SeekFromEnd
  9247.                     deriving (Eq, Ord, Ix, Bounded, Enum, Read, Show)
  9248. primitive stdin       :: Handle
  9249. primitive stdout      :: Handle
  9250. primitive stderr      :: Handle
  9251. primitive openFile    :: FilePath -> IOMode -> IO Handle
  9252. primitive hClose      :: Handle -> IO ()
  9253. --Not yet implemented:
  9254. --hFileSize           :: Handle -> IO Integer
  9255. --hIsEOF              :: Handle -> IO Bool
  9256. --isEOF               :: IO Bool
  9257. --isEOF                = hIsEOF stdin
  9258. --hSetBuffering       :: Handle  -> BufferMode -> IO ()
  9259. --hGetBuffering       :: Handle  -> IO BufferMode
  9260. primitive hFlush      :: Handle -> IO ()
  9261. primitive hGetPosn    :: Handle -> IO HandlePosn
  9262. primitive hSetPosn    :: HandlePosn -> IO () 
  9263. --hSeek               :: Handle -> SeekMode -> Integer -> IO () 
  9264. --hWaitForInput          :: Handle -> Int -> IO Bool
  9265. --hReady              :: Handle -> IO Bool 
  9266. --hReady h           = hWaitForInput h 0
  9267. primitive hGetChar    :: Handle -> IO Char
  9268. hGetLine              :: Handle -> IO String
  9269. hGetLine h             = do c <- hGetChar h
  9270.                             if c=='\n' then return ""
  9271.                               else do cs <- hGetLine h
  9272.                                       return (c:cs)
  9273. --hLookAhead          :: Handle -> IO Char
  9274. primitive hGetContents:: Handle -> IO String
  9275. primitive hPutChar    :: Handle -> Char -> IO ()
  9276. primitive hPutStr     :: Handle -> String -> IO ()
  9277. hPutStrLn             :: Handle -> String -> IO ()
  9278. hPutStrLn h s          = do { hPutStr h s; hPutChar h '\n' }
  9279. hPrint                :: Show a => Handle -> a -> IO ()
  9280. hPrint h               = hPutStrLn h . show
  9281. primitive hIsOpen,    
  9282.          hIsClosed,  
  9283.          hIsReadable,
  9284.          hIsWritable :: Handle -> IO Bool
  9285. --hIsSeekable         :: Handle -> IO Bool
  9286. primitive isIllegalOperation, 
  9287.       isAlreadyExistsError, 
  9288.       isDoesNotExistError, 
  9289.           isAlreadyInUseError,   
  9290.       isFullError,     
  9291.           isEOFError, 
  9292.       isPermissionError,
  9293.           isUserError        :: IOError -> Bool
  9294. primitive ioeGetErrorString "primShowIOError" :: IOError -> String
  9295. primitive ioeGetHandle      :: IOError -> Maybe Handle
  9296. primitive ioeGetFileName    :: IOError -> Maybe FilePath
  9297. try       :: IO a -> IO (Either IOError a)
  9298. try p      = catch (p >>= (return . Right)) (return . Left)
  9299. bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
  9300. bracket before after m = do
  9301.         x  <- before
  9302.         rs <- try (m x)
  9303.         after x
  9304.         case rs of
  9305.            Right r -> return r
  9306.            Left  e -> ioError e
  9307. -- variant of the above where middle computation doesn't want x
  9308. bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
  9309. bracket_ before after m = do
  9310.          x  <- before
  9311.          rs <- try m
  9312.          after x
  9313.          case rs of
  9314.             Right r -> return r
  9315.             Left  e -> ioError e
  9316. -----------------------------------------------------------------------------
  9317. -- Non-standard extensions 
  9318. -- (likely to disappear when IO library is more complete)
  9319. -- C library style test for EOF (doesn't obey Haskell semantics)
  9320. primitive hugsHIsEOF "hIsEOF" :: Handle -> IO Bool
  9321. hugsIsEOF             :: IO Bool
  9322. hugsIsEOF              = hugsHIsEOF stdin
  9323. primitive hugsIsSearchErr :: IOError -> Bool
  9324. primitive hugsIsNameErr   :: IOError -> Bool
  9325. primitive hugsIsWriteErr  :: IOError -> Bool
  9326. -----------------------------------------------------------------------------
  9327. -----------------------------------------------------------------------------
  9328. -- Standard Library: Complex numbers
  9329. -- Suitable for use with Hugs 98
  9330. -----------------------------------------------------------------------------
  9331. module Complex(Complex((:+)), realPart, imagPart, conjugate, mkPolar,
  9332.                cis, polar, magnitude, phase)  where
  9333. infix  6  :+
  9334. data (RealFloat a) => Complex a = !a :+ !a 
  9335.                       deriving (Eq,Read,Show)
  9336. realPart, imagPart :: (RealFloat a) => Complex a -> a
  9337. realPart (x:+y)     = x
  9338. imagPart (x:+y)     = y
  9339. conjugate          :: (RealFloat a) => Complex a -> Complex a
  9340. conjugate (x:+y)    = x :+ (-y)
  9341. mkPolar            :: (RealFloat a) => a -> a -> Complex a
  9342. mkPolar r theta     = r * cos theta :+ r * sin theta
  9343. cis                :: (RealFloat a) => a -> Complex a
  9344. cis theta           = cos theta :+ sin theta
  9345. polar              :: (RealFloat a) => Complex a -> (a,a)
  9346. polar z             = (magnitude z, phase z)
  9347. magnitude, phase   :: (RealFloat a) => Complex a -> a
  9348. magnitude (x:+y)    = scaleFloat k
  9349.                        (sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2))
  9350.                       where k  = max (exponent x) (exponent y)
  9351.                             mk = - k
  9352. phase (0:+0)        = 0
  9353. phase (x:+y)        = atan2 y x
  9354. instance (RealFloat a) => Num (Complex a) where
  9355.     (x:+y) + (x':+y')  = (x+x') :+ (y+y')
  9356.     (x:+y) - (x':+y')  = (x-x') :+ (y-y')
  9357.     (x:+y) * (x':+y')  = (x*x'-y*y') :+ (x*y'+y*x')
  9358.     negate (x:+y)      = negate x :+ negate y
  9359.     abs z              = magnitude z :+ 0
  9360.     signum 0           = 0
  9361.     signum z@(x:+y)    = x/r :+ y/r where r = magnitude z
  9362.     fromInteger n      = fromInteger n :+ 0
  9363.     fromInt n          = fromInt n :+ 0
  9364. instance (RealFloat a) => Fractional (Complex a) where
  9365.     (x:+y) / (x':+y')  = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d
  9366.              where x'' = scaleFloat k x'
  9367.                    y'' = scaleFloat k y'
  9368.                    k   = - max (exponent x') (exponent y')
  9369.                    d   = x'*x'' + y'*y''
  9370.     fromRational a     = fromRational a :+ 0
  9371.     fromDouble a       = fromDouble a :+ 0
  9372. instance (RealFloat a) => Floating (Complex a) where
  9373.     pi            = pi :+ 0
  9374.     exp (x:+y)    = expx * cos y :+ expx * sin y
  9375.             where expx = exp x
  9376.     log z         = log (magnitude z) :+ phase z
  9377.     sqrt 0        = 0
  9378.     sqrt z@(x:+y) = u :+ (if y < 0 then -v else v)
  9379.             where (u,v) = if x < 0 then (v',u') else (u',v')
  9380.               v'    = abs y / (u'*2)
  9381.               u'    = sqrt ((magnitude z + abs x) / 2)
  9382.     sin (x:+y)    = sin x * cosh y :+ cos x * sinh y
  9383.     cos (x:+y)    = cos x * cosh y :+ (- sin x * sinh y)
  9384.     tan (x:+y)    = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))
  9385.             where sinx  = sin x
  9386.               cosx    = cos x
  9387.               sinhy = sinh y
  9388.               coshy = cosh y
  9389.     sinh (x:+y)   = cos y * sinh x :+ sin  y * cosh x
  9390.     cosh (x:+y)   = cos y * cosh x :+ sin y * sinh x
  9391.     tanh (x:+y)   = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)
  9392.             where siny  = sin y
  9393.               cosy    = cos y
  9394.               sinhx = sinh x
  9395.               coshx = cosh x
  9396.     asin z@(x:+y) =  y':+(-x')
  9397.                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
  9398.     acos z@(x:+y) =  y'':+(-x'')
  9399.                      where (x'':+y'') = log (z + ((-y'):+x'))
  9400.                            (x':+y')   = sqrt (1 - z*z)
  9401.     atan z@(x:+y) =  y':+(-x')
  9402.                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))
  9403.     asinh z       = log (z + sqrt (1+z*z))
  9404.     acosh z       = log (z + (z+1) * sqrt ((z-1)/(z+1)))
  9405.     atanh z       = log ((1+z) / sqrt (1-z*z))
  9406. -----------------------------------------------------------------------------
  9407. -----------------------------------------------------------------------------
  9408. -- Standard Library: Char operations
  9409. -- Suitable for use with Hugs 98
  9410. -----------------------------------------------------------------------------
  9411. module Char ( 
  9412.     isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,
  9413.     isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
  9414.     digitToInt, intToDigit,
  9415.     toUpper, toLower,
  9416.     ord, chr,
  9417.     readLitChar, showLitChar, lexLitChar,
  9418.     -- ... and what the prelude exports
  9419.     Char, String
  9420.     ) where
  9421. -- This module is (almost) empty; Char operations are currently defined in
  9422. -- the prelude, but should eventually be moved to this library file instead.
  9423. -- No Unicode support yet. 
  9424. isLatin1 c = True
  9425. -----------------------------------------------------------------------------
  9426. -----------------------------------------------------------------------------
  9427. -- Standard Library: Array operations
  9428. -- Suitable for use with Hugs 98
  9429. -----------------------------------------------------------------------------
  9430. module  Array ( 
  9431.     module Ix,  -- export all of Ix 
  9432.     Array, array, listArray, (!), bounds, indices, elems, assocs, 
  9433.     accumArray, (//), accum, ixmap ) where
  9434. import Ix
  9435. import List( (\\) )
  9436. infixl 9  !, //
  9437. data Array a b -- Arrays are implemented as a primitive type
  9438. array          :: Ix a => (a,a) -> [(a,b)] -> Array a b
  9439. listArray      :: Ix a => (a,a) -> [b] -> Array a b
  9440. (!)           :: Ix a => Array a b -> a -> b
  9441. bounds         :: Ix a => Array a b -> (a,a)
  9442. indices        :: Ix a => Array a b -> [a]
  9443. elems          :: Ix a => Array a b -> [b]
  9444. assocs           :: Ix a => Array a b -> [(a,b)]
  9445. (//)           :: Ix a => Array a b -> [(a,b)] -> Array a b
  9446. accum          :: Ix a => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b
  9447. accumArray     :: Ix a => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b
  9448. ixmap           :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c
  9449. primitive primArray  :: (a,a) -> Int -> (a -> Int) -> [(a,b)] -> Array a b
  9450. primitive primUpdate :: [(a,b)] -> Array a b -> (a -> Int) -> Array a b
  9451. primitive primAccum
  9452.     :: [(a,c)] -> Array a b -> (b -> c -> b) -> (a -> Int) -> Array a b
  9453. primitive primAccumArray
  9454.     :: (a,a) -> Int -> (b -> c -> b) -> b -> (a -> Int) -> [(a,c)] -> Array a b
  9455. primitive primSubscript
  9456.     :: ((a,a) -> a -> Int) -> Array a b -> a -> b
  9457. primitive primBounds :: Array a b -> (a,a)
  9458. primitive primElems  :: Array a b -> [b]
  9459. primitive primAmap   :: (b -> c) -> Array a b -> Array a c
  9460. array bnds          = primArray bnds (rangeSize bnds) (index bnds)
  9461. listArray bnds vs   = array bnds (zip (range bnds) vs)
  9462. (!)                 = primSubscript index
  9463. bounds              = primBounds
  9464. indices                = range . bounds
  9465. elems               = primElems
  9466. assocs a            = zip (indices a) (elems a)
  9467. accumArray f z bnds = primAccumArray bnds (rangeSize bnds) f z (index bnds)
  9468. a // as             = primUpdate as a (index (bounds a))
  9469. accum f a as        = primAccum as a f (index (bounds a))
  9470. ixmap bnds f a      = array bnds [ (i, a ! f i) | i <- range bnds ]
  9471. instance (Ix a) => Functor (Array a) where
  9472.     fmap = primAmap
  9473. instance (Ix a, Eq b) => Eq (Array a b) where
  9474.     a == a'   =   assocs a == assocs a'
  9475. instance (Ix a, Ord b) => Ord (Array a b) where
  9476.     a <= a'   =   assocs a <= assocs a'
  9477. instance  (Ix a, Show a, Show b) => Show (Array a b)  where
  9478.     showsPrec p a = showParen (p > 9) (
  9479.             showString "array " .
  9480.             shows (bounds a) . showChar ' ' .
  9481.             shows (assocs a)                  )
  9482. instance  (Ix a, Read a, Read b) => Read (Array a b)  where
  9483.     readsPrec p = readParen (p > 9)
  9484.          (\r -> [(array b as, u) | ("array",s) <- lex r,
  9485.                        (b,t)       <- reads s,
  9486.                        (as,u)      <- reads t   ])
  9487. -----------------------------------------------------------------------------
  9488. unsafePtrToInt
  9489. unsafePtrEq
  9490. recEq
  9491. recShw
  9492. recSel
  9493. recBrk
  9494. recExt
  9495. strict
  9496. primUnsafeCoerce
  9497. primCmpDouble
  9498. primEqDouble
  9499. primCmpFloat
  9500. primEqFloat
  9501. primCmpChar
  9502. primEqChar
  9503. primCmpWord
  9504. primEqWord
  9505. primCmpInt
  9506. primEqInt
  9507. primEqAddr
  9508. plusAddr
  9509. addrToInt
  9510. nullAddr
  9511. primRationalToDouble
  9512. primRationalToFloat
  9513. floatToDouble
  9514. doubleToFloat
  9515. primIntToDouble
  9516. primIntToFloat
  9517. wordToInt
  9518. intToWord
  9519. primCharToInt
  9520. primIntToChar
  9521. primDoubleEncode
  9522. primDoubleDecode
  9523. primDoubleMaxExp
  9524. primDoubleMinExp
  9525. primDoubleDigits
  9526. primDoubleRadix
  9527. primDoubleToInt
  9528. primSqrtDouble
  9529. primLogDouble
  9530. primExpDouble
  9531. primAtanDouble
  9532. primAcosDouble
  9533. primAsinDouble
  9534. primTanDouble
  9535. primCosDouble
  9536. primSinDouble
  9537. primFloatEncode
  9538. primFloatDecode
  9539. primFloatMaxExp
  9540. primFloatMinExp
  9541. primFloatDigits
  9542. primFloatRadix
  9543. primFloatToInt
  9544. primSqrtFloat
  9545. primLogFloat
  9546. primExpFloat
  9547. primAtanFloat
  9548. primAcosFloat
  9549. primAsinFloat
  9550. primTanFloat
  9551. primCosFloat
  9552. primSinFloat
  9553. primNegDouble
  9554. primDivDouble
  9555. primMulDouble
  9556. primMinusDouble
  9557. primPlusDouble
  9558. primNegFloat
  9559. primDivFloat
  9560. primMulFloat
  9561. primMinusFloat
  9562. primPlusFloat
  9563. primTestWord
  9564. primBitWord
  9565. primShiftWord
  9566. primComplementWord
  9567. primXorWord
  9568. primOrWord
  9569. primAndWord
  9570. primQrmWord
  9571. primEvenWord
  9572. primRemWord
  9573. primModWord
  9574. primQuotWord
  9575. primDivWord
  9576. primMulWord
  9577. primNegateWord
  9578. primMinusWord
  9579. primPlusWord
  9580. primMaxWord
  9581. primTestInt
  9582. primBitInt
  9583. primShiftInt
  9584. primComplementInt
  9585. primXorInt
  9586. primOrInt
  9587. primAndInt
  9588. primQrmInt
  9589. primEvenInt
  9590. primNegInt
  9591. primRemInt
  9592. primModInt
  9593. primQuotInt
  9594. primDivInt
  9595. primMulInt
  9596. primMinusInt
  9597. primPlusInt
  9598. primMaxInt
  9599. primMinInt
  9600. enFrTo
  9601. enFrTh
  9602. enFrom
  9603. enFrEn
  9604. enToEn
  9605. enInRng
  9606. enIndex
  9607. enRange
  9608. conCmp
  9609. trace
  9610. error
  9611. gcBhole
  9612. catchError
  9613. fatbar
  9614. IOArrEq
  9615. IOBounds
  9616. IOFreeze
  9617. IOWriteArr
  9618. IOReadArr
  9619. IONewArr
  9620. STArrEq
  9621. STBounds
  9622. STFreeze
  9623. STWriteArr
  9624. STReadArr
  9625. STNewArr
  9626. outBounds
  9627. eltUndef
  9628. primElems
  9629. primBounds
  9630. primSubscript
  9631. primAmap
  9632. primAccumArray
  9633. primAccum
  9634. primUpdate
  9635. primArray
  9636. _undefined_array_element
  9637. _out_of_bounds
  9638. primCmpInteger
  9639. primEqInteger
  9640. primIntegerToDouble
  9641. primIntegerToFloat
  9642. primIntegerToWord
  9643. primWordToInteger
  9644. primIntegerToInt
  9645. primIntToInteger
  9646. primEvenInteger
  9647. primNegInteger
  9648. primQrmInteger
  9649. primMulInteger
  9650. primMinusInteger
  9651. primPlusInteger
  9652. Bignum expected
  9653. print
  9654. _print
  9655. nprint
  9656. _nprint
  9657. lprint
  9658. _lprint
  9659. nlprint
  9660. _nlprint
  9661. sprint
  9662. _sprint
  9663. nsprint
  9664. _nsprint
  9665. primShowsDouble
  9666. primShowsFloat
  9667. primShowsInteger
  9668. primShowsAddr
  9669. primShowsInt
  9670. {array}
  9671. {mutable variable}
  9672. {record}
  9673. {handle}
  9674. Error in graph
  9675. ] ++ 
  9676. " ++ 
  9677. " ++ [
  9678.  error: 
  9679. passIO
  9680. _pass
  9681. hreader
  9682. _hreader
  9683. hugsIORun
  9684. hugsPutStr
  9685. eqStableName
  9686. hashStableName
  9687. deRefStableName
  9688. makeStableName
  9689. finalizerWaiting
  9690. runFinalizer
  9691. finalize
  9692. replaceFinalizer
  9693. deRefWeak
  9694. mkWeak
  9695. weakPtrEq
  9696. derefWeakPtr
  9697. makeWeakPtr
  9698. eqForeignObj
  9699. writeForeignObj
  9700. makeForeignObj
  9701. freeStablePtr
  9702. deRefStablePtr
  9703. makeStablePtr
  9704. eqRef
  9705. setRef
  9706. getRef
  9707. newRef
  9708. ioeGetFileName
  9709. ioeGetHandle
  9710. hugsIsWriteErr
  9711. isPermissionError
  9712. isIllegalOperation
  9713. isEOFError
  9714. isFullError
  9715. isAlreadyInUseError
  9716. isDoesNotExistError
  9717. isAlreadyExistsError
  9718. appendBinaryFile
  9719. writeBinaryFile
  9720. readBinaryFile
  9721. appendFile
  9722. writeFile
  9723. readFile
  9724. primEqHandle
  9725. hIsReadable
  9726. hIsWritable
  9727. hIsClosed
  9728. hIsOpen
  9729. hSetPosn
  9730. hGetPosn
  9731. hClose
  9732. hFlush
  9733. hIsEOF
  9734. stderr
  9735. stdout
  9736. stdin
  9737. openBinaryFile
  9738. openFile
  9739. getContents
  9740. hGetContents
  9741. hPutStr
  9742. hPutChar
  9743. hGetChar
  9744. hugsIsNameErr
  9745. hugsIsSearchErr
  9746. isUserError
  9747. userError
  9748. primShowIOError
  9749. putStr
  9750. putChar
  9751. getChar
  9752. getCh
  9753. primArgv
  9754. primArgc
  9755. getRandomSeed
  9756. primSystem
  9757. getEnv
  9758. primGC
  9759. rbindIO
  9760. lbindIO
  9761. runitIO
  9762. lunitIO
  9763. User error: 
  9764. Illegal file name: 
  9765. File or variable not found: 
  9766. Cannot write to file: 
  9767. Illegal operation
  9768. Unrecognised I/O exception!
  9769. getRandomSeed is not implemented on this architecture
  9770. primDeRefWeak
  9771. primReplaceFinalizer
  9772. primFinalize
  9773. STHash
  9774. STEql
  9775. STMutVarEq
  9776. STDeref
  9777. STAssign
  9778. STNew
  9779. STInter
  9780. STStrictBind
  9781. STLazyBind
  9782. STReturn
  9783. STFix
  9784. primSTtoIO
  9785. runST
  9786. type error in assign
  9787. type error in deref
  9788. Stable pointer table full
  9789. runIO: uncaught error
  9790. runIO: unbalanced stack (%d)
  9791. runIO: bad return value
  9792. _FATBAR
  9793. _FAIL
  9794. _concmp
  9795. _range
  9796. _index
  9797. _inRange
  9798. _ToEnum
  9799. _FrEnum
  9800. _From
  9801. _FromTo
  9802. _FromThen
  9803. _Gc Black Hole
  9804. _indirect
  9805. _recExt
  9806. _recBrk
  9807. _recSel
  9808. _recShw
  9809. _recEq
  9810. _addEv
  9811. negate
  9812. enumFrom
  9813. enumFromThen
  9814. enumFromTo
  9815. enumFromThenTo
  9816. otherwise
  9817. undefined
  9818. showField
  9819. showParen
  9820. readField
  9821. readParen
  9822. rangeSize
  9823. primCompAux
  9824. primPmInt
  9825. primPmInteger
  9826. primPmFlt
  9827. primPmNpk
  9828. primPmSub
  9829. rationalToFloat
  9830. floatToRational
  9831. doubleToRational
  9832. doubleToRatio
  9833. intToRatio
  9834. translate: monad comps
  9835. translate
  9836. match fails
  9837. guard fails
  9838. refutePat
  9839. matchPat
  9840. remPat1
  9841. pmcTerm
  9842. emptyMatch
  9843. isNumDiscr
  9844. discrArity
  9845. eqNumDiscr
  9846. liftVar
  9847. preComp
  9848. Compiling
  9849. compileGlobalFunction
  9850. Edit> 
  9851. %d %s
  9852. Cheat sheet for edit mode hack
  9853.     escape    Show history buffer
  9854.     digit    Select history line
  9855.     space    Select most recent
  9856.     return    Back to input mode
  9857.     q         Revert to input mode
  9858.     h         Back one character
  9859.     j         Next history line
  9860.     k         Previous history line
  9861.     l         Forward one character
  9862.     ^         Start of line
  9863.     $         End of line
  9864.     D         Delete to end of line
  9865.     r         Change current character
  9866. ?:\system\apps\hugs
  9867. {Hugs}
  9868. String storage space exhausted
  9869. gcCStack
  9870. Unexpected signal
  9871. Hugs is not configured to use an editor
  9872. Warning: Editor terminated abnormally
  9873. initModule
  9874. This version of Hugs does not support GreenCard version %d
  9875. Unable to load GreenCard primitives
  9876. __   __ __  __  ____   ___      _________________________________________
  9877. ||   || ||  || ||  || ||__      Hugs 98: Based on the Haskell 98 standard
  9878. ||___|| ||__|| ||__||  __||     Copyright (c) 1994-1999
  9879. ||---||         ___||           World Wide Web: http://haskell.org/hugs
  9880. ||   ||                         Report bugs to: hugs-bugs@haskell.org
  9881. February 2000 
  9882. ||   || Version: %s _________________________________________
  9883. [Leaving Hugs]
  9884. EDITOR
  9885. {Hugs}\lib;{Hugs}\lib\hugs;{Hugs}\lib\exts
  9886. -p"%s> " -r$$
  9887. HUGSFLAGS
  9888. Multiple project filenames on command line
  9889. Prelude.hs
  9890. Prelude not found on current path: "%s"
  9891. Unable to load prelude
  9892. Haskell 98 mode: Restart with command line option -98 to enable extensions
  9893. Hugs mode: Restart with command line option +98 for Haskell 98 mode
  9894. Using project file, ignoring additional filenames
  9895. Unknown toggle `%c'
  9896. %-5s%s
  9897. %-5c%s
  9898. TOGGLES: groups begin with +/- to turn options on/off resp.
  9899. OTHER OPTIONS: (leading + or - makes no difference)
  9900. Set heap size (cannot be changed within Hugs)
  9901. Set prompt string to str
  9902. Set repeat last expression string to str
  9903. Set search path for modules to str
  9904. Use editor setting given by str
  9905. Set constraint cutoff limit
  9906. Current settings: 
  9907.  -c%d
  9908. Search path     : -P
  9909. Project Path    : %s
  9910. Editor setting  : -E
  9911. Haskell 98 (+98)
  9912. Hugs Extensions (-98)
  9913. Compatibility   : %s
  9914. Option string must begin with `+' or `-'
  9915. Haskell 98 compatibility cannot be changed while the interpreter is running
  9916. Cannot change heap size
  9917. Missing integer in option setting "%s"
  9918. Option setting "%s" is too large
  9919. Unwanted characters after option setting "%s"
  9920. :version
  9921. :xplain
  9922. :browse
  9923. :module
  9924. :project
  9925. :info
  9926. :names
  9927. :find
  9928. :quit
  9929. :edit
  9930. :reload
  9931. :load
  9932. :type
  9933. :also
  9934. LIST OF COMMANDS:  Any command may be abbreviated to :c where
  9935. c is the first character in the full name.
  9936. :load <filenames>   load modules from specified files
  9937. :load               clear all files except prelude
  9938. :also <filenames>   read additional modules
  9939. :reload             repeat last load command
  9940. :project <filename> use project file
  9941. :edit <filename>    edit file
  9942. :edit               edit last module
  9943. :module <module>    set module for evaluating expressions
  9944. <expr>              evaluate expression
  9945. :type <expr>        print type of expression
  9946. :?                  display this list of commands
  9947. :set <options>      set command line options
  9948. :set                help on command line options
  9949. :names [pat]        list names currently in scope
  9950. :info <names>       describe named objects
  9951. :browse <modules>   browse names defined in <modules>
  9952. :xplain <context>   explain instance resolution for <context>
  9953. :find <name>        edit module containing definition of name
  9954. :!command           shell escape
  9955. :cd dir             change directory
  9956. :Pwd                print working directory
  9957. :gc                 force garbage collection
  9958. :version            print Hugs version
  9959. :quit               exit Hugs interpreter
  9960. Command not recognised.  
  9961. Type :? for help
  9962. Use multi instance resolution
  9963. Explain instance resolution
  9964. Chase imports while loading modules
  9965. Use "show" to display results
  9966. Allow overlapping instances
  9967. Show kind errors in full
  9968. Always show which modules are loaded
  9969. Print nothing to show progress
  9970. Print dots to show progress
  9971. Warn about errors in literate modules
  9972. Literate modules as default
  9973. Print no. cells recovered after gc
  9974. Terminate evaluation on first error
  9975. Print type after evaluation
  9976. Print no. reductions/cells after eval
  9977. Unable to change to directory "%s"
  9978. Empty project file
  9979. Too many module files (maximum of %d allowed)
  9980. Reading file "%s":
  9981. Recursive import dependency between "%s" and "%s"
  9982. Too many project files
  9983. No project filename specified
  9984. Hugs session for:
  9985.  (project: %s)
  9986. Multiple filenames not permitted
  9987. No name specified
  9988. Multiple names not permitted
  9989. No current definition for name "%s"
  9990. Cannot find module "%s"
  9991. Unresolved overloading
  9992. *** Type       : 
  9993. *** Expression : 
  9994. Cannot find "show" function for:
  9995. *** Of type    : 
  9996. Program execution
  9997. (%lu reduction%s, 
  9998. %lu cell%s
  9999. , %u garbage collection%s
  10000. module %s where
  10001.   -- data constructor
  10002.   -- class member
  10003.   -- selector function
  10004.    -- primitive
  10005. Unknown module %s
  10006. not Sat
  10007. %s.%s
  10008. objToStr
  10009. -- type constructor
  10010.  with kind 
  10011. type 
  10012. data 
  10013. newtype 
  10014. -- constructors:
  10015. -- selectors:
  10016.  = <restricted>
  10017. -- instances:
  10018. -- type class
  10019. -- constructor class
  10020.  with arity 
  10021. class 
  10022.  where
  10023. <unknown type>
  10024. Unknown reference `%s'
  10025. infix
  10026. instance 
  10027. No names selected
  10028. (%d names listed)
  10029. Warning: Shell escape terminated abnormally
  10030. -- Hugs Version %s
  10031. Garbage collection recovered %d cells
  10032. ERROR
  10033.  "%s"
  10034.  (line %d)
  10035. INTERNAL ERROR: %s
  10036. FATAL ERROR: %s
  10037. {Interrupted!}
  10038. :!#$%&*+./<=>?@\^|-~
  10039. (),;[]_`{}
  10040. Unable to open project file "%s"
  10041. Parsing
  10042. Unable to open file "%s"
  10043. \begin{code}
  10044. \begin{code} encountered inside code block
  10045. \end{code}
  10046. \end{code} encountered outside code block
  10047. Program line next to comment
  10048. Empty script - perhaps you forgot the `%c's?
  10049.  !"#$%&'()*+-236?@ABCD
  10050. input
  10051. module definition
  10052. import declaration
  10053. type definition
  10054. data definition
  10055. newtype definition
  10056. needprims decl
  10057. type defn lhs
  10058. data type definition
  10059. primitive defn
  10060. class declaration
  10061. instance declaration
  10062. default declaration
  10063. dependent parameters
  10064. type expression
  10065. anonymous type variables
  10066. extensible records
  10067. fixity decl
  10068. type signature
  10069. declaration
  10070. pattern
  10071. expression
  10072. case expression
  10073. definition
  10074. Syntax error in %s (unexpected %s)
  10075. %s "%s"
  10076. keyword
  10077. end of input
  10078. infixl
  10079. infixr
  10080. infix
  10081. instance
  10082. class
  10083. primitive
  10084. where
  10085. newtype
  10086. deriving
  10087. default
  10088. import
  10089. module
  10090. forall
  10091. comma
  10092. `{', possibly due to bad layout
  10093. `}', possibly due to bad layout
  10094. `;', possibly due to bad layout
  10095. backslash (lambda)
  10096. tilde
  10097. backquote
  10098. selector "#%s"
  10099. implicit parameter "?%s"
  10100. symbol "%s"
  10101. symbol "hiding"
  10102. symbol "qualified"
  10103. symbol "as"
  10104. numeric literal
  10105. character literal
  10106. string literal
  10107. token
  10108. Precedence value must be an integer in the range [%d..%d]
  10109. class expression
  10110. Last generator in do {...} must be an expression
  10111. Illegal left hand side in datatype definition
  10112. Maximum token length (%d) exceeded
  10113. Missing digits in exponent
  10114. Illegal character constant
  10115. Improperly terminated character constant
  10116. Improperly terminated string
  10117. Non ISO character `\%d' in constant
  10118. Illegal use of `\&' in character constant
  10119. Illegal escape sequence
  10120. Illegal use of gap in character constant
  10121. Illegal character escape sequence "\%s"
  10122. Missing `\' terminating string literal gap
  10123. @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_
  10124. Unrecognised escape sequence `\^%c'
  10125. Empty octal character escape
  10126. Octal character escape out of range
  10127. Empty hexadecimal character escape
  10128. Hexadecimal character escape out of range
  10129. Decimal character escape out of range
  10130. a closing quote, '"', was expected
  10131. Too many levels of program nesting
  10132. Unterminated nested comment {- ...
  10133. Misplaced `}'
  10134. Unrecognised character `\%d' in column %d
  10135. Cannot use %s without any previous input
  10136. Parser overflow
  10137. parseInput
  10138. Prelude
  10139. hiding
  10140. qualified
  10141. needPrims_hugs
  10142. bad Label
  10143. Compiled code too complex
  10144. fixAddrs
  10145. build
  10146. Program
  10147. uncaught eval error
  10148. Cannot allocate program memory
  10149. insertField
  10150. showRecRow
  10151. eqRecRow
  10152. dlet {...} in 
  10153. {free!}
  10154. do {...}
  10155. let {...} in 
  10156.  then 
  10157.  else 
  10158. case 
  10159.  of {...}
  10160. let {...}
  10161. ADDPAT
  10162. putExt
  10163. <unknownPredicate>
  10164. forall 
  10165. (bad type)
  10166. abcdefghijklmnopqrstuvwxyz
  10167. (bad kind)
  10168. Illegal type
  10169.  in %s
  10170. Kind error in %s
  10171. *** expression     : 
  10172. *** constructor    : 
  10173. *** kind           : 
  10174. *** does not match : 
  10175. *** because        : %s
  10176. startModule
  10177. Module "%s" already loaded
  10178. Module "%s" not previously loaded
  10179. Entity "%s" is not a %s "%s"
  10180. constructor of type
  10181. member of class
  10182. checkImportEntity2
  10183. checkImportEntity3
  10184. Unknown entity "%s" imported from module "%s"
  10185. Module "%s" recursively imports itself
  10186. importEntity
  10187. Entity "%s" imported from module "%s" already defined in module "%s"
  10188. Tycon "%s" imported from "%s" already defined in module "%s"
  10189. Import of type constructor "%s" clashes with class in module "%s"
  10190. Class "%s" imported from "%s" already defined in module "%s"
  10191. Import of class "%s" clashes with type constructor in module "%s"
  10192. Unknown entity "%s" exported from module "%s"
  10193. Unknown module "%s" exported from module "%s"
  10194. Explicit constructor list given for type synonym "%s" in export list of module "%s"
  10195. Transparent export of restricted type synonym "%s" in export list of module "%s"
  10196. checkExport1
  10197. Explicit export list given for non-class/datatype "%s" in export list of module "%s"
  10198. Repeated definition of type constructor "%s"
  10199. "%s" used as both class and type constructor
  10200. restricted type synonyms
  10201. Repeated type variable "%s" on left hand side
  10202. Recursive type synonym "%s"
  10203. checkTyconDefn
  10204. context
  10205. Variable "%s" in constraint is not locally bound
  10206. Cannot derive instances for types
  10207.  with polymorphic or qualified components
  10208.  with existentially typed components
  10209. Cannot use selectors with existentially typed components
  10210. constructor function
  10211. A newtype constructor cannot have class constraints
  10212. A newtype constructor must have exactly one argument
  10213. Illegal strictess annotation for newtype constructor
  10214. Repeated field name "%s" for constructor "%s"
  10215. Repeated definition for selector "%s"
  10216. Type synonyms "%s" and "%s" are mutually recursive
  10217. Repeated definition of class "%s"
  10218. multiple parameter classes
  10219. Type variable required in class head
  10220. Repeated type variable "%s" in class head
  10221. Functional dependency is trivial
  10222. Trivial dependency for variable "%s"
  10223. Repeated variable "%s" in functional dependency
  10224. class definition
  10225. inheritFundeps - predicate failed to match it's own head!
  10226. tag classes
  10227. Undefined class "%s"
  10228. Wrong number of arguments for class "%s"
  10229. Wrong number of arguments for lacks predicate
  10230. depPredExp
  10231. member type
  10232. class declaration
  10233. Make.%s
  10234. class
  10235. Repeated definition for member function "%s"
  10236. sc%d.%s
  10237. Please use a shorter name for class "%s"
  10238. Class hierarchy for "%s" is not acyclic
  10239. Pattern binding illegal in %s declaration
  10240. No member "%s" in class "%s"
  10241. Too many type variables in %s
  10242. type expression
  10243. Quantifier does not mention type variable "%s"
  10244. Quantified type variable "%s" is not used
  10245. Quantified type variable "%s" is repeated
  10246. type component
  10247. Qualified type variables not allowed
  10248. Undefined type constructor "%s"
  10249. extensible records
  10250. depTypeExp
  10251. Undefined type variable "%s"
  10252. Duplicated quantified variable %s
  10253. Locally quantified variable %s is not used
  10254. Ambiguous type signature in %s
  10255. *** ambiguous type : 
  10256. *** assigned to    : 
  10257. kindConstr1
  10258. polymorphic type
  10259. kindConstr2
  10260. Illegal use of row in 
  10261. Not enough arguments for type synonym "%s"
  10262. constructor application
  10263. kindAtom
  10264. lacks predicate
  10265. iparam predicate
  10266. class constraint
  10267. fixKinds
  10268. synonym definition
  10269. member function type signature
  10270. syntax error in instance head (variable expected)
  10271. repeated type variable "%s" in instance head
  10272. syntax error in instance head (constructor expected)
  10273. Cannot use type synonym in instance head
  10274. instance definition
  10275. Illegal predicate in instance declaration
  10276. Instance is more general than a dependency allows
  10277. *** Instance         : 
  10278. *** For class        : 
  10279. *** Under dependency : 
  10280. Type signature declarations not permitted in instance declaration
  10281. Fixity declarations not permitted in instance declaration
  10282. instance
  10283. Instances are not consistent with dependencies
  10284. *** This instance    : 
  10285. *** Conflicts with   : 
  10286. Overlapping instances for class "%s"
  10287. *** This instance   : 
  10288. *** Overlaps with   : 
  10289. *** Common instance : 
  10290. Unknown class "%s" in derived instance
  10291. initDerInst
  10292. *** Cannot derive 
  10293.  after %d iterations.
  10294. *** This may indicate that the problem is undecidable.  However,
  10295. *** you may still try to increase the cutoff limit using the -c
  10296. *** option and then try again.  (The current setting is -c%d)
  10297. Cannot derive 
  10298.  because predicate 
  10299.  does not hold
  10300. An instance of 
  10301.  is required to derive 
  10302. copyAdj
  10303. derived instance
  10304. Cannot derive instances of class "%s"
  10305. compare
  10306. Can only derive instances of Enum for enumeration types
  10307. enumFromThen
  10308. enumFromTo
  10309. enumFrom
  10310. fromEnum
  10311. toEnum
  10312. inRange
  10313. index
  10314. range
  10315. Can only derive instances of Ix for enumeration or product types
  10316. showsPrec
  10317. readsPrec
  10318. maxBound
  10319. minBound
  10320. Can only derive instances of Bounded for enumeration and product types
  10321. Multiple default declarations are not permitted in
  10322. a single script file.
  10323. default type
  10324. Default types must be instances of the Num class
  10325. primitive definition
  10326. primitive
  10327. pattern
  10328. Illegal pattern syntax
  10329. Second argument in (n+k) pattern must be an integer
  10330. Integer k in (n+k) pattern must be > 0
  10331. Illegal tuple pattern
  10332. Illegal record pattern
  10333. Illegal use of qualified variable in pattern
  10334. Repeated variable "%s" in pattern
  10335. Undefined constructor function "%s"
  10336. "%s" is not a constructor function
  10337. Constructor "%s" must have exactly %d argument%s in pattern
  10338. pattern type annotations
  10339. pattern type
  10340. Illegal syntax in %s type annotation
  10341. Type signature for qualified variable "%s" is not allowed
  10342. FUNBIND
  10343. Equations give different arities for "%s"
  10344. No variables defined in lhs pattern
  10345. getPatVars
  10346. Repeated use of variable "%s" in pattern binding
  10347. "%s" multiply defined
  10348. getAttr
  10349. type declaration
  10350. Missing binding for variable "%s" in type signature
  10351. Repeated type signature for "%s"
  10352. Repeated fixity declaration for operator "%s"
  10353. Cannot find binding for operator "%s" in fixity declaration
  10354. Ambiguous use of unary minus with "
  10355. Ambiguous use of operator "
  10356. " with "
  10357. Undefined variable "%s"
  10358. Undefined qualified variable "%s"
  10359. Dependency analysis
  10360. saveSyntax
  10361. result
  10362. expression
  10363. Illegal `@' in expression
  10364. Illegal `~' in expression
  10365. Illegal `_' in expression
  10366. Illegal application of record
  10367. depExpr
  10368. Constructor "%s" does not have selected fields in 
  10369. depConFlds
  10370. Construction does not define strict field
  10371. Expression : 
  10372. Field      : 
  10373. Empty field list in update
  10374. missing field bindings
  10375. "%s" is not a selector function/field name
  10376. Repeated field name "%s" in field list
  10377. No constructor has all of the fields specified in 
  10378. Repeated label "%s" in record 
  10379. variable
  10380. Repeated definition for %s "%s"
  10381. Definition of %s "%s" clashes with import
  10382. No top level binding of "%s" for restricted synonym "%s"
  10383. Illegal Haskell 98 class constraint in %s
  10384. *** Instance   : 
  10385. *** Constraint : 
  10386. *** Context    : 
  10387. *** Expression : 
  10388. *** Type       : 
  10389. Haskell 98 does not support %s
  10390. identToStr
  10391. identToStr2
  10392. storage space exhausted for internal literal string
  10393. Character string storage space exhausted
  10394. Program code storage space exhausted
  10395. Ext storage space exhausted
  10396. Type constructor storage space exhausted
  10397. findQualTycon
  10398. findQualTycon2
  10399. Name storage space exhausted
  10400. findQualName
  10401. findQualName2
  10402. Unknown primitive reference "%s"
  10403. sfunPos
  10404. %s in pattern
  10405. missing `]'
  10406. extra trailing `\'
  10407. Class storage space exhausted
  10408. Instance storage space exhausted
  10409. Control stack overflow
  10410. Module storage space exhausted
  10411. findModid
  10412. Too many script files in use
  10413. <nofile>
  10414. Prelude.hs
  10415. overwrite
  10416. Weak ptr contains object which isn't heap allocated %d
  10417. bad weak ptr
  10418. Garbage collection fails to reclaim sufficient space
  10419. Too many handles open; cannot open "%s"
  10420. Too many ForeignObjs open
  10421. freeMallocPtr
  10422. derefStablePtr
  10423. Cannot allocate heap storage (%d cells)
  10424. Unable to allocate gc markspace
  10425. Cannot allocate instance tables
  10426. Substitution expanding too quickly
  10427. Too many variables (%d) in type checker
  10428. findBtyvsInt
  10429. expandSyn1
  10430. markType
  10431. Too many quantified type variables
  10432. getKind
  10433. types do not match
  10434. constructor variable kinds do not match
  10435. cannot instantiate Skolem constant
  10436. unification would give infinite type
  10437. kinds do not match
  10438. rows are not compatible
  10439. incompatible constructors
  10440. distinct rows have common tail
  10441. field mismatch
  10442. remover
  10443. Mismatching uses of implicit parameter
  10444. ***  
  10445. Constraints are not consistent with functional dependency
  10446. *** Constraint       : 
  10447. *** And constraint   : 
  10448. *** For class        : 
  10449. *** Break dependency : 
  10450. unification would give infinite kind
  10451. ShowRecRow
  10452. EqRecRow
  10453. qualifyBinding
  10454. *** The type checker has reached the cutoff limit while trying to
  10455. *** determine whether:
  10456. ***     
  10457. *** can be deduced from:
  10458. ***     
  10459. *** This may indicate that the problem is undecidable.  However,
  10460. *** you may still try to increase the cutoff limit using the -c
  10461. *** option and then try again.  (The current setting is -c%d)
  10462. scFind
  10463. scEntail(scFind): 
  10464.  ||- 
  10465. scSat.
  10466. entail: 
  10467. inSat.
  10468. No instance found for 
  10469. inEntails: 
  10470. Multiple satisfiable instances for 
  10471. not Sat
  10472. not Sat.
  10473. all not Sat.
  10474. scSimplify: 
  10475. Simplified!
  10476. Cannot satisfy constraint 
  10477. Type annotation uses variable 
  10478.  where a more specific type 
  10479.  was inferred
  10480. leavePendingBtyvs
  10481. Type annotation uses distinct variables 
  10482.  and 
  10483.  where a single variable was inferred
  10484. leaveSkolVars
  10485. Existentially quantified variable in inferred type
  10486. *** Variable     : 
  10487. *** From pattern : 
  10488. *** Result type  : 
  10489. Existentially quantified variable escapes from pattern 
  10490. Type error in %s
  10491. *** Expression     : 
  10492. *** Term           : 
  10493. *** Type           : 
  10494. *** Does not match : 
  10495. *** Because        : %s
  10496. Cannot justify constraints in %s
  10497. *** Expression    : 
  10498. *** Type          : 
  10499. *** Given context : 
  10500. *** Constraints   : 
  10501. Inferred type is not general enough
  10502. *** Expected type : 
  10503. *** Inferred type : 
  10504. conditional
  10505. case discriminant
  10506. as (@) pattern
  10507. type annotation
  10508. lambda expression
  10509. typeExpr
  10510. application
  10511. typeAp0
  10512. typeAp1
  10513. typeAp2
  10514. Use of 
  10515.  requires at least %d argument%s
  10516. Argument 
  10517.  in pattern 
  10518.  where a variable is required
  10519. typeAp3
  10520. Cannot use pattern binding for 
  10521.  as a component with a qualified type
  10522. Definition requires at least %d parameters on lhs
  10523.  used where a variable or wildcard is required
  10524. case pattern
  10525. case expression
  10526. boolean qualifier
  10527. generator
  10528. final generator
  10529. value construction
  10530. update
  10531. Sorry, record update syntax cannot currently be used for datatypes with polymorphic components
  10532. typeUpdFlds
  10533. Unresolved top-level overloading
  10534. *** Binding             : %s
  10535. *** Inferred type       : 
  10536. *** Outstanding context : 
  10537. Explicit overloaded type for "%s"
  10538.  not permitted in restricted binding
  10539. inferred type
  10540. explicitly typed binding
  10541. addEvidParams
  10542. default_
  10543. Undefined member: 
  10544. default member binding
  10545. typeInstDefn
  10546. scEntail: 
  10547. inEntail: 
  10548. Cannot build superclass instance
  10549. *** Instance            : 
  10550. *** Context supplied    : 
  10551. *** Required superclass : 
  10552. instance member binding
  10553. typeMember1
  10554. Implementation of %s requires extra context
  10555. *** Expected type   : 
  10556. *** Missing context : 
  10557. typeBind
  10558. lhs pattern
  10559. right hand side
  10560. function binding
  10561. result type
  10562. guarded expression
  10563. guard
  10564. genAss
  10565. equalTypes
  10566. Type checking
  10567. Instance%s of 
  10568.  required for definition of 
  10569. typeDefnGroup
  10570. typeSel1
  10571. Mismatch in field types for selector "%s"
  10572. *** Field type     : 
  10573. typeSel2
  10574. EmptyRow
  10575. EmptyRec
  10576. String
  10577. Integer
  10578. Double
  10579. Maybe
  10580. Ordering
  10581. Prelude does not define standard types
  10582. Bounded
  10583. Prelude does not define standard classes
  10584. Integral
  10585. RealFrac
  10586. RealFloat
  10587. Fractional
  10588. Floating
  10589. Prelude does not define numeric classes
  10590. Monad
  10591. Prelude does not define Monad class
  10592. Prelude does not define IO monad constructor
  10593. False
  10594. Nothing
  10595. Right
  10596. Prelude does not define standard constructors
  10597. fromInt
  10598. fromInteger
  10599. fromDouble
  10600. compare
  10601. showsPrec
  10602. readsPrec
  10603. index
  10604. inRange
  10605. range
  10606. minBound
  10607. maxBound
  10608. return
  10609. Prelude does not define standard members
  10610. ESTLIB[100002c3].DLL
  10611. EUSER[100000c1].DLL
  10612. 0X1\1`1d1h1
  10613. 2 2$2(2
  10614. 2H3L3P3T3X3\3
  10615. 54686<6@6<7@7D7H7L7P7T7X7H8L8P8T8X8\8`8d8h8l8
  10616. 9d:h:l:t:x:|:
  10617. < <$<(<t=x=|=
  10618. =$>(>,>0>4>8><>
  10619. 4 4$4(4,4044484
  10620. 5 5$5(5,5L8T8X8\8`8d8h8l8p8t8x8`;h;l;p;t;x;|;
  10621. =@>D>H>L>P>T>\>
  10622. 041<1@1D1H1L1
  10623. 5 5$5(5,505
  10624. 8 8(8
  10625. 9 9$9(9,90949`:h:l:p:t:x:
  10626. ;X;`;
  10627. < <$<(<,<0<
  10628. = =$=(=,=0=
  10629. >,?0?4?8?<?@?
  10630. 4080<0@0H0L0P0
  10631. 1 1$1(1,1
  10632. 1\2`2d2h2l2p2
  10633. 2d3h3l3p3t3x3
  10634. 384<4@4D4H4
  10635. 4\5`5d5h5l5p5
  10636. 5,6064686<6@6
  10637. 7 7$7(7
  10638. 8<9@9D9H9L9P9
  10639. 9l:p:t:x:|:
  10640. :t;x;|;
  10641. =p=t=x=|=
  10642. =`>d>h>l>p>t>x>|>
  10643. 042@2P2@3D3,404,505
  10644. 90:4:8:<:
  10645. ;`;d;h;l;
  10646. < <$<(<d<h<
  10647. >4?8?
  10648. 4(505,6064686x8|8
  10649. 0 0$0(0,0
  10650. 1$1(1,1014181<1
  10651. 1@2D2H2L2P2
  10652. 2 3$3(3,303
  10653. 384<4@4
  10654. 5@6D6H6L6P6T6
  10655. 6P7T7X7\7`7d7
  10656. 7l8p8t8
  10657. 8H9L9P9T9X9
  10658. : :$:(:
  10659. :P;T;X;\;`;
  10660. =P=X=\=
  10661. =D>L>
  10662. ? ?(?,?0?
  10663. 0 1$1(1,1014181<1
  10664. 2 2$2(2,20242
  10665. 2H3L3P3T3X3\3`3d3
  10666. 4 5$5(5,5054585<5@5
  10667. 6<8@8D8H8L8P8T8X8\8`8d8h8l8p8t8x8|8
  10668. 8x9|9
  10669. 9,:0:4:8:<:@:
  10670. ; ;$;(;,;0;4;8;<;@;D;H;L;P;T;X;\;`;d;h;l;p;t;x;|;
  10671. < <$<(<,<0<4<8<<<@<D<H<L<P<T<X<\<`<d<h<l<p<t<x<|<
  10672. t2x2|2
  10673. 2x4|4
  10674. 4T5X5\5`5
  10675. 7 7$7(7,7074787<7@7
  10676. ; ;$;(;,;0;4;8;<;@;D;H;L;P;
  10677. = =$=(=d=h=l=p=t=0>4>8><>D>H>
  10678. >h?l?
  10679. 0 0d0h0
  10680. 5$6(6,6
  10681. : :$:(:,:0:4:8:<:D:H:L:P:
  10682. ; ;$;
  10683. < <$<(<,<0<4<p<t<x<|<
  10684. >4?8?<?@?
  10685. 0 0$0(0,0|0
  10686. 0h1l1p1t1x1|1
  10687. 3x4|4
  10688. 4`6d6h6l6t6x6|6
  10689. 8X9\9`9d9h9l9
  10690. ;T;\;`;
  10691. >d?h?l?p?t?
  10692. 0p1t1x1|1
  10693. 2 2$2(2,2
  10694. 2P3T3X3\3`3d3h3l3
  10695. 4$5(5,5054585<5@5`6d6h6l6p6t6x6|6
  10696. 9x9|9
  10697. ;8<<<@<
  10698. = =$=(=
  10699. ?h?l?p?t?x?
  10700. 0H1L1T1X1\1`1d1h1l1
  10701. 2l2p2t2x24383@3D3H3L3P3T3X3
  10702. 4P5T5\5`5d5h5l5p5t5d6h6l6p6t6x6|6
  10703. 6H7L7P7T7X7\7`7d7
  10704. :(;,;0;4;8;<;T;
  10705. ;0<4<8<<<@<0=8=<=@=D=H=L=
  10706. =X>\>d>h>l>p>t>
  10707. h0l0t0x0|0(1,1014181<1@1
  10708. 1d2h2l2p2t2x2|2
  10709. 6@7D7H7L7P7T7
  10710. <X<\<`<
  10711. =@=D=H=x=|=
  10712. >\>`>d>
  10713. ?L?T?
  10714. 0P0X0
  10715. 2 2$2(2,2<3D3H3L3P3T3
  10716. 4x5|5
  10717. : :$:(:,:0:4:8:<:@:D:H:L:P:T:X:\:`:d:h:l:p:t:x:|:
  10718. ? ?$?
  10719. l2p2t2x2|2
  10720. 2 3$3(3,3034383<3@3D3H3L3P3T3X3\3`3d3h3l3p3t3x3|3
  10721. 4 4$4(4,4044484<4@4D4H4L4P4T4X4\4`4d4h4l4p4t4x4|4
  10722. 9H9L9
  10723. 9 :$:\;`;d;D<H<
  10724. 0X0\0`0d0
  10725. 7 8$8(8,8084888<8@8D8H8L8P8T8X8\8`8d8h8l8p8t8x8|8
  10726. 9 9$9(9,9094989<9@9D9H9L9P9T9X9\9`9d9h9l9p9t9x9|9
  10727. 94;8;<;@;D;x<|<
  10728. = =$=(=,=0=4=8=<=@=D=H=L=P=T=X=\=`=d=h=l=p=t=x=|=
  10729. > >$>(>,>0>4>8><>@>D>H>L>P>T>X>\>`>d>h>l>p>
  10730. 1p3t3
  10731. 4 4$4(4,4044484<4@4D4H4L4P4T4X4\4`4d4h4l4p4t4x4|4
  10732. 5 5$5(5,5054585<5@5D5H5L5P5T5X5\5`5d5h5l5p5t5x5
  10733. ; ;$;(;,;0;4;8;<;@;D;H;L;P;T;X;\;`;d;h;l;p;t;x;|;
  10734. < <$<(<,<0<4<8<<<@<D<H<L<P<T<X<\<`<d<h<l<p<t<x<|<
  10735. >x>|>
  10736. 1\2`2
  10737. 4D8H8
  10738. 0h1l1p1t1x1|1
  10739. 2 2$2(2,2024282
  10740. 2T4X4\4
  10741. 5 5$5(5,5054585<5@5D5H5L5P5T5X5\5`5d5h5l5p5t5x5|5
  10742. 6 6$6(6,6064686<6@6D6H6L6P6T6X6\6`6d6h6l6p6t6x6|6
  10743. 74888
  10744. :l;p;t;
  10745. <<=@=
  10746. ? ?$?(?,?0?4?8?<?@?D?H?L?P?T?X?\?`?d?h?l?p?t?x?|?
  10747. 0 0$0(0,0004080<0@0D0H0L0P0T0X0\0`0d0h0l0p0t0x0|0
  10748. 20343\3$4(4,4044484
  10749. 6d7h7l7p7t7X8\8`8d8
  10750. 9P:T:X:`:d:h:l:
  10751. ; =$=(=,=0=
  10752. ? ?$?(?,?0?4?8?<?@?D?H?L?P?T?X?\?`?d?h?l?p?t?x?|?
  10753. 0 0$0(0,0004080<0@0D0H0L0P0T0X0\0`0d0h0l0p0t0x0|0
  10754. 0(2,2024282<2@2D2
  10755. 5,606
  10756. 70747
  10757. :l:p:
  10758. ;`;d;h;l;
  10759. ;(<\>`>d>h>l>p>
  10760. ?P?T?X?
  10761. 80<0@0D0
  10762. 1l2p2t2x2|2
  10763. 2\4`4d4h4l4p4t4x4|4
  10764. 4$5(5
  10765. 9 9$9(9,9094989<9@9D9H9L9P9T9X9\9`9d9h9l9
  10766. =h>l>p>t>x>|>
  10767. D0H0L0P0T0
  10768. 0x1|1
  10769. 183<3@3D3H3L3P3T3X3\3`3d3
  10770. 5(6,606
  10771. 8 8$8T8X8
  10772. 9@9p<t<x<|<
  10773. =(>,>0>4>
  10774. 0D2H2L2P2T2X2\2`2
  10775. 3`6d6h6l6p6t6x6|6
  10776. < =$=(=,=0=`=
  10777. > >$>(>,>0>4>8><>@>D>H>L>P>T>X>\>`>d>h>l>|?
  10778. 04181<1@1D1H1(2,2024282<2@2p2
  10779. 303t3x3
  10780. 4@5\5h5
  10781. 6H6\6
  10782. 6x9|9
  10783. 90:4:8:<:@:D:H:
  10784. ;h<l<p<t<x<|<
  10785. ? ?$?(?,?
  10786. l1p1t1x1|1
  10787. 2d3h3l3p3t3x3|3
  10788. 4d6h6t6x6
  10789. 7 7$7(7,7074787<7@7D7H7L7P7T7X7\7`7d7h7l7p7t7x7|7
  10790. 8 8$8(8,8084888<8@8D8H8L8P8T8X8\8`8d8h8l8p8t8x8|8
  10791. 9 9$9(9,9094989<9@9D9H9L9P9T9X9\9`9d9h9l9p9t9x9|9
  10792. : :$:(:,:0:4:8:<:@:D:H:L:P:T:X:\:`:d:h:l:p:t:x:|:
  10793. ; ;$;(;,;0;4;8;<;@;D;H;L;P;T;X;\;`;d;h;l;p;t;x;|;
  10794. < <$<(<,<0<4<8<<<@<D<H<L<P<T<X<\<`<d<h<l<p<t<x<|<
  10795. = =$=(=,=0=4=8=<=@=D=H=L=P=T=X=\=`=d=h=l=p=t=x=|=
  10796. > >$>(>,>0>4>8><>@>D>H>L>P>T>X>\>`>d>h>l>p>t>
  10797. 4282<2@2D2H2L2P2T2X2\2`2d2h2`7d7h7l7p7t7
  10798. ;p?t?x?|?
  10799. d3h3l3p3t3x3|3
  10800. 7 <$<(<
  10801. l1p1t1x1
  10802. 5 5$5(5,5054585<5@5D5H5L5T5X5\5`5d5l5p5t5
  10803. 6<7@7D7|7
  10804. 8 8$8(8,8084888<8@8D8H8L8P8T8X8\8`8d8h8l8p8t8x8|8
  10805. 9 9$9(9,9094989<9@9D9H9L9P9T9X9\9`9d9h9l9p9t9x9|9
  10806. : :$:(:,:0:4:8:<:@:D:H:L:P:T:X:\:`:d:h:l:p:t:x:|:
  10807. ; ;$;(;,;0;4;8;<;@;D;H;L;P;T;X;\;`;d;h;l;p;t;x;|;
  10808. < <$<(<,<0<4<8<<<@<D<H<L<P<T<X<\<`<d<h<l<p<t<x<|<
  10809. 0 0$0(0,0004080<0@0D0H0L0P0T0X0\0`0d0h0l0p0t0x0|0
  10810. 1h1l1
  10811. 1$2(2
  10812. 2D3H3L3P3
  10813. 3H4L4P4T4X4
  10814. 5<9@9D9H9L9P9T9
  10815. :l;p;
  10816. ? ?$?(?
  10817. L0P0T0X0
  10818. 3 5$5(5,505
  10819. 888<8
  10820. 9t=x=|=
  10821. 6$6(6,60646<6@6H6L6P6T6X6\6`6X7\7d7h7p7t7x7
  10822. 7 8`8
  10823. 849X9\9`9d9h9,=0=4=8=<=@=D=H=L=P=T=X=\=`=d=h=l=p=t=x=|=
  10824. > >$>(>,>0>4>8><>@>D>H>L>P>T>X>\>`>d>h>l>p>t>x>|>
  10825. 1 1L1P1
  10826. 14282p2t2
  10827. 3x3|3
  10828. 3H4L4P4T4X4\4`4d4h4l4p4t4x4|4
  10829. 5 5$5(5,5t5x5|5
  10830. 5@6D6H6
  10831. 6,70747
  10832. 90:4:
  10833. ; ;$;(;,;0;4;8;<;@;D;H;L;P;T;X;\;`;d;h;l;p;t;x;|;
  10834. < <$<(<,<0<4<8<<<@<D<H<L<P<T<X<\<`<d<h<l<p<t<x<|<
  10835. >X?\?`?d?h?
  10836. 0 0$0(0,10141
  10837. 2 2$2(2,2024282<2@2D2H2L2P2T2X2\2`2d2h2l2p2t2x2|2
  10838. 3 3$3(3,3034383<3@3D3H3L3P3T3X3\3`3d3h3l3p3t3x3|3
  10839. 3P7T7X7\7`7d7h7
  10840. ;d<h<l<p<t<$=(=,=0=4=
  10841. =<>@>D>H>
  10842. 1(3,3034383
  10843. 4 4$4
  10844. :X>\>`>h>l>p>t>
  10845. 0 1<1@1
  10846. 1`3h3l3p3t3x3|3
  10847. 3P4T4X4\4`4d4h4l4p4t4x4|4
  10848. 5 5$5(5,5054585<5@5D5H5L5P5T5X5\5`5d5h5l5p5t5x5|5
  10849. 6 6$6
  10850. >@?D?H?L?
  10851. 3h4l4
  10852. 8(9,9(:,:0:
  10853. < <$<(<,<0<4<8<<<@<D<H<L<P<T<X<\<`<d<h<l<p<t<x<|<
  10854. = =$=(=,=0=4=8=<=@=D=H=L=P=T=X=\=`=d=h=l=p=t=x=|=
  10855. 2 2$2(2,2024282<2|2
  10856. 2L3P3L4P4T4X4\4
  10857. 5(5,5@5`5|5
  10858. 5t6x6|6
  10859. 9 9$9(9,9094989<9@9D9
  10860. :t:x:
  10861. ;t;x;|;
  10862. <d?h?l?p?t?x?|?
  10863. 283<3@3l4p4t4x4
  10864. :l;p;t;
  10865. = =$=(=,=0=4=8=<=
  10866. =d>h>l>t>`?d?h?l?
  10867. $0(0,0004080<0(3,3034383
  10868. 7`9d9h9l9p9t9x9|9
  10869. 9x:|:
  10870. :0;4;8;
  10871. =4>8>
  10872. 0h1l1p1
  10873. 3 3$3(3,30343
  10874. 9 9x:|:
  10875. =$>(>X?\?`?d?
  10876. D2H2L2
  10877. 8X9\9$;(;
  10878. ;@=D=H=P=
  10879. =H?L?P?T?X?
  10880. 3x4|4
  10881. 4l5p5t5x5
  10882. 6 6$6(6,6064686<6@6D6H6L6P6T6X6\6`6d6h6l6p6t6x6|6
  10883. 7T8X8
  10884. > >$>(>,>0>4>8><>@>D>H>L>P>T>X>\>`>d>h>l>p>t>x>|>
  10885. T1X1\1`1d1h1l1p1t1x1|1
  10886. 5(6,6
  10887. ;\<`<d<h<
  10888. 3 3$3(3,303
  10889. 4 4$4(4,4
  10890. 7l:p:x:|:
  10891. <0L0P0T0X0
  10892. 1L2P2T2X3\3`3d3
  10893. 7 7(7,70747D9H9L9P9T9
  10894. 94:8:<:`;d;h;p;@<H<L<P<$>,>0>4>8><>@>D>H>L>P>T>
  10895. 4L5P5
  10896. 8 8$8(8,8
  10897. = =P>T>X>\>`>T?X?\?`?d?
  10898. 0040,3034383<3@3D3H3\5`5d5h5l5p5t5x5
  10899. ;<>@>D>
  10900. 5D6H6L6P6
  10901. 6D8H8L8P8T8X8\8`8d8h8
  10902. 8d9h9l9
  10903. 9p:t:x:
  10904. ; ;$;(;,;0;4;8;<;@;D;H;L;P;T;X;\;`;d;h;l;p;t;x;|;
  10905. < <$<(<,<0<4<8<<<@<D<H<L<P<T<X<\<`<d<h<
  10906. >$?(?,?0?4?8?
  10907. 1L2P2
  10908. 4l5p5t5x5L6P6T6
  10909. 6L9P9T9X9\9`9
  10910. : :$:(:,:0:4:8:<:@:D:H:L:P:T:X:\:`:d:h:l:p:t:x:|:
  10911. ; ;$;(;,;0;4;8;<;@;D;H;L;P;T;X;\;`;d;h;l;p;t;x;|;
  10912. ;p=t=x=
  10913. 44888<8@8D8
  10914. ;P<T<X<\<
  10915. >D>H>h>
  10916. D0H0L0P0T0
  10917. 2<3@3
  10918. 3T5X5\5`5
  10919. 6 6$6(6,6064686<6@6D6H6L6P6T6X6\6`6d6h6l6p6t6x6|6
  10920. 7 7$7(7,7074787<7@7D7H7L7P7T7X7\7`7d7h7l7p7t7x7|7
  10921. 7<;@;D;H;L;P;T;X;\;
  10922. 4h5l5p5
  10923. 9(:,:0:4:8:<:
  10924. :T=X=\=`=h=l=p=t=
  10925. H0L0P0T0\0`0
  10926. 8x9|9
  10927. :X;\;
  10928. =T?X?\?`?d?h?l?p?t?x?|?
  10929. T1X1\1`1d1h1l1
  10930. 5 5$5h5p5
  10931. 7 7$7(7,7
  10932. 8d8h8p9t9x9|9
  10933. :H;L;
  10934. $0(0,0D1H1L1P1
  10935. 2l3p3t384<4d4
  10936. 7x7|7
  10937. 9<:@:D:H:
  10938. <l<p<
  10939. = =$=0>4>8><>@>D>H>4?8?<?@?D?H?L?P?T?X?\?`?d?h?
  10940. 1d1h1
  10941. 1 2$2(2,2
  10942. 94:8:<:
  10943. =l?p?t?x?|?
  10944. 2L3P3
  10945. 384p4
  10946. 5,606`6
  10947. 7d7h7
  10948. 7@8D8
  10949. 8D9H9
  10950. 9,:0:4:
  10951. ; ;x;|;
  10952. <L<P<
  10953. =<>@>D>
  10954. 0,000L0P0
  10955. 0@2D2H2L2P2T2X2\2`2d2h2l2p2t2x2|2
  10956. <$<(<,<
  10957. =D>H>
  10958. h0l0p0
  10959. 3L4P4
  10960. 5x6|6
  10961. 7p7t7x7|7
  10962. 8<8H9L9P9
  10963. :p;t;
  10964. <t=x=
  10965. `0d0h0X1\1`1
  10966. 1T3X3
  10967. 4D5H5L5P5
  10968. 5@7D7
  10969. 9`:d:
  10970. < <$<(<,<
  10971. $1(1014181@1D1H1
  10972. 4 4$484
  10973. 5$7(7,70747
  10974. >(?,?0?
  10975. 0\1$2(20242$3(3,303
  10976. 6 6$6(6,6064686<6
  10977. 60:4:8:
  10978. <h=l=p=
  10979. >8?<?@?
  10980. p1t1x1|1
  10981. 1@2D2H2
  10982. 2\3`3\4`4d4h4l4p4
  10983. 40545
  10984. 5L6P6
  10985. 6\7`7d7h7
  10986. 788<8@8
  10987. 8L9P9
  10988. 94:8:
  10989. :$;L;P;T;
  10990. >p?t?x?
  10991. ,1014181<1@1
  10992. 4l5p5
  10993. ; ;$;(;,;0;
  10994. =<?@?D?H?L?P?
  10995. $0(0,000t1x1|1
  10996. 1l2p2t2
  10997. 5t7x7|7
  10998. 7p8t8x8
  10999. ;\<`<d<
  11000. <p>t>x>
  11001. >D?H?L?P?
  11002. 384<4
  11003. 5d6h6l6p6t6
  11004. 7 7$7(7,7074787<7@7D7H7L7P7T7X7\7`7d7h7l7p7t7x7|7
  11005. 8 8$8(8,8084888<8@8D8H8L8P8T8X8\8`8d8h8l8
  11006. 6 6$6
  11007. :0=4=8=<=@=H=L=P=T=p=
  11008. 0H4L4P4T4X4\4`4d4h4l4p4
  11009. 7\8`8d8h8
  11010. 084<4@4D4H4L4P4T4X4\4`4`6d6h6l6p6t6x6
  11011. 8 8$8(8,8084888t:x:|:
  11012. < <$<
  11013. <`=d=h=
  11014. \0`0d0h0p0t0
  11015. 3 5$5,5
  11016. :,=0=4=8=<=@=D=H=L=P=T=X=\=`=d=
  11017. 0H0`2d2h2l2p2
  11018. 3p4t4
  11019. 6X7\7
  11020. ;<>@>D>H>L>P>T>X>\>`>d>h>l>p>
  11021. 3l5p5t5x5|5
  11022. 5T9X9\9`9d9h9l9p9t9x9
  11023. > >$>(>,>0>4>8><>@>D>H>L>P>T>X>\>`>d>h>l>p>t>|>
  11024. d2h2l2p2t2x2|2
  11025. 7 7$7(7,7074787<7@7D7H7L7P7T7X7\7`7d7h7l7p7t7x7|7
  11026. 8$808<8H8T8`8l8x8
  11027. 9 9,989D9P9\9h9t9
  11028. :(:4:@:L:X:d:p:|:
  11029. ;$;0;<;H;T;`;l;x;
  11030. 0 0$0,00080<0D0H0P0T0\0`0h0l0t0x0
  11031. 1 1(1,14181@1D1L1P1X1\1d1h1p1t1|1
  11032. 2$2(20242<2@2H2L2T2X2`2d2l2p2x2|2
  11033. 3 3$3,30383<3D3H3P3T3\3`3h3l3t3x3
  11034. 4 4(4,44484@4D4L4P4X4\4d4h4p4t4|4
  11035. 5$5(50545<5@5H5L5T5X5`5d5l5p5x5|5
  11036. 6$6,60686<6D6H6P6T6\6`6h6l6t6x6
  11037. 7 7(787<7H7P7T7\7`7h7l7t7x7
  11038. 8 8(8,84888@8D8L8P8X8\8d8h8p8t8|8
  11039. 9 9(9,94989@9D9L9P9X9\9d9h9p9t9|9
  11040. :$:(:0:4:<:@:H:L:T:X:`:d:l:p:x:|:
  11041. ; ;$;,;0;8;<;D;H;P;T;\;`;h;l;t;x;
  11042. < <(<,<4<8<@<D<L<P<X<\<d<t<x<
  11043. =$=4=8=D=H=d=h=l=
  11044. > >(>0>8>@>H>P>X>`>h>p>x>
  11045. ?(?,?8?<?H?L?X?\?h?l?x?|?
  11046. 0$0,040<0D0L0T0\0d0l0t0|0
  11047. 1$1,141<1D1L1\1
  11048.