hellerve/dotfiles
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added cabal and vim dir

Browse Source
This commit is contained in:
hellerve
2015-04-05 17:47:08 +02:00
parent 1e73d5652c
commit ae5a30a4a4
2440 changed files with 40465 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

12
cabal/share/x86_64-osx-ghc-7.10.1/HUnit-1.2.5.2/README Normal file
View File

@@ -0,0 +1,12 @@
HUnit is a unit testing framework for Haskell, inspired by the JUnit
tool for Java. HUnit is free software; see its "License" file for
details. HUnit is available at <http://hunit.sourceforge.net>.
HUnit 1.1.1 consists of a number of files. Besides Haskell source files
in Test/HUnit (whose names end in ".hs" or ".lhs"), these files include:
* README -- this file
* doc/Guide.html -- user's guide, in HTML format
* LICENSE -- license for use of HUnit
See the user's guide for more information.

539
cabal/share/x86_64-osx-ghc-7.10.1/HUnit-1.2.5.2/doc/Guide.html Normal file
View File

@@ -0,0 +1,539 @@
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
xsi:schemaLocation="http://www.w3.org/MarkUp/SCHEMA/xhtml11.xsd" xml:lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8"/>
<meta name="Author" content="Dean Herington"/>
<meta name="KeyWords" content="HUnit, unit testing, test-first development, Haskell, JUnit"/>
<title>HUnit 1.0 User's Guide</title>
</head>
<body>
<h1>HUnit 1.2 User's Guide</h1>
<p>HUnit is a unit testing framework for Haskell, inspired by the JUnit tool for Java. This
guide describes how to use HUnit, assuming you are familiar with Haskell, though not
necessarily with JUnit. You can obtain HUnit, including this guide, at <a
href="http://code.haskell.org/HUnit">http://code.haskell.org/HUnit</a>.</p>
<h2>Introduction</h2>
<p>A test-centered methodology for software development is most effective when tests are
easy to create, change, and execute. The <a href="http://www.junit.org">JUnit</a> tool
pioneered support for test-first development in <a href="http://java.sun.com">Java</a>.
HUnit is an adaptation of JUnit to Haskell, a general-purpose, purely functional
programming language. (To learn more about Haskell, see <a href="http://www.haskell.org"
>http://www.haskell.org</a>.)</p>
<p>With HUnit, as with JUnit, you can easily create tests, name them, group them into
suites, and execute them, with the framework checking the results automatically. Test
specification in HUnit is even more concise and flexible than in JUnit, thanks to the
nature of the Haskell language. HUnit currently includes only a text-based test
controller, but the framework is designed for easy extension. (Would anyone care to
write a graphical test controller for HUnit?)</p>
<p>The next section helps you get started using HUnit in simple ways. Subsequent sections
give details on <a href="#WritingTests">writing tests</a> and <a href="#RunningTests"
>running tests</a>. The document concludes with a section describing HUnit's <a
href="#ConstituentFiles">constituent files</a> and a section giving <a
href="#References">references</a> to further information.</p>
<h2 id="GettingStarted">Getting Started</h2>
<p>In the Haskell module where your tests will reside, import module <tt>Test.HUnit</tt>:</p>
<pre>
import Test.HUnit
</pre>
<p>Define test cases as appropriate:</p>
<pre>
test1 = TestCase (assertEqual "for (foo 3)," (1,2) (foo 3))
test2 = TestCase (do (x,y) &lt;- partA 3
assertEqual "for the first result of partA," 5 x
b &lt;- partB y
assertBool ("(partB " ++ show y ++ ") failed") b)
</pre>
<p>Name the test cases and group them together:</p>
<pre>
tests = TestList [TestLabel "test1" test1, TestLabel "test2" test2]
</pre>
<p>Run the tests as a group. At a Haskell interpreter prompt, apply the function
<tt>runTestTT</tt> to the collected tests. (The "<tt>TT</tt>" suggests
<strong>T</strong>ext orientation with output to the <strong>T</strong>erminal.)</p>
<pre>
> runTestTT tests
Cases: 2 Tried: 2 Errors: 0 Failures: 0
>
</pre>
<p>If the tests are proving their worth, you might see:</p>
<pre>
> runTestTT tests
### Failure in: 0:test1
for (foo 3),
expected: (1,2)
but got: (1,3)
Cases: 2 Tried: 2 Errors: 0 Failures: 1
>
</pre>
<p>Isn't that easy?</p>
<p>You can specify tests even more succinctly using operators and overloaded functions that
HUnit provides:</p>
<pre>
tests = test [ "test1" ~: "(foo 3)" ~: (1,2) ~=? (foo 3),
"test2" ~: do (x, y) &lt;- partA 3
assertEqual "for the first result of partA," 5 x
partB y @? "(partB " ++ show y ++ ") failed" ]
</pre>
<p>Assuming the same test failures as before, you would see:</p>
<pre>
> runTestTT tests
### Failure in: 0:test1:(foo 3)
expected: (1,2)
but got: (1,3)
Cases: 2 Tried: 2 Errors: 0 Failures: 1
>
</pre>
<h2 id="WritingTests">Writing Tests</h2>
<p>Tests are specified compositionally. <a href="#Assertions">Assertions</a> are combined to
make a <a href="#TestCase">test case</a>, and test cases are combined into <a
href="#Tests">tests</a>. HUnit also provides <a href="#AdvancedFeatures">advanced
features</a> for more convenient test specification.</p>
<h3 id="Assertions">Assertions</h3>
<p>The basic building block of a test is an <b>assertion</b>.</p>
<pre>
type Assertion = IO ()
</pre>
<p>An assertion is an <tt>IO</tt> computation that always produces a void result. Why is an
assertion an <tt>IO</tt> computation? So that programs with real-world side effects can
be tested. How does an assertion assert anything if it produces no useful result? The
answer is that an assertion can signal failure by calling <tt>assertFailure</tt>.</p>
<pre>
assertFailure :: String -> Assertion
assertFailure msg = ioError (userError ("HUnit:" ++ msg))
</pre>
<p><tt>(assertFailure msg)</tt> raises an exception. The string argument identifies the
failure. The failure message is prefixed by "<tt>HUnit:</tt>" to mark it as an HUnit
assertion failure message. The HUnit test framework interprets such an exception as
indicating failure of the test whose execution raised the exception. (Note: The details
concerning the implementation of <tt>assertFailure</tt> are subject to change and should
not be relied upon.)</p>
<p><tt>assertFailure</tt> can be used directly, but it is much more common to use it
indirectly through other assertion functions that conditionally assert failure.</p>
<pre>
assertBool :: String -> Bool -> Assertion
assertBool msg b = unless b (assertFailure msg)
assertString :: String -> Assertion
assertString s = unless (null s) (assertFailure s)
assertEqual :: (Eq a, Show a) => String -> a -> a -> Assertion
assertEqual preface expected actual =
unless (actual == expected) (assertFailure msg)
where msg = (if null preface then "" else preface ++ "\n") ++
"expected: " ++ show expected ++ "\n but got: " ++ show actual
</pre>
<p>With <tt>assertBool</tt> you give the assertion condition and failure message separately.
With <tt>assertString</tt> the two are combined. With <tt>assertEqual</tt> you provide a
"preface", an expected value, and an actual value; the failure message shows the two
unequal values and is prefixed by the preface. Additional ways to create assertions are
described later under <a href="#AdvancedFeatures">Advanced Features</a>.</p>
<p>Since assertions are <tt>IO</tt> computations, they may be combined--along with other
<tt>IO</tt> computations--using <tt>(>>=)</tt>, <tt>(>>)</tt>, and the <tt>do</tt>
notation. As long as its result is of type <tt>(IO ())</tt>, such a combination
constitutes a single, collective assertion, incorporating any number of constituent
assertions. The important features of such a collective assertion are that it fails if
any of its constituent assertions is executed and fails, and that the first constituent
assertion to fail terminates execution of the collective assertion. Such behavior is
essential to specifying a test case.</p>
<h3 id="TestCase">Test Case</h3>
<p>A <b>test case</b> is the unit of test execution. That is, distinct test cases are
executed independently. The failure of one is independent of the failure of any other.</p>
<p>A test case consists of a single, possibly collective, assertion. The possibly multiple
constituent assertions in a test case's collective assertion are <b>not</b> independent.
Their interdependence may be crucial to specifying correct operation for a test. A test
case may involve a series of steps, each concluding in an assertion, where each step
must succeed in order for the test case to continue. As another example, a test may
require some "set up" to be performed that must be undone ("torn down" in JUnit
parlance) once the test is complete. In this case, you could use Haskell's
<tt>IO.bracket</tt> function to achieve the desired effect.</p>
<p>You can make a test case from an assertion by applying the <tt>TestCase</tt> constructor.
For example, <tt>(TestCase&nbsp;(return&nbsp;()))</tt> is a test case that never
fails, and
<tt>(TestCase&nbsp;(assertEqual&nbsp;"for&nbsp;x,"&nbsp;3&nbsp;x))</tt>
is a test case that checks that the value of <tt>x</tt> is 3.&nbsp; Additional ways
to create test cases are described later under <a href="#AdvancedFeatures">Advanced
Features</a>.</p>
<h3 id="Tests">Tests</h3>
<p>As soon as you have more than one test, you'll want to name them to tell them apart. As
soon as you have more than several tests, you'll want to group them to process them more
easily. So, naming and grouping are the two keys to managing collections of tests.</p>
<p>In tune with the "composite" design pattern [<a href="#DesignPatterns">1</a>], a
<b>test</b> is defined as a package of test cases. Concretely, a test is either a single
test case, a group of tests, or either of the first two identified by a label.</p>
<pre>
data Test = TestCase Assertion
| TestList [Test]
| TestLabel String Test
</pre>
<p>There are three important features of this definition to note:</p>
<ul>
<li>A <tt>TestList</tt> consists of a list of tests rather than a list of test cases.
This means that the structure of a <tt>Test</tt> is actually a tree. Using a
hierarchy helps organize tests just as it helps organize files in a file system.</li>
<li>A <tt>TestLabel</tt> is attached to a test rather than to a test case. This means
that all nodes in the test tree, not just test case (leaf) nodes, can be labeled.
Hierarchical naming helps organize tests just as it helps organize files in a file
system.</li>
<li>A <tt>TestLabel</tt> is separate from both <tt>TestCase</tt> and <tt>TestList</tt>.
This means that labeling is optional everywhere in the tree. Why is this a good
thing? Because of the hierarchical structure of a test, each constituent test case
is uniquely identified by its path in the tree, ignoring all labels. Sometimes a
test case's path (or perhaps its subpath below a certain node) is a perfectly
adequate "name" for the test case (perhaps relative to a certain node). In this
case, creating a label for the test case is both unnecessary and inconvenient.</li>
</ul>
<p>The number of test cases that a test comprises can be computed with
<tt>testCaseCount</tt>.</p>
<pre>
testCaseCount :: Test -> Int
</pre>
<p>As mentioned above, a test is identified by its <b>path</b> in the test hierarchy.</p>
<pre>
data Node = ListItem Int | Label String
deriving (Eq, Show, Read)
type Path = [Node] -- Node order is from test case to root.
</pre>
<p>Each occurrence of <tt>TestList</tt> gives rise to a <tt>ListItem</tt> and each
occurrence of <tt>TestLabel</tt> gives rise to a <tt>Label</tt>. The <tt>ListItem</tt>s
by themselves ensure uniqueness among test case paths, while the <tt>Label</tt>s allow
you to add mnemonic names for individual test cases and collections of them.</p>
<p>Note that the order of nodes in a path is reversed from what you might expect: The first
node in the list is the one deepest in the tree. This order is a concession to
efficiency: It allows common path prefixes to be shared.</p>
<p>The paths of the test cases that a test comprises can be computed with
<tt>testCasePaths</tt>. The paths are listed in the order in which the corresponding
test cases would be executed.</p>
<pre>
testCasePaths :: Test -> [Path]
</pre>
<p>The three variants of <tt>Test</tt> can be constructed simply by applying
<tt>TestCase</tt>, <tt>TestList</tt>, and <tt>TestLabel</tt> to appropriate arguments.
Additional ways to create tests are described later under <a href="#AdvancedFeatures"
>Advanced Features</a>.</p>
<p>The design of the type <tt>Test</tt> provides great conciseness, flexibility, and
convenience in specifying tests. Moreover, the nature of Haskell significantly augments
these qualities:</p>
<ul>
<li>Combining assertions and other code to construct test cases is easy with the
<tt>IO</tt> monad.</li>
<li>Using overloaded functions and special operators (see below), specification of
assertions and tests is extremely compact.</li>
<li>Structuring a test tree by value, rather than by name as in JUnit, provides for more
convenient, flexible, and robust test suite specification. In particular, a test
suite can more easily be computed "on the fly" than in other test frameworks.</li>
<li>Haskell's powerful abstraction facilities provide unmatched support for test
refactoring.</li>
</ul>
<h3 id="AdvancedFeatures">Advanced Features</h3>
<p>HUnit provides additional features for specifying assertions and tests more conveniently
and concisely. These facilities make use of Haskell type classes.</p>
<p>The following operators can be used to construct assertions.</p>
<pre>
infix 1 @?, @=?, @?=
(@?) :: (AssertionPredicable t) => t -> String -> Assertion
pred @? msg = assertionPredicate pred >>= assertBool msg
(@=?) :: (Eq a, Show a) => a -> a -> Assertion
expected @=? actual = assertEqual "" expected actual
(@?=) :: (Eq a, Show a) => a -> a -> Assertion
actual @?= expected = assertEqual "" expected actual
</pre>
<p>You provide a boolean condition and failure message separately to <tt>(@?)</tt>, as for
<tt>assertBool</tt>, but in a different order. The <tt>(@=?)</tt> and <tt>(@?=)</tt>
operators provide shorthands for <tt>assertEqual</tt> when no preface is required. They
differ only in the order in which the expected and actual values are provided. (The
actual value--the uncertain one--goes on the "?" side of the operator.)</p>
<p>The <tt>(@?)</tt> operator's first argument is something from which an assertion
predicate can be made, that is, its type must be <tt>AssertionPredicable</tt>.</p>
<pre>
type AssertionPredicate = IO Bool
class AssertionPredicable t
where assertionPredicate :: t -> AssertionPredicate
instance AssertionPredicable Bool
where assertionPredicate = return
instance (AssertionPredicable t) => AssertionPredicable (IO t)
where assertionPredicate = (>>= assertionPredicate)
</pre>
<p>The overloaded <tt>assert</tt> function in the <tt>Assertable</tt> type class constructs
an assertion.</p>
<pre>
class Assertable t
where assert :: t -> Assertion
instance Assertable ()
where assert = return
instance Assertable Bool
where assert = assertBool ""
instance (ListAssertable t) => Assertable [t]
where assert = listAssert
instance (Assertable t) => Assertable (IO t)
where assert = (>>= assert)
</pre>
<p>The <tt>ListAssertable</tt> class allows <tt>assert</tt> to be applied to <tt>[Char]</tt>
(that is, <tt>String</tt>).</p>
<pre>
class ListAssertable t
where listAssert :: [t] -> Assertion
instance ListAssertable Char
where listAssert = assertString
</pre>
<p>With the above declarations, <tt>(assert&nbsp;())</tt>,
<tt>(assert&nbsp;True)</tt>, and <tt>(assert&nbsp;"")</tt> (as well as
<tt>IO</tt> forms of these values, such as <tt>(return&nbsp;())</tt>) are all
assertions that never fail, while <tt>(assert&nbsp;False)</tt> and
<tt>(assert&nbsp;"some&nbsp;failure&nbsp;message")</tt> (and their
<tt>IO</tt> forms) are assertions that always fail. You may define additional
instances for the type classes <tt>Assertable</tt>, <tt>ListAssertable</tt>, and
<tt>AssertionPredicable</tt> if that should be useful in your application.</p>
<p>The overloaded <tt>test</tt> function in the <tt>Testable</tt> type class constructs a
test.</p>
<pre>
class Testable t
where test :: t -> Test
instance Testable Test
where test = id
instance (Assertable t) => Testable (IO t)
where test = TestCase . assert
instance (Testable t) => Testable [t]
where test = TestList . map test
</pre>
<p>The <tt>test</tt> function makes a test from either an <tt>Assertion</tt> (using
<tt>TestCase</tt>), a list of <tt>Testable</tt> items (using <tt>TestList</tt>), or
a <tt>Test</tt> (making no change).</p>
<p>The following operators can be used to construct tests.</p>
<pre>
infix 1 ~?, ~=?, ~?=
infixr 0 ~:
(~?) :: (AssertionPredicable t) => t -> String -> Test
pred ~? msg = TestCase (pred @? msg)
(~=?) :: (Eq a, Show a) => a -> a -> Test
expected ~=? actual = TestCase (expected @=? actual)
(~?=) :: (Eq a, Show a) => a -> a -> Test
actual ~?= expected = TestCase (actual @?= expected)
(~:) :: (Testable t) => String -> t -> Test
label ~: t = TestLabel label (test t)
</pre>
<p><tt>(~?)</tt>, <tt>(~=?)</tt>, and <tt>(~?=)</tt> each make an assertion, as for
<tt>(@?)</tt>, <tt>(@=?)</tt>, and <tt>(@?=)</tt>, respectively, and then a test case
from that assertion. <tt>(~:)</tt> attaches a label to something that is
<tt>Testable</tt>. You may define additional instances for the type class
<tt>Testable</tt> should that be useful.</p>
<h2 id="RunningTests">Running Tests</h2>
<p>HUnit is structured to support multiple test controllers. The first subsection below
describes the <a href="#TestExecution">test execution</a> characteristics common to all
test controllers. The second subsection describes the <a href="#Text-BasedController"
>text-based controller</a> that is included with HUnit.</p>
<h3 id="TestExecution">Test Execution</h3>
<p>All test controllers share a common test execution model. They differ only in how the
results of test execution are shown.</p>
<p>The execution of a test (a value of type <tt>Test</tt>) involves the serial execution (in
the <tt>IO</tt> monad) of its constituent test cases. The test cases are executed in a
depth-first, left-to-right order. During test execution, four counts of test cases are
maintained:</p>
<pre>
data Counts = Counts { cases, tried, errors, failures :: Int }
deriving (Eq, Show, Read)
</pre>
<ul>
<li><tt>cases</tt> is the number of test cases included in the test. This number is a
static property of a test and remains unchanged during test execution.</li>
<li><tt>tried</tt> is the number of test cases that have been executed so far during the
test execution.</li>
<li><tt>errors</tt> is the number of test cases whose execution ended with an unexpected
exception being raised. Errors indicate problems with test cases, as opposed to the
code under test.</li>
<li><tt>failures</tt> is the number of test cases whose execution asserted failure.
Failures indicate problems with the code under test.</li>
</ul>
<p>Why is there no count for test case successes? The technical reason is that the counts
are maintained such that the number of test case successes is always equal to
<tt>(tried&nbsp;-&nbsp;(errors&nbsp;+&nbsp;failures))</tt>. The
psychosocial reason is that, with test-centered development and the expectation that
test failures will be few and short-lived, attention should be focused on the failures
rather than the successes.</p>
<p>As test execution proceeds, three kinds of reporting event are communicated to the test
controller. (What the controller does in response to the reporting events depends on the
controller.)</p>
<ul>
<li><i>start</i> -- Just prior to initiation of a test case, the path of the test case
and the current counts (excluding the current test case) are reported.</li>
<li><i>error</i> -- When a test case terminates with an error, the error message is
reported, along with the test case path and current counts (including the current
test case).</li>
<li><i>failure</i> -- When a test case terminates with a failure, the failure message is
reported, along with the test case path and current counts (including the current
test case).</li>
</ul>
<p>Typically, a test controller shows <i>error</i> and <i>failure</i> reports immediately
but uses the <i>start</i> report merely to update an indication of overall test
execution progress.</p>
<h3 id="Text-BasedController">Text-Based Controller</h3>
<p>A text-based test controller is included with HUnit.</p>
<pre>
runTestText :: PutText st -> Test -> IO (Counts, st)
</pre>
<p><tt>runTestText</tt> is generalized on a <i>reporting scheme</i> given as its first
argument. During execution of the test given as its second argument, the controller
creates a string for each reporting event and processes it according to the reporting
scheme. When test execution is complete, the controller returns the final counts along
with the final state for the reporting scheme.</p>
<p>The strings for the three kinds of reporting event are as follows.</p>
<ul>
<li>A <i>start</i> report is the result of the function <tt>showCounts</tt> applied to
the counts current immediately prior to initiation of the test case being started.</li>
<li>An <i>error</i> report is of the form
"<tt>Error&nbsp;in:&nbsp;&nbsp;&nbsp;<i>path</i>\n<i>message</i></tt>",
where <i>path</i> is the path of the test case in error, as shown by
<tt>showPath</tt>, and <i>message</i> is a message describing the error. If the path
is empty, the report has the form "<tt>Error:\n<i>message</i></tt>".</li>
<li>A <i>failure</i> report is of the form
"<tt>Failure&nbsp;in:&nbsp;<i>path</i>\n<i>message</i></tt>", where
<i>path</i> is the path of the test case in error, as shown by
<tt>showPath</tt>, and <i>message</i> is the failure message. If the path is empty,
the report has the form "<tt>Failure:\n<i>message</i></tt>".</li>
</ul>
<p>The function <tt>showCounts</tt> shows a set of counts.</p>
<pre>
showCounts :: Counts -> String
</pre>
<p>The form of its result is
"<tt>Cases:&nbsp;<i>cases</i>&nbsp;&nbsp;Tried:&nbsp;<i>tried</i>&nbsp;&nbsp;Errors:&nbsp;<i>errors</i>&nbsp;&nbsp;Failures:&nbsp;<i>failures</i></tt>"
where <i>cases</i>, <i>tried</i>, <i>errors</i>, and <i>failures</i> are the count
values.</p>
<p>The function <tt>showPath</tt> shows a test case path.</p>
<pre>
showPath :: Path -> String
</pre>
<p>The nodes in the path are reversed (so that the path reads from the root down to the test
case), and the representations for the nodes are joined by '<tt>:</tt>' separators. The
representation for <tt>(ListItem <i>n</i>)</tt> is <tt>(show n)</tt>. The representation
for <tt>(Label <i>label</i>)</tt> is normally <i>label</i>. However, if <i>label</i>
contains a colon or if <tt>(show <i>label</i>)</tt> is different from <i>label</i>
surrounded by quotation marks--that is, if any ambiguity could exist--then <tt>(Label
<i>label</i>)</tt> is represented as <tt>(show <i>label</i>)</tt>.</p>
<p>HUnit includes two reporting schemes for the text-based test controller. You may define
others if you wish.</p>
<pre>
putTextToHandle :: Handle -> Bool -> PutText Int
</pre>
<p><tt>putTextToHandle</tt> writes error and failure reports, plus a report of the final
counts, to the given handle. Each of these reports is terminated by a newline. In
addition, if the given flag is <tt>True</tt>, it writes start reports to the handle as
well. A start report, however, is not terminated by a newline. Before the next report is
written, the start report is "erased" with an appropriate sequence of carriage return
and space characters. Such overwriting realizes its intended effect on terminal devices.</p>
<pre>
putTextToShowS :: PutText ShowS
</pre>
<p><tt>putTextToShowS</tt> ignores start reports and simply accumulates error and failure
reports, terminating them with newlines. The accumulated reports are returned (as the
second element of the pair returned by <tt>runTestText</tt>) as a <tt>ShowS</tt>
function (that is, one with type <tt>(String&nbsp;->&nbsp;String)</tt>) whose
first argument is a string to be appended to the accumulated report lines.</p>
<p>HUnit provides a shorthand for the most common use of the text-based test controller.</p>
<pre>
runTestTT :: Test -> IO Counts
</pre>
<p><tt>runTestTT</tt> invokes <tt>runTestText</tt>, specifying <tt>(putTextToHandle stderr
True)</tt> for the reporting scheme, and returns the final counts from the test
execution.</p>
<h2 id="References">References</h2>
<dl>
<dt id="DesignPatterns">[1] Gamma, E., et al. Design Patterns: Elements of Reusable
Object-Oriented Software, Addison-Wesley, Reading, MA, 1995.</dt>
<dd>The classic book describing design patterns in an object-oriented context.</dd>
<dt>
<a href="http://www.junit.org">http://www.junit.org</a>
</dt>
<dd>Web page for JUnit, the tool after which HUnit is modeled.</dd>
<dt>
<a href="http://junit.sourceforge.net/doc/testinfected/testing.htm">
http://junit.sourceforge.net/doc/testinfected/testing.htm</a>
</dt>
<dd>A good introduction to test-first development and the use of JUnit.</dd>
<dt>
<a href="http://junit.sourceforge.net/doc/cookstour/cookstour.htm">
http://junit.sourceforge.net/doc/cookstour/cookstour.htm</a>
</dt>
<dd>A description of the internal structure of JUnit. Makes for an interesting
comparison between JUnit and HUnit.</dd>
</dl>
<hr/>
<p>The HUnit software and this guide were written by Dean Herington (<a
href="mailto:heringto@cs.unc.edu">heringto@cs.unc.edu</a>).</p>
</body>
</html>

40
cabal/share/x86_64-osx-ghc-7.10.1/HUnit-1.2.5.2/examples/Example.hs Normal file
View File

@@ -0,0 +1,40 @@
-- Example.hs -- Examples from HUnit user's guide
--
-- For more examples, check out the tests directory. It contains unit tests
-- for HUnit.
module Main where
import Test.HUnit
foo :: Int -> (Int, Int)
foo x = (1, x)
partA :: Int -> IO (Int, Int)
partA v = return (v+2, v+3)
partB :: Int -> IO Bool
partB v = return (v > 5)
test1 :: Test
test1 = TestCase (assertEqual "for (foo 3)," (1,2) (foo 3))
test2 :: Test
test2 = TestCase (do (x,y) <- partA 3
assertEqual "for the first result of partA," 5 x
b <- partB y
assertBool ("(partB " ++ show y ++ ") failed") b)
tests :: Test
tests = TestList [TestLabel "test1" test1, TestLabel "test2" test2]
tests' :: Test
tests' = test [ "test1" ~: "(foo 3)" ~: (1,2) ~=? (foo 3),
"test2" ~: do (x, y) <- partA 3
assertEqual "for the first result of partA," 5 x
partB y @? "(partB " ++ show y ++ ") failed" ]
main :: IO Counts
main = do runTestTT tests
runTestTT tests'

2
cabal/share/x86_64-osx-ghc-7.10.1/HUnit-1.2.5.2/prologue.txt Normal file
View File

@@ -0,0 +1,2 @@
HUnit is a unit testing framework for Haskell, inspired by the JUnit
tool for Java, see: <http://www.junit.org>.

17
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/assets/complete_license.as Normal file
View File

@@ -0,0 +1,17 @@
zepto - the minimal Scheme Interpreter
Copyright (C) 2015 Veit Heller
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

9
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/assets/grandeur.as Normal file
View File

@@ -0,0 +1,9 @@
Hoffnung ist ein verdammtes Ding, das sich zwischen zwei ersten Sonnenstrahlen versteckt.
Ein lärmiges Gefühl in der Langzeile, dessen Positivismus mich erbrechen macht;
palindrome Gleichheit der Winkel, die nicht überraschend ist -
hündische Liebelei mit ungeborener Zeit.
Vielleicht gastrisches Rauschen in der Ödnis oder eine Ewigkeit;
wenn ihr mich danach fragt, weiss ich von nichts.

5
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/assets/license_interactive.as Normal file
View File

@@ -0,0 +1,5 @@
zepto version 0.6.3, Copyright (C) 2015 Veit Heller
zepto comes with ABSOLUTELY NO WARRANTY; for details type `:complete-license'.
This is free software, and you are welcome to redistribute it
under certain conditions; contact the author for details.

22
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/char.scm Normal file
View File

@@ -0,0 +1,22 @@
(define (char-cmp? cmp a b) "compares two chars with a compare option cmp"
(cmp (char->integer a) (char->integer b)))
(define (char-ci-cmp? cmp a b) "compares two chars case insensitive with a compare option cmp"
(cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char=? a b) "are chars equal" (char-cmp? = a b))
(define (char<? a b) "is char less than" (char-cmp? < a b))
(define (char>? a b) "is char greater than" (char-cmp? > a b))
(define (char<=? a b) "is char less than or equal to" (char-cmp? <= a b))
(define (char>=? a b) "is char greater than or equal to" (char-cmp? >= a b))
(define (char-ci=? a b) "are chars equal; case insensitive"
(char-ci-cmp? = a b))
(define (char-ci<? a b) "is char less than; case insensitive"
(char-ci-cmp? < a b))
(define (char-ci>? a b) "is char greater than; case insensitive"
(char-ci-cmp? > a b))
(define (char-ci<=? a b) "is char less than or equal to; case insensitive"
(char-ci-cmp? <= a b))
(define (char-ci>=? a b) "is char greater than or equal to; case insensitive"
(char-ci-cmp? >= a b))

316
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/comlist.scm Normal file
View File

@@ -0,0 +1,316 @@
;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
; Copyright (C) 1991, 1993, 1995, 2001, 2003 Aubrey Jaffer.
; Copyright (C) 2000 Colin Walters
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;; Some of these functions may be already defined in your Scheme.
;;; Comment out those definitions for functions which are already defined.
;;;; LIST FUNCTIONS FROM COMMON LISP
(define (cl:assoc-adjoin pair lst)
(if (assoc (car pair) lst)
lst
(cons pair lst)))
;; with precedence to first lst
(define cl:assoc-union
(letrec ((onion (lambda (lst1 lst2)
(if (null? lst1)
lst2
(onion (cdr lst1) (cl:assoc-adjoin (car lst1) lst2))))))
(lambda (lst1 lst2)
(cond ((null? lst1) lst2)
((null? lst2) lst1)
(else (onion (reverse lst2) lst1))))))
;;; Some tail-recursive optimizations made by
;;; Colin Walters <walters@cis.ohio-state.edu>
;;; AGJ restored order July 2001.
;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define (cl:make-list k . init)
(set! init (if (pair? init) (car init)))
(do ((k (+ -1 k) (+ -1 k))
(result '() (cons init result)))
((negative? k) result)))
;@
(define (cl:copy-list lst) (append lst '()))
;@
(define (cl:adjoin obj lst) (if (member obj lst) lst (cons obj lst)))
;@
(define cl:union
(letrec ((onion
(lambda (lst1 lst2)
(if (null? lst1)
lst2
(onion (cdr lst1) (cl:adjoin (car lst1) lst2))))))
(lambda (lst1 lst2)
(cond ((null? lst1) lst2)
((null? lst2) lst1)
((null? (cdr lst1)) (cl:adjoin (car lst1) lst2))
((null? (cdr lst2)) (cl:adjoin (car lst2) lst1))
((< (length lst2) (length lst1)) (onion (reverse lst2) lst1))
(else (onion (reverse lst1) lst2))))))
;@
(define (cl:intersection lst1 lst2)
(if (null? lst2)
lst2
(let build-intersection ((lst1 lst1)
(result '()))
(cond ((null? lst1)
(if (null? result)
'()
(reverse result)))
((member (car lst1) lst2)
(build-intersection (cdr lst1) (cons (car lst1) result)))
(else (build-intersection (cdr lst1) result))))))
;@
(define (cl:set-difference lst1 lst2)
(if (null? lst2)
lst1
(let build-difference ((lst1 lst1)
(result '()))
(cond ((null? lst1) (reverse result))
((member (car lst1) lst2) (build-difference (cdr lst1) result))
(else (build-difference (cdr lst1) (cons (car lst1) result)))))))
;@
(define (cl:subset? lst1 lst2)
(or (eq? lst1 lst2)
(let loop ((lst1 lst1))
(or (null? lst1)
(and (member (car lst1) lst2)
(loop (cdr lst1)))))))
;@
(define (cl:position obj lst)
(define pos (lambda (n lst)
(cond ((null? lst) #f)
((equal? obj (car lst)) n)
(else (pos (+ 1 n) (cdr lst))))))
(pos 0 lst))
;@
(define (cl:reduce-init pred? init lst)
(if (null? lst)
init
(cl:reduce-init pred? (pred? init (car lst)) (cdr lst))))
;@
(define (cl:reduce pred? lst)
(cond ((null? lst) lst)
((null? (cdr lst)) (car lst))
(else (cl:reduce-init pred? (car lst) (cdr lst)))))
;@
(define (cl:some pred lst . rest)
(cond ((null? rest)
(let mapf ((lst lst))
(and (not (null? lst))
(or (pred (car lst)) (mapf (cdr lst))))))
(else (let mapf ((lst lst) (rest rest))
(and (not (null? lst))
(or (apply pred (car lst) (map car rest))
(mapf (cdr lst) (map cdr rest))))))))
;@
(define (cl:every pred lst . rest)
(cond ((null? rest)
(let mapf ((lst lst))
(or (null? lst)
(and (pred (car lst)) (mapf (cdr lst))))))
(else (let mapf ((lst lst) (rest rest))
(or (null? lst)
(and (apply pred (car lst) (map car rest))
(mapf (cdr lst) (map cdr rest))))))))
;@
(define (cl:notany pred . ls) (not (apply cl:some pred ls)))
;@
(define (cl:notevery pred . ls) (not (apply cl:every pred ls)))
;@
(define (cl:list-of?? predicate . bound)
(define (errout) (apply error 'list-of?? predicate bound))
(case (length bound)
((0)
(lambda (obj)
(and (list? obj)
(cl:every predicate obj))))
((1)
(set! bound (car bound))
(cond ((negative? bound)
(set! bound (- bound))
(lambda (obj)
(and (list? obj)
(<= bound (length obj))
(cl:every predicate obj))))
(else
(lambda (obj)
(and (list? obj)
(<= (length obj) bound)
(cl:every predicate obj))))))
((2)
(let ((low (car bound))
(high (cadr bound)))
(cond ((or (negative? low) (negative? high)) (errout))
((< high low)
(set! high (car bound))
(set! low (cadr bound))))
(lambda (obj)
(and (list? obj)
(<= low (length obj) high)
(cl:every predicate obj)))))
(else (errout))))
;@
(define (cl:find-if pred? lst)
(cond ((null? lst) #f)
((pred? (car lst)) (car lst))
(else (cl:find-if pred? (cdr lst)))))
;@
(define (cl:member-if pred? lst)
(cond ((null? lst) #f)
((pred? (car lst)) lst)
(else (cl:member-if pred? (cdr lst)))))
;@
(define (cl:remove obj lst)
(define head (list '*head*))
(let remove ((lst lst)
(tail head))
(cond ((null? lst))
((eqv? obj (car lst)) (remove (cdr lst) tail))
(else
(set-cdr! tail (list (car lst)))
(remove (cdr lst) (cdr tail)))))
(cdr head))
;@
(define (cl:remove-if pred? lst)
(let remove-if ((lst lst)
(result '()))
(cond ((null? lst) (reverse result))
((pred? (car lst)) (remove-if (cdr lst) result))
(else (remove-if (cdr lst) (cons (car lst) result))))))
;@
(define (cl:remove-if-not pred? lst)
(let remove-if-not ((lst lst)
(result '()))
(cond ((null? lst) (reverse result))
((pred? (car lst)) (remove-if-not (cdr lst) (cons (car lst) result)))
(else (remove-if-not (cdr lst) result)))))
;@
(define cl:nconc
(lambda args
(cond ((null? args) '())
((null? (cdr args)) (car args))
((null? (car args)) (apply cl:nconc (cdr args)))
(else
(set-cdr! (last-pair (car args))
(apply cl:nconc (cdr args)))
(car args)))))
;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define (cl:nreverse rev-it)
;;; Reverse order of elements of LIST by mutating cdrs.
(cond ((null? rev-it) rev-it)
((not (list? rev-it))
(error "nreverse: Not a list in arg1" rev-it))
(else (do ((reved '() rev-it)
(rev-cdr (cdr rev-it) (cdr rev-cdr))
(rev-it rev-it rev-cdr))
((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it)))))
;@
(define (cl:last lst n)
(cl:nthcdr (- (length lst) n) lst))
;@
(define (cl:butlast lst n)
(cl:butnthcdr (- (length lst) n) lst))
;@
(define (cl:nthcdr n lst)
(if (zero? n) lst (cl:nthcdr (+ -1 n) (cdr lst))))
;@
(define (cl:butnthcdr k lst)
(cond ((negative? k) lst) ;(slib:error "negative argument to butnthcdr" k)
; SIMSYNCH FIFO8 uses negative k.
((or (zero? k) (null? lst)) '())
(else (let ((ans (list (car lst))))
(do ((lst (cdr lst) (cdr lst))
(tail ans (cdr tail))
(k (+ -2 k) (+ -1 k)))
((or (negative? k) (null? lst)) ans)
(set-cdr! tail (list (car lst))))))))
;;;; CONDITIONALS
;@
(define (cl:and? . args)
(cond ((null? args) #t)
((car args) (apply cl:and? (cdr args)))
(else #f)))
;@
(define (cl:or? . args)
(cond ((null? args) #f)
((car args) #t)
(else (apply cl:or? (cdr args)))))
;;;@ Checks to see if a list has any duplicate MEMBERs.
(define (cl:has-duplicates? lst)
(cond ((null? lst) #f)
((member (car lst) (cdr lst)) #t)
(else (cl:has-duplicates? (cdr lst)))))
;;;@ remove duplicates of MEMBERs of a list
(define cl:remove-duplicates
(letrec ((rem-dup (lambda (lst nlst)
(cond ((null? lst) (if (null? nlst) nlst (reverse nlst)))
((member (car lst) nlst) (rem-dup (cdr lst) nlst))
(else (rem-dup (cdr lst) (cons (car lst) nlst)))))))
(lambda (lst)
(rem-dup lst '()))))
;@
(define cl:list*
(letrec ((list*1 (lambda (obj)
(if (null? (cdr obj))
(car obj)
(cons (car obj) (list*1 (cdr obj)))))))
(lambda (obj1 . obj2)
(if (null? obj2)
obj1
(cons obj1 (list*1 obj2))))))
;@
(define (cl:atom? obj)
(not (pair? obj)))
;@
(define (cl:delete obj lst)
(let delete ((lst lst))
(cond ((null? lst) '())
((equal? obj (car lst)) (delete (cdr lst)))
(else
(set-cdr! lst (delete (cdr lst)))
lst))))
;@
(define (cl:delete-if pred lst)
(let delete-if ((lst lst))
(cond ((null? lst) '())
((pred (car lst)) (delete-if (cdr lst)))
(else
(set-cdr! lst (delete-if (cdr lst)))
lst))))
;@
(define (cl:delete-if-not pred lst)
(let delete-if ((lst lst))
(cond ((null? lst) '())
((not (pred (car lst))) (delete-if (cdr lst)))
(else
(set-cdr! lst (delete-if (cdr lst)))
lst))))

8
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/definitions.scm Normal file
View File

@@ -0,0 +1,8 @@
(define len length)
(define nil '())
(define ok '())
(define fold foldl)
(define reduce fold)
(define ceil ceiling)
(define head car)
(define tail list-tail)

24
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/delay.scm Normal file
View File

@@ -0,0 +1,24 @@
;; All implementations here are "borrowed" from
;; husk-scheme (github.com/justinethier/husk-scheme).
(define force
(lambda (object)
(object)))
(define-syntax delay
(syntax-rules ()
((delay expression)
(make-promise (lambda () expression)))))
(define make-promise
(lambda (proc)
(let ((result-ready? #f)
(result #f))
(lambda ()
(if result-ready?
result
(let ((x (proc)))
(if result-ready?
result
(begin (set! result x)
(set! result-ready? #t)
result))))))))

76
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/extra.scm Normal file
View File

@@ -0,0 +1,76 @@
;; All definitions here are "borrowed" from
;; husk (github.com/justinethier/husk-scheme).
(define-syntax cond
(syntax-rules (else =>)
((cond (else result1 result2 ...))
((lambda () result1 result2 ...)))
((cond (test => result))
(let ((temp test))
(if temp (result temp))))
((cond (test => result) clause1 clause2 ...)
(let ((temp test))
(if temp
(result temp)
(cond clause1 clause2 ...))))
((cond (test)) test)
((cond (test) clause1 clause2 ...)
(let ((temp test))
(if temp
temp
(cond clause1 clause2 ...))))
((cond (test result1 result2 ...))
(if test ((lambda () result1 result2 ...))))
((cond (test result1 result2 ...)
clause1 clause2 ...)
(if test
((lambda () result1 result2 ...))
(cond clause1 clause2 ...)))))
(define-syntax case
(syntax-rules (else =>)
((case (key ...)
clauses ...)
(let ((atom-key (key ...)))
(case atom-key clauses ...)))
((case key
(else => result))
(result key))
((case key
(else result1 result2 ...))
(if #t ((lambda () result1 result2 ...))))
((case key
((atoms ...) result1 result2 ...))
(if (memv key '(atoms ...))
((lambda () result1 result2 ...))))
((case key
((atoms ...) => result)
clause clauses ...)
(if (memv key '(atoms ...))
(result key)
(case key clause clauses ...)))
((case key
((atoms ...) result1 result2 ...)
clause clauses ...)
(if (memv key '(atoms ...))
((lambda () result1 result2 ...))
(case key clause clauses ...)))))
(define-syntax when
(syntax-rules ()
((when test result1 result2 ...)
(if test
(begin result1 result2 ...)))))
(define-syntax unless
(syntax-rules ()
((unless test result1 result2 ...)
(if (not test)
(begin result1 result2 ...)))))
(define-syntax letrec*
(syntax-rules ()
((letrec* ((var1 init1) ...) body1 body2 ...)
(let ((var1 #f) ...)
(set! var1 init1)
...
(let () body1 body2 ...)))))

38
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/io.scm Normal file
View File

@@ -0,0 +1,38 @@
(define (call-with-input-file s p) "open an input file s and apply a function to it, then close the file"
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((res (p inport)))
(close-input-port inport)
res))))
(define (call-with-output-file s p) "open an output file s and apply a function to it, then close the file"
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((res (p outport)))
(close-output-port outport)
res))))
(define (with-input-from-file s p) "open an input file s and run a function while it's open"
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((prev-inport (current-input-port)))
(set-input-port inport)
(let ((res (p)))
(close-input-port inport)
(set-input-port prev-inport)
res)))))
(define (with-output-to-file s p) "open an output file s and run a function while it's open"
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((prev-outport (current-output-port)))
(set-output-port outport)
(let ((res (p)))
(close-output-port outport)
(set-output-port prev-outport)
res)))))

68
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/let.scm Normal file
View File

@@ -0,0 +1,68 @@
;; All implementations here are "borrowed" from
;; husk-scheme (github.com/justinethier/husk-scheme).
(define-syntax let
(syntax-rules ()
((_ ((x v) ...) e1 e2 ...)
((lambda (x ...) e1 e2 ...) v ...))
((_ name ((x v) ...) e1 e2 ...)
(let*
((f (lambda (name)
(lambda (x ...) e1 e2 ...)))
(ff ((lambda (proc) (f (lambda (x ...) ((proc proc)
x ...))))
(lambda (proc) (f (lambda (x ...) ((proc proc)
x ...)))))))
(ff v ...)))))
(define-syntax let*
(syntax-rules ()
((let* () body1 body2 ...)
(let () body1 body2 ...))
((let* ((name1 val1) (name2 val2) ...)
body1 body2 ...)
(let ((name1 val1))
(let* ((name2 val2) ...)
body1 body2 ...)))))
(define-syntax letrec
(syntax-rules ()
((letrec ((var1 init1) ...) body ...)
(letrec "generate_temp_names"
(var1 ...)
()
((var1 init1) ...)
body ...))
((letrec "generate_temp_names"
()
(temp1 ...)
((var1 init1) ...)
body ...)
(let ((var1 #f) ...)
(let ((temp1 init1) ...)
(set! var1 temp1)
...
body ...)))
((letrec "generate_temp_names"
(x y ...)
(temp ...)
((var1 init1) ...)
body ...)
(letrec "generate_temp_names"
(y ...)
(newtemp temp ...)
((var1 init1) ...)
body ...))))
(define-syntax do
(syntax-rules ()
((_ ((var init . step) ...)
(test expr ...)
command ...)
(let loop ((var init) ...)
(if test
(begin expr ...)
(begin (begin command ...)
(loop
(if (null? (cdr (list var . step)))
(car (list var . step))
(cadr (list var . step))) ...)))))))

9
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/logical.scm Normal file
View File

@@ -0,0 +1,9 @@
(define (and . lst) "logical and on multiple values" (fold && #t lst))
(define (or . lst) "logical or on multiple values" (fold || #f lst))
(define (not x) "logical not" (if x #f #t))
(define (null? obj) "test for null object"
(if (eqv? obj '())
#t
#f))

124
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/marsaglia.scm Normal file
View File

@@ -0,0 +1,124 @@
; george marsaglia's random number generators,
; taken from http://programmingpraxis.codepad.org/sf8Z4pJP, edited slightly
; for testing the rngs, a test routine is included (test-rng).
; Testing might take a while, though, because do notation is still very slow.
(define (ipow b e)
(cond ((zero? e) 1)
((even? e) (ipow (* b b) (/ e 2)))
(else (* b (ipow (* b b) (/ (- e 1) 2))))))
(define (logand a b)
(if (or (zero? a) (zero? b)) 0
(+ (* (logand (floor (/ a 2)) (floor (/ b 2))) 2)
(if (or (even? a) (even? b)) 0 1))))
(define (logxor a b)
(cond ((zero? a) b)
((zero? b) a)
(else
(+ (* (logxor (floor (/ a 2)) (floor (/ b 2))) 2)
(if (even? a)
(if (even? b) 0 1)
(if (even? b) 1 0))))))
(define (ash int cnt)
(if (negative? cnt)
(let ((n (ipow 2 (- cnt))))
(if (negative? int)
(+ -1 (quotient (+ 1 int) n))
(quotient int n)))
(* (ipow 2 cnt) int)))
(define mwc #f)
(define shr3 #f)
(define cong #f)
(define fib #f)
(define kiss #f)
(define lfib4 #f)
(define swb #f)
(define uni #f)
(define vni #f)
(define settable #f)
(let ((z 362436069) (w 521288629) (jsr 123456789)
(jcong 380116160) (a 224466889) (b 7584631)
(t (make-vector 256 0)) (x 0) (y 0) (c 0))
(define (mod8 n) (modulo n 256))
(define (mod32 n) (modulo n 4294967296))
(define (ref i) (vector-ref t (mod8 i)))
(set! mwc (lambda ()
(set! z (mod32 (+ (* 36969 (logand z 65535)) (ash z -16))))
(set! w (mod32 (+ (* 18000 (logand w 65535)) (ash w -16))))
(mod32 (+ (ash z 16) w))))
(set! shr3 (lambda ()
(set! jsr (mod32 (logxor jsr (ash jsr 17))))
(set! jsr (mod32 (logxor jsr (ash jsr -13))))
(set! jsr (mod32 (logxor jsr (ash jsr 5)))) jsr))
(set! cong (lambda ()
(set! jcong (mod32 (+ (* 69069 jcong) 1234567))) jcong))
(set! fib (lambda ()
(set! b (mod32 (+ a b))) (set! a (mod32 (- b a))) a))
(set! kiss (lambda ()
(mod32 (+ (logxor (mwc) (cong)) (shr3)))))
(set! lfib4 (lambda ()
(set! c (mod8 (+ c 1)))
(vector-set! t c (mod32 (+ (ref c) (ref (+ c 58))
(ref (+ c 119)) (ref (+ c 178))))) (ref c)))
(set! swb (lambda ()
(set! c (mod8 (+ c 1)))
(let ((bro (if (< x y) 1 0)))
(set! x (mod32 (ref (+ c 34))))
(set! y (mod32 (+ (ref (+ c 19)) bro)))
(vector-set! t c (mod32 (- x y)))
(vector-ref t c))))
(set! uni (lambda ()
(* (kiss) 2.328306e-10)))
(set! vni (lambda ()
(* (- (kiss) 2147483648) 4.6566133e-10)))
(set! settable (lambda (i1 i2 i3 i4 i5 i6)
(set! z i1) (set! w i2) (set! jsr i3) (set! jcong i4)
(set! a i5) (set! b i6) (set! x 0) (set! y 0) (set! c 0)
(do ((i 0 (+ i 1))) ((= i 256))
(vector-set! t i (kiss))))))
(define-syntax rng-assert
(syntax-rules ()
((rng-assert expr result)
(if (not (equal? expr result))
(write
'("failed assertion: "
"expected " result
", returned " expr))
(display "test succesful.")))))
(define (test-rng)
(let ((k 0))
(settable 12345 65435 34221 12345 9983651 95746118)
(display "First test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 1064612766)) (set! k (lfib4)))
(display "Second test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 627749721)) (set! k (swb)))
(display "Third test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 1372460312)) (set! k (kiss)))
(display "Fourth test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 1529210297)) (set! k (cong)))
(display "Fifth test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 2642725982)) (set! k (shr3)))
(display "Sixth test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 904977562)) (set! k (mwc)))
(display "Seventh test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 3519793928)) (set! k (fib)))))
;(test-rng)

27
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/math.scm Normal file
View File

@@ -0,0 +1,27 @@
(define exact? integer?)
(define (inexact? x) "is inexact number" (and (real? x) (not (integer? x))))
(define (even? n) "is even" (= (remainder n 2) 0))
(define (odd? n) "is odd" (not (= (remainder n 2) 0)))
(define (zero? n) "is zero" (= n 0))
(define (positive? n) "is positive" (> n 0))
(define (negative? n) "is negative" (< n 0))
(define complex? number?)
(define (abs n) "absolute value of number" (if (>= n 0) n (- n)))
(define (exact->inexact n) "make inexact number from exact" (* n 1.0))
(define (<> n1 n2) "not equal" (not (= n1 n2)))
(define (succ x) "next number" (+ x 1))
(define (pred x) "previous number" (- x 1))
(define (gcd a b) "Greatest Common Divisor"
(let ((aa (abs a))
(bb (abs b)))
(if (= bb 0)
aa
(gcd bb (remainder aa bb)))))
(define (lcm a b) "Least Common Multiple"
(if (or (= a 0) (= b 0))
0
(abs (* (quotient a (gcd a b)) b))))

14
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/module.scm Normal file
View File

@@ -0,0 +1,14 @@
(load "let.scm")
(load "char.scm")
(load "extra.scm")
(load "delay.scm")
(load "io.scm")
(load "logical.scm")
(load "marsaglia.scm")
(load "math.scm")
(load "pairs.scm")
(load "random.scm")
(load "util.scm")
(load "definitions.scm")

28
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/pairs.scm Normal file
View File

@@ -0,0 +1,28 @@
(define (caar pair) (car (car pair)))
(define (cadr pair) (car (cdr pair)))
(define (cdar pair) (cdr (car pair)))
(define (cddr pair) (cdr (cdr pair)))
(define (caaar pair) (car (car (car pair))))
(define (caadr pair) (car (car (cdr pair))))
(define (cadar pair) (car (cdr (car pair))))
(define (cdaar pair) (cdr (car (car pair))))
(define (caddr pair) (car (cdr (cdr pair))))
(define (cdadr pair) (cdr (car (cdr pair))))
(define (cddar pair) (cdr (cdr (car pair))))
(define (cdddr pair) (cdr (cdr (cdr pair))))
(define (caaaar pair) (car (car (car (car pair)))))
(define (caaadr pair) (car (car (car (cdr pair)))))
(define (caadar pair) (car (car (cdr (car pair)))))
(define (caaddr pair) (car (car (cdr (cdr pair)))))
(define (cadaar pair) (car (cdr (car (car pair)))))
(define (cadadr pair) (car (cdr (car (cdr pair)))))
(define (caddar pair) (car (cdr (cdr (car pair)))))
(define (cadddr pair) (car (cdr (cdr (cdr pair)))))
(define (cdaaar pair) (cdr (car (car (car pair)))))
(define (cdaadr pair) (cdr (car (car (cdr pair)))))
(define (cdadar pair) (cdr (car (cdr (car pair)))))
(define (cdaddr pair) (cdr (car (cdr (cdr pair)))))
(define (cddaar pair) (cdr (cdr (car (car pair)))))
(define (cddadr pair) (cdr (cdr (car (cdr pair)))))
(define (cdddar pair) (cdr (cdr (cdr (car pair)))))
(define (cddddr pair) (cdr (cdr (cdr (cdr pair)))))

16
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/random.scm Normal file
View File

@@ -0,0 +1,16 @@
;; This code is taken from:
;; http://stackoverflow.com/questions/14674165/scheme-generate-random
;; It is not to be used in cryptography or related fields.
(define random
(let ((a 69069) (c 1) (m (expt 2 32)) (seed 19380110.0))
(lambda new-seed
(if (pair? new-seed)
(begin (set! seed (car new-seed)))
(begin (set! seed (modulo (+ (* seed a) c) m))))
(/ seed m))))
(define (randint . args) "generate a random integer between the given args(the lower range is optional)"
(cond ((= (length args) 1) (randint 0 (car args)))
((= (length args) 2)
(+ (car args) (floor (* (random) (- (cadr args) (car args))))))
(else (write "usage: (randint [lo] hi)"))))

119
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/sort.scm Normal file
View File

@@ -0,0 +1,119 @@
;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
;;;
;;; This code is in the public domain.
;;; Updated: 11 June 1991
;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
;;; Updated: 19 June 1995
;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09
;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
;;; Modified by Andrew Sorensen for Impromptu 2006-05-10
;;; (cl:sorted? sequence less?)
;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
;;; such that for all 1 <= i <= m,
;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
;@
(define (cl:sorted? seq less?) "returns whether a sequence is sorted"
(cond ((null? seq) #t)
(else (let loop ((last (car seq)) (next (cdr seq)))
(or (null? next)
(and (not (less? (car next) last))
(loop (car next) (cdr next))))))))
;;; (cl:merge a b less?)
;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
;;; and returns a new list in which the elements of a and b have been stably
;;; interleaved so that (sorted? (merge a b less?) less?).
;;; Note: this does _not_ accept arrays. See below.
;@
(define (cl:merge a b less?) "merges two sorted lists"
(cond ((null? a) b)
((null? b) a)
(else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
;; The loop handles the merging of non-empty lists. It has
;; been written this way to save testing and car/cdring.
(if (less? y x)
(if (null? b)
(cons y (cons x a))
(cons y (loop x a (car b) (cdr b))))
;; x <= y
(if (null? a)
(cons x (cons y b))
(cons x (loop (car a) (cdr a) y b))))))))
;;; (cl:merge! a b less?)
;;; takes two sorted lists a and b and smashes their cdr fields to form a
;;; single sorted list including the elements of both.
;;; Note: this does _not_ accept arrays.
;@
(define (cl:merge! a b less?) "merges two sorted lists"
(define (loop r a b)
(if (less? (car b) (car a))
(begin (set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b))))
;; (car a) <= (car b)
(begin (set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b)))))
(cond ((null? a) b)
((null? b) a)
((less? (car b) (car a))
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)))
b)
(else (if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b))
a)))
;;; (cl:sort! sequence less?)
;;; sorts the list, array, or string sequence destructively. It uses
;;; a version of merge-sort invented, to the best of my knowledge, by
;;; David H. D. Warren, and first used in the DEC-10 Prolog system.
;;; R. A. O'Keefe adapted it to work destructively in Scheme.
;@
(define (cl:sort! seq less?) "sorts a sequence destructively; merge-sort"
(define (step n)
(cond ((> n 2)
(let* ((j (quotient n 2))
(a (step j))
(k (- n j))
(b (step k)))
(cl:merge! a b less?)))
((= n 2)
(let ((x (car seq))
(y (cadr seq))
(p seq))
(set! seq (cddr seq))
(cond ((less? y x)
(set-car! p y)
(set-car! (cdr p) x)))
(set-cdr! (cdr p) '())
p))
((= n 1)
(let ((p seq))
(set! seq (cdr seq))
(set-cdr! p '())
p))
(else '())))
(step (length seq)))
;;; (cl:sort sequence less?)
;;; sorts a array, string, or list non-destructively. It does this
;;; by sorting a copy of the sequence. My understanding is that the
;;; Standard says that the result of append is always "newly
;;; allocated" except for sharing structure with "the last argument",
;;; so (append x '()) ought to be a standard way of copying a list x.
;@
(define (cl:sort seq less?) "sorts a sequence non-destructively; merge-sort"
(cond ((vector? seq)
(list->vector (cl:sort! (vector->list seq) less?)))
((string? seq)
(list->string (cl:sort! (string->list seq) less?)))
(else (cl:sort! (append seq '()) less?))))

163
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/util.scm Normal file
View File

@@ -0,0 +1,163 @@
(define (list . objs) "creates a list from objects"
objs)
(define (id obj) "returns an object"
obj)
(define (flip func) "flips two arguments for a function"
(lambda (arg1 arg2)
(func arg2 arg1)))
(define (list-tail l k) "get tail of a list"
(if (zero? k)
l
(list-tail (cdr l) (- k 1))))
(define (list-ref l k) "get reference to list element at certain point"
(car (list-tail l k)))
(define (append i a) "append something to a list"
(foldr (lambda (ax ix) (cons ax ix)) a i))
(define (curry func arg1) "curry a function"
(lambda (arg)
(func arg1 arg)))
(define (compose f g) "compose two functions"
(lambda (arg)
(f (apply g arg))))
(define (foldr func end l) "fold right"
(if (null? l)
end
(func (car l) (foldr func end (cdr l)))))
(define (foldl func accum l) "fold left"
(if (null? l)
accum
(foldl func (func accum (car l)) (cdr l))))
(define (generate func init pred)
(if (pred init)
(cons init '())
(cons init (unfold func (func init) pred))))
(define (sum . l) "sum of values"
(fold + 0 l))
(define (product . l) "product of values"
(fold * 1 l))
(define (max first . l) "maximum of values"
(fold (lambda (old new)
(if (> old new) old new))
first
l))
(define (min first . l) "minimum of values"
(fold (lambda (old new)
(if (< old new) old new))
first
l))
(define (length l) "length of list"
(fold (lambda (x y)
(+ x 1))
0
l))
(define (reverse l) "reverse list"
(fold (flip cons) '() l))
(define (my-mem-helper obj lst cmp-proc)
(cond
((null? lst) #f)
((cmp-proc obj (car lst)) lst)
(else (my-mem-helper obj (cdr lst) cmp-proc))))
(define (memq obj lst) (my-mem-helper obj lst eq?))
(define (memv obj lst) (my-mem-helper obj lst eqv?))
(define (member obj lst) (my-mem-helper obj lst equal?))
(define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))
(define (assq obj alist) (fold (mem-helper (curry eq? obj) car) #f alist))
(define (assv obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist))
(define (assoc obj alist) (fold (mem-helper (curry equal? obj) car) #f alist))
(define (map func l) "map function to list"
(foldr (lambda (x y)
(cons (func x) y))
'()
l))
(define (foreach func l) "apply function to each element on the list"
(foldl (lambda (x y)
(cons (func x) y))
'()
l))
(define (filter pred l) "filter list through preidcate"
(foldr (lambda (x y)
(if (pred x)
(cons x y)
y))
'()
l))
(define (any? pred lst) "does anything in the list satisfy the predicate?"
(let any* ((l (map pred lst)))
(cond
((null? l) #f)
((car l) #t)
(else
(any* (cdr l))))))
(define (every? pred lst) "do all values in the list satisfy the predicate?"
(let every* ((l (map pred lst)))
(cond
((null? l) #t)
((car l)
(every* (cdr l)))
(else
#f))))
(define all? every?)
(define (case x . cs)
if (== cs ())
("No Case Found")
(if (== x (caar cs))
(cadar cs)
(unpack case (join (list x) (cdr cs)))))
(define (iota n) "makes a list from numbers from 0 to n"
(let ((acc '()))
(do ((i 0 (+ i 1))) ((= i n)) (set! acc (append acc (list i)))) acc))
(define (unzip1-with-cdr . lists)
(unzip1-with-cdr-iterative lists '() '()))
(define (unzip1-with-cdr-iterative lists cars cdrs)
(if (null? lists)
(cons cars cdrs)
(let ((car1 (caar lists))
(cdr1 (cdar lists)))
(unzip1-with-cdr-iterative
(cdr lists)
(append cars (list car1))
(append cdrs (list cdr1))))))
(define (for-each proc . lists) "applies a function to a bunch of arguments"
(if (null? lists)
(apply proc)
(if (null? (car lists))
#t
(let* ((unz (apply unzip1-with-cdr lists))
(cars (car unz))
(cdrs (cdr unz)))
(apply proc cars) (apply map (cons proc cdrs))))))

17
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/assets/complete_license.as Normal file
View File

@@ -0,0 +1,17 @@
zepto - the minimal Scheme Interpreter
Copyright (C) 2015 Veit Heller
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

9
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/assets/grandeur.as Normal file
View File

@@ -0,0 +1,9 @@
Hoffnung ist ein verdammtes Ding, das sich zwischen zwei ersten Sonnenstrahlen versteckt.
Ein lärmiges Gefühl in der Langzeile, dessen Positivismus mich erbrechen macht;
palindrome Gleichheit der Winkel, die nicht überraschend ist -
hündische Liebelei mit ungeborener Zeit.
Vielleicht gastrisches Rauschen in der Ödnis oder eine Ewigkeit;
wenn ihr mich danach fragt, weiss ich von nichts.

5
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/assets/license_interactive.as Normal file
View File

@@ -0,0 +1,5 @@
zepto version 0.6.4, Copyright (C) 2015 Veit Heller
zepto comes with ABSOLUTELY NO WARRANTY; for details type `:complete-license'.
This is free software, and you are welcome to redistribute it
under certain conditions; contact the author for details.

22
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/char.scm Normal file
View File

@@ -0,0 +1,22 @@
(define (char-cmp? cmp a b) "compares two chars with a compare option cmp"
(cmp (char->integer a) (char->integer b)))
(define (char-ci-cmp? cmp a b) "compares two chars case insensitive with a compare option cmp"
(cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char=? a b) "are chars equal" (char-cmp? = a b))
(define (char<? a b) "is char less than" (char-cmp? < a b))
(define (char>? a b) "is char greater than" (char-cmp? > a b))
(define (char<=? a b) "is char less than or equal to" (char-cmp? <= a b))
(define (char>=? a b) "is char greater than or equal to" (char-cmp? >= a b))
(define (char-ci=? a b) "are chars equal; case insensitive"
(char-ci-cmp? = a b))
(define (char-ci<? a b) "is char less than; case insensitive"
(char-ci-cmp? < a b))
(define (char-ci>? a b) "is char greater than; case insensitive"
(char-ci-cmp? > a b))
(define (char-ci<=? a b) "is char less than or equal to; case insensitive"
(char-ci-cmp? <= a b))
(define (char-ci>=? a b) "is char greater than or equal to; case insensitive"
(char-ci-cmp? >= a b))

316
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/comlist.scm Normal file
View File

@@ -0,0 +1,316 @@
;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
; Copyright (C) 1991, 1993, 1995, 2001, 2003 Aubrey Jaffer.
; Copyright (C) 2000 Colin Walters
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;; Some of these functions may be already defined in your Scheme.
;;; Comment out those definitions for functions which are already defined.
;;;; LIST FUNCTIONS FROM COMMON LISP
(define (cl:assoc-adjoin pair lst)
(if (assoc (car pair) lst)
lst
(cons pair lst)))
;; with precedence to first lst
(define cl:assoc-union
(letrec ((onion (lambda (lst1 lst2)
(if (null? lst1)
lst2
(onion (cdr lst1) (cl:assoc-adjoin (car lst1) lst2))))))
(lambda (lst1 lst2)
(cond ((null? lst1) lst2)
((null? lst2) lst1)
(else (onion (reverse lst2) lst1))))))
;;; Some tail-recursive optimizations made by
;;; Colin Walters <walters@cis.ohio-state.edu>
;;; AGJ restored order July 2001.
;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define (cl:make-list k . init)
(set! init (if (pair? init) (car init)))
(do ((k (+ -1 k) (+ -1 k))
(result '() (cons init result)))
((negative? k) result)))
;@
(define (cl:copy-list lst) (append lst '()))
;@
(define (cl:adjoin obj lst) (if (member obj lst) lst (cons obj lst)))
;@
(define cl:union
(letrec ((onion
(lambda (lst1 lst2)
(if (null? lst1)
lst2
(onion (cdr lst1) (cl:adjoin (car lst1) lst2))))))
(lambda (lst1 lst2)
(cond ((null? lst1) lst2)
((null? lst2) lst1)
((null? (cdr lst1)) (cl:adjoin (car lst1) lst2))
((null? (cdr lst2)) (cl:adjoin (car lst2) lst1))
((< (length lst2) (length lst1)) (onion (reverse lst2) lst1))
(else (onion (reverse lst1) lst2))))))
;@
(define (cl:intersection lst1 lst2)
(if (null? lst2)
lst2
(let build-intersection ((lst1 lst1)
(result '()))
(cond ((null? lst1)
(if (null? result)
'()
(reverse result)))
((member (car lst1) lst2)
(build-intersection (cdr lst1) (cons (car lst1) result)))
(else (build-intersection (cdr lst1) result))))))
;@
(define (cl:set-difference lst1 lst2)
(if (null? lst2)
lst1
(let build-difference ((lst1 lst1)
(result '()))
(cond ((null? lst1) (reverse result))
((member (car lst1) lst2) (build-difference (cdr lst1) result))
(else (build-difference (cdr lst1) (cons (car lst1) result)))))))
;@
(define (cl:subset? lst1 lst2)
(or (eq? lst1 lst2)
(let loop ((lst1 lst1))
(or (null? lst1)
(and (member (car lst1) lst2)
(loop (cdr lst1)))))))
;@
(define (cl:position obj lst)
(define pos (lambda (n lst)
(cond ((null? lst) #f)
((equal? obj (car lst)) n)
(else (pos (+ 1 n) (cdr lst))))))
(pos 0 lst))
;@
(define (cl:reduce-init pred? init lst)
(if (null? lst)
init
(cl:reduce-init pred? (pred? init (car lst)) (cdr lst))))
;@
(define (cl:reduce pred? lst)
(cond ((null? lst) lst)
((null? (cdr lst)) (car lst))
(else (cl:reduce-init pred? (car lst) (cdr lst)))))
;@
(define (cl:some pred lst . rest)
(cond ((null? rest)
(let mapf ((lst lst))
(and (not (null? lst))
(or (pred (car lst)) (mapf (cdr lst))))))
(else (let mapf ((lst lst) (rest rest))
(and (not (null? lst))
(or (apply pred (car lst) (map car rest))
(mapf (cdr lst) (map cdr rest))))))))
;@
(define (cl:every pred lst . rest)
(cond ((null? rest)
(let mapf ((lst lst))
(or (null? lst)
(and (pred (car lst)) (mapf (cdr lst))))))
(else (let mapf ((lst lst) (rest rest))
(or (null? lst)
(and (apply pred (car lst) (map car rest))
(mapf (cdr lst) (map cdr rest))))))))
;@
(define (cl:notany pred . ls) (not (apply cl:some pred ls)))
;@
(define (cl:notevery pred . ls) (not (apply cl:every pred ls)))
;@
(define (cl:list-of?? predicate . bound)
(define (errout) (apply error 'list-of?? predicate bound))
(case (length bound)
((0)
(lambda (obj)
(and (list? obj)
(cl:every predicate obj))))
((1)
(set! bound (car bound))
(cond ((negative? bound)
(set! bound (- bound))
(lambda (obj)
(and (list? obj)
(<= bound (length obj))
(cl:every predicate obj))))
(else
(lambda (obj)
(and (list? obj)
(<= (length obj) bound)
(cl:every predicate obj))))))
((2)
(let ((low (car bound))
(high (cadr bound)))
(cond ((or (negative? low) (negative? high)) (errout))
((< high low)
(set! high (car bound))
(set! low (cadr bound))))
(lambda (obj)
(and (list? obj)
(<= low (length obj) high)
(cl:every predicate obj)))))
(else (errout))))
;@
(define (cl:find-if pred? lst)
(cond ((null? lst) #f)
((pred? (car lst)) (car lst))
(else (cl:find-if pred? (cdr lst)))))
;@
(define (cl:member-if pred? lst)
(cond ((null? lst) #f)
((pred? (car lst)) lst)
(else (cl:member-if pred? (cdr lst)))))
;@
(define (cl:remove obj lst)
(define head (list '*head*))
(let remove ((lst lst)
(tail head))
(cond ((null? lst))
((eqv? obj (car lst)) (remove (cdr lst) tail))
(else
(set-cdr! tail (list (car lst)))
(remove (cdr lst) (cdr tail)))))
(cdr head))
;@
(define (cl:remove-if pred? lst)
(let remove-if ((lst lst)
(result '()))
(cond ((null? lst) (reverse result))
((pred? (car lst)) (remove-if (cdr lst) result))
(else (remove-if (cdr lst) (cons (car lst) result))))))
;@
(define (cl:remove-if-not pred? lst)
(let remove-if-not ((lst lst)
(result '()))
(cond ((null? lst) (reverse result))
((pred? (car lst)) (remove-if-not (cdr lst) (cons (car lst) result)))
(else (remove-if-not (cdr lst) result)))))
;@
(define cl:nconc
(lambda args
(cond ((null? args) '())
((null? (cdr args)) (car args))
((null? (car args)) (apply cl:nconc (cdr args)))
(else
(set-cdr! (last-pair (car args))
(apply cl:nconc (cdr args)))
(car args)))))
;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define (cl:nreverse rev-it)
;;; Reverse order of elements of LIST by mutating cdrs.
(cond ((null? rev-it) rev-it)
((not (list? rev-it))
(error "nreverse: Not a list in arg1" rev-it))
(else (do ((reved '() rev-it)
(rev-cdr (cdr rev-it) (cdr rev-cdr))
(rev-it rev-it rev-cdr))
((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it)))))
;@
(define (cl:last lst n)
(cl:nthcdr (- (length lst) n) lst))
;@
(define (cl:butlast lst n)
(cl:butnthcdr (- (length lst) n) lst))
;@
(define (cl:nthcdr n lst)
(if (zero? n) lst (cl:nthcdr (+ -1 n) (cdr lst))))
;@
(define (cl:butnthcdr k lst)
(cond ((negative? k) lst) ;(slib:error "negative argument to butnthcdr" k)
; SIMSYNCH FIFO8 uses negative k.
((or (zero? k) (null? lst)) '())
(else (let ((ans (list (car lst))))
(do ((lst (cdr lst) (cdr lst))
(tail ans (cdr tail))
(k (+ -2 k) (+ -1 k)))
((or (negative? k) (null? lst)) ans)
(set-cdr! tail (list (car lst))))))))
;;;; CONDITIONALS
;@
(define (cl:and? . args)
(cond ((null? args) #t)
((car args) (apply cl:and? (cdr args)))
(else #f)))
;@
(define (cl:or? . args)
(cond ((null? args) #f)
((car args) #t)
(else (apply cl:or? (cdr args)))))
;;;@ Checks to see if a list has any duplicate MEMBERs.
(define (cl:has-duplicates? lst)
(cond ((null? lst) #f)
((member (car lst) (cdr lst)) #t)
(else (cl:has-duplicates? (cdr lst)))))
;;;@ remove duplicates of MEMBERs of a list
(define cl:remove-duplicates
(letrec ((rem-dup (lambda (lst nlst)
(cond ((null? lst) (if (null? nlst) nlst (reverse nlst)))
((member (car lst) nlst) (rem-dup (cdr lst) nlst))
(else (rem-dup (cdr lst) (cons (car lst) nlst)))))))
(lambda (lst)
(rem-dup lst '()))))
;@
(define cl:list*
(letrec ((list*1 (lambda (obj)
(if (null? (cdr obj))
(car obj)
(cons (car obj) (list*1 (cdr obj)))))))
(lambda (obj1 . obj2)
(if (null? obj2)
obj1
(cons obj1 (list*1 obj2))))))
;@
(define (cl:atom? obj)
(not (pair? obj)))
;@
(define (cl:delete obj lst)
(let delete ((lst lst))
(cond ((null? lst) '())
((equal? obj (car lst)) (delete (cdr lst)))
(else
(set-cdr! lst (delete (cdr lst)))
lst))))
;@
(define (cl:delete-if pred lst)
(let delete-if ((lst lst))
(cond ((null? lst) '())
((pred (car lst)) (delete-if (cdr lst)))
(else
(set-cdr! lst (delete-if (cdr lst)))
lst))))
;@
(define (cl:delete-if-not pred lst)
(let delete-if ((lst lst))
(cond ((null? lst) '())
((not (pred (car lst))) (delete-if (cdr lst)))
(else
(set-cdr! lst (delete-if (cdr lst)))
lst))))

8
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/definitions.scm Normal file
View File

@@ -0,0 +1,8 @@
(define len length)
(define nil '())
(define ok '())
(define fold foldl)
(define reduce fold)
(define ceil ceiling)
(define head car)
(define tail list-tail)

24
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/delay.scm Normal file
View File

@@ -0,0 +1,24 @@
;; All implementations here are "borrowed" from
;; husk-scheme (github.com/justinethier/husk-scheme).
(define force
(lambda (object)
(object)))
(define-syntax delay
(syntax-rules ()
((delay expression)
(make-promise (lambda () expression)))))
(define make-promise
(lambda (proc)
(let ((result-ready? #f)
(result #f))
(lambda ()
(if result-ready?
result
(let ((x (proc)))
(if result-ready?
result
(begin (set! result x)
(set! result-ready? #t)
result))))))))

76
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/extra.scm Normal file
View File

@@ -0,0 +1,76 @@
;; All definitions here are "borrowed" from
;; husk (github.com/justinethier/husk-scheme).
(define-syntax cond
(syntax-rules (else =>)
((cond (else result1 result2 ...))
((lambda () result1 result2 ...)))
((cond (test => result))
(let ((temp test))
(if temp (result temp))))
((cond (test => result) clause1 clause2 ...)
(let ((temp test))
(if temp
(result temp)
(cond clause1 clause2 ...))))
((cond (test)) test)
((cond (test) clause1 clause2 ...)
(let ((temp test))
(if temp
temp
(cond clause1 clause2 ...))))
((cond (test result1 result2 ...))
(if test ((lambda () result1 result2 ...))))
((cond (test result1 result2 ...)
clause1 clause2 ...)
(if test
((lambda () result1 result2 ...))
(cond clause1 clause2 ...)))))
(define-syntax case
(syntax-rules (else =>)
((case (key ...)
clauses ...)
(let ((atom-key (key ...)))
(case atom-key clauses ...)))
((case key
(else => result))
(result key))
((case key
(else result1 result2 ...))
(if #t ((lambda () result1 result2 ...))))
((case key
((atoms ...) result1 result2 ...))
(if (memv key '(atoms ...))
((lambda () result1 result2 ...))))
((case key
((atoms ...) => result)
clause clauses ...)
(if (memv key '(atoms ...))
(result key)
(case key clause clauses ...)))
((case key
((atoms ...) result1 result2 ...)
clause clauses ...)
(if (memv key '(atoms ...))
((lambda () result1 result2 ...))
(case key clause clauses ...)))))
(define-syntax when
(syntax-rules ()
((when test result1 result2 ...)
(if test
(begin result1 result2 ...)))))
(define-syntax unless
(syntax-rules ()
((unless test result1 result2 ...)
(if (not test)
(begin result1 result2 ...)))))
(define-syntax letrec*
(syntax-rules ()
((letrec* ((var1 init1) ...) body1 body2 ...)
(let ((var1 #f) ...)
(set! var1 init1)
...
(let () body1 body2 ...)))))

38
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/io.scm Normal file
View File

@@ -0,0 +1,38 @@
(define (call-with-input-file s p) "open an input file s and apply a function to it, then close the file"
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((res (p inport)))
(close-input-port inport)
res))))
(define (call-with-output-file s p) "open an output file s and apply a function to it, then close the file"
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((res (p outport)))
(close-output-port outport)
res))))
(define (with-input-from-file s p) "open an input file s and run a function while it's open"
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((prev-inport (current-input-port)))
(set-input-port inport)
(let ((res (p)))
(close-input-port inport)
(set-input-port prev-inport)
res)))))
(define (with-output-to-file s p) "open an output file s and run a function while it's open"
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((prev-outport (current-output-port)))
(set-output-port outport)
(let ((res (p)))
(close-output-port outport)
(set-output-port prev-outport)
res)))))

68
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/let.scm Normal file
View File

@@ -0,0 +1,68 @@
;; All implementations here are "borrowed" from
;; husk-scheme (github.com/justinethier/husk-scheme).
(define-syntax let
(syntax-rules ()
((_ ((x v) ...) e1 e2 ...)
((lambda (x ...) e1 e2 ...) v ...))
((_ name ((x v) ...) e1 e2 ...)
(let*
((f (lambda (name)
(lambda (x ...) e1 e2 ...)))
(ff ((lambda (proc) (f (lambda (x ...) ((proc proc)
x ...))))
(lambda (proc) (f (lambda (x ...) ((proc proc)
x ...)))))))
(ff v ...)))))
(define-syntax let*
(syntax-rules ()
((let* () body1 body2 ...)
(let () body1 body2 ...))
((let* ((name1 val1) (name2 val2) ...)
body1 body2 ...)
(let ((name1 val1))
(let* ((name2 val2) ...)
body1 body2 ...)))))
(define-syntax letrec
(syntax-rules ()
((letrec ((var1 init1) ...) body ...)
(letrec "generate_temp_names"
(var1 ...)
()
((var1 init1) ...)
body ...))
((letrec "generate_temp_names"
()
(temp1 ...)
((var1 init1) ...)
body ...)
(let ((var1 #f) ...)
(let ((temp1 init1) ...)
(set! var1 temp1)
...
body ...)))
((letrec "generate_temp_names"
(x y ...)
(temp ...)
((var1 init1) ...)
body ...)
(letrec "generate_temp_names"
(y ...)
(newtemp temp ...)
((var1 init1) ...)
body ...))))
(define-syntax do
(syntax-rules ()
((_ ((var init . step) ...)
(test expr ...)
command ...)
(let loop ((var init) ...)
(if test
(begin expr ...)
(begin (begin command ...)
(loop
(if (null? (cdr (list var . step)))
(car (list var . step))
(cadr (list var . step))) ...)))))))

9
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/logical.scm Normal file
View File

@@ -0,0 +1,9 @@
(define (and . lst) "logical and on multiple values" (fold && #t lst))
(define (or . lst) "logical or on multiple values" (fold || #f lst))
(define (not x) "logical not" (if x #f #t))
(define (null? obj) "test for null object"
(if (eqv? obj '())
#t
#f))

124
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/marsaglia.scm Normal file
View File

@@ -0,0 +1,124 @@
; george marsaglia's random number generators,
; taken from http://programmingpraxis.codepad.org/sf8Z4pJP, edited slightly
; for testing the rngs, a test routine is included (test-rng).
; Testing might take a while, though, because do notation is still very slow.
(define (ipow b e)
(cond ((zero? e) 1)
((even? e) (ipow (* b b) (/ e 2)))
(else (* b (ipow (* b b) (/ (- e 1) 2))))))
(define (logand a b)
(if (or (zero? a) (zero? b)) 0
(+ (* (logand (floor (/ a 2)) (floor (/ b 2))) 2)
(if (or (even? a) (even? b)) 0 1))))
(define (logxor a b)
(cond ((zero? a) b)
((zero? b) a)
(else
(+ (* (logxor (floor (/ a 2)) (floor (/ b 2))) 2)
(if (even? a)
(if (even? b) 0 1)
(if (even? b) 1 0))))))
(define (ash int cnt)
(if (negative? cnt)
(let ((n (ipow 2 (- cnt))))
(if (negative? int)
(+ -1 (quotient (+ 1 int) n))
(quotient int n)))
(* (ipow 2 cnt) int)))
(define mwc #f)
(define shr3 #f)
(define cong #f)
(define fib #f)
(define kiss #f)
(define lfib4 #f)
(define swb #f)
(define uni #f)
(define vni #f)
(define settable #f)
(let ((z 362436069) (w 521288629) (jsr 123456789)
(jcong 380116160) (a 224466889) (b 7584631)
(t (make-vector 256 0)) (x 0) (y 0) (c 0))
(define (mod8 n) (modulo n 256))
(define (mod32 n) (modulo n 4294967296))
(define (ref i) (vector-ref t (mod8 i)))
(set! mwc (lambda ()
(set! z (mod32 (+ (* 36969 (logand z 65535)) (ash z -16))))
(set! w (mod32 (+ (* 18000 (logand w 65535)) (ash w -16))))
(mod32 (+ (ash z 16) w))))
(set! shr3 (lambda ()
(set! jsr (mod32 (logxor jsr (ash jsr 17))))
(set! jsr (mod32 (logxor jsr (ash jsr -13))))
(set! jsr (mod32 (logxor jsr (ash jsr 5)))) jsr))
(set! cong (lambda ()
(set! jcong (mod32 (+ (* 69069 jcong) 1234567))) jcong))
(set! fib (lambda ()
(set! b (mod32 (+ a b))) (set! a (mod32 (- b a))) a))
(set! kiss (lambda ()
(mod32 (+ (logxor (mwc) (cong)) (shr3)))))
(set! lfib4 (lambda ()
(set! c (mod8 (+ c 1)))
(vector-set! t c (mod32 (+ (ref c) (ref (+ c 58))
(ref (+ c 119)) (ref (+ c 178))))) (ref c)))
(set! swb (lambda ()
(set! c (mod8 (+ c 1)))
(let ((bro (if (< x y) 1 0)))
(set! x (mod32 (ref (+ c 34))))
(set! y (mod32 (+ (ref (+ c 19)) bro)))
(vector-set! t c (mod32 (- x y)))
(vector-ref t c))))
(set! uni (lambda ()
(* (kiss) 2.328306e-10)))
(set! vni (lambda ()
(* (- (kiss) 2147483648) 4.6566133e-10)))
(set! settable (lambda (i1 i2 i3 i4 i5 i6)
(set! z i1) (set! w i2) (set! jsr i3) (set! jcong i4)
(set! a i5) (set! b i6) (set! x 0) (set! y 0) (set! c 0)
(do ((i 0 (+ i 1))) ((= i 256))
(vector-set! t i (kiss))))))
(define-syntax rng-assert
(syntax-rules ()
((rng-assert expr result)
(if (not (equal? expr result))
(write
'("failed assertion: "
"expected " result
", returned " expr))
(display "test succesful.")))))
(define (test-rng)
(let ((k 0))
(settable 12345 65435 34221 12345 9983651 95746118)
(display "First test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 1064612766)) (set! k (lfib4)))
(display "Second test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 627749721)) (set! k (swb)))
(display "Third test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 1372460312)) (set! k (kiss)))
(display "Fourth test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 1529210297)) (set! k (cong)))
(display "Fifth test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 2642725982)) (set! k (shr3)))
(display "Sixth test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 904977562)) (set! k (mwc)))
(display "Seventh test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 3519793928)) (set! k (fib)))))
;(test-rng)

27
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/math.scm Normal file
View File

@@ -0,0 +1,27 @@
(define exact? integer?)
(define (inexact? x) "is inexact number" (and (real? x) (not (integer? x))))
(define (even? n) "is even" (= (remainder n 2) 0))
(define (odd? n) "is odd" (not (= (remainder n 2) 0)))
(define (zero? n) "is zero" (= n 0))
(define (positive? n) "is positive" (> n 0))
(define (negative? n) "is negative" (< n 0))
(define complex? number?)
(define (abs n) "absolute value of number" (if (>= n 0) n (- n)))
(define (exact->inexact n) "make inexact number from exact" (* n 1.0))
(define (<> n1 n2) "not equal" (not (= n1 n2)))
(define (succ x) "next number" (+ x 1))
(define (pred x) "previous number" (- x 1))
(define (gcd a b) "Greatest Common Divisor"
(let ((aa (abs a))
(bb (abs b)))
(if (= bb 0)
aa
(gcd bb (remainder aa bb)))))
(define (lcm a b) "Least Common Multiple"
(if (or (= a 0) (= b 0))
0
(abs (* (quotient a (gcd a b)) b))))

14
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/module.scm Normal file
View File

@@ -0,0 +1,14 @@
(load "let.scm")
(load "char.scm")
(load "extra.scm")
(load "delay.scm")
(load "io.scm")
(load "logical.scm")
(load "marsaglia.scm")
(load "math.scm")
(load "pairs.scm")
(load "random.scm")
(load "util.scm")
(load "definitions.scm")

28
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/pairs.scm Normal file
View File

@@ -0,0 +1,28 @@
(define (caar pair) (car (car pair)))
(define (cadr pair) (car (cdr pair)))
(define (cdar pair) (cdr (car pair)))
(define (cddr pair) (cdr (cdr pair)))
(define (caaar pair) (car (car (car pair))))
(define (caadr pair) (car (car (cdr pair))))
(define (cadar pair) (car (cdr (car pair))))
(define (cdaar pair) (cdr (car (car pair))))
(define (caddr pair) (car (cdr (cdr pair))))
(define (cdadr pair) (cdr (car (cdr pair))))
(define (cddar pair) (cdr (cdr (car pair))))
(define (cdddr pair) (cdr (cdr (cdr pair))))
(define (caaaar pair) (car (car (car (car pair)))))
(define (caaadr pair) (car (car (car (cdr pair)))))
(define (caadar pair) (car (car (cdr (car pair)))))
(define (caaddr pair) (car (car (cdr (cdr pair)))))
(define (cadaar pair) (car (cdr (car (car pair)))))
(define (cadadr pair) (car (cdr (car (cdr pair)))))
(define (caddar pair) (car (cdr (cdr (car pair)))))
(define (cadddr pair) (car (cdr (cdr (cdr pair)))))
(define (cdaaar pair) (cdr (car (car (car pair)))))
(define (cdaadr pair) (cdr (car (car (cdr pair)))))
(define (cdadar pair) (cdr (car (cdr (car pair)))))
(define (cdaddr pair) (cdr (car (cdr (cdr pair)))))
(define (cddaar pair) (cdr (cdr (car (car pair)))))
(define (cddadr pair) (cdr (cdr (car (cdr pair)))))
(define (cdddar pair) (cdr (cdr (cdr (car pair)))))
(define (cddddr pair) (cdr (cdr (cdr (cdr pair)))))

16
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/random.scm Normal file
View File

@@ -0,0 +1,16 @@
;; This code is taken from:
;; http://stackoverflow.com/questions/14674165/scheme-generate-random
;; It is not to be used in cryptography or related fields.
(define random
(let ((a 69069) (c 1) (m (expt 2 32)) (seed 19380110.0))
(lambda new-seed
(if (pair? new-seed)
(begin (set! seed (car new-seed)))
(begin (set! seed (modulo (+ (* seed a) c) m))))
(/ seed m))))
(define (randint . args) "generate a random integer between the given args(the lower range is optional)"
(cond ((= (length args) 1) (randint 0 (car args)))
((= (length args) 2)
(+ (car args) (floor (* (random) (- (cadr args) (car args))))))
(else (write "usage: (randint [lo] hi)"))))

119
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/sort.scm Normal file
View File

@@ -0,0 +1,119 @@
;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
;;;
;;; This code is in the public domain.
;;; Updated: 11 June 1991
;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
;;; Updated: 19 June 1995
;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09
;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
;;; Modified by Andrew Sorensen for Impromptu 2006-05-10
;;; (cl:sorted? sequence less?)
;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
;;; such that for all 1 <= i <= m,
;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
;@
(define (cl:sorted? seq less?) "returns whether a sequence is sorted"
(cond ((null? seq) #t)
(else (let loop ((last (car seq)) (next (cdr seq)))
(or (null? next)
(and (not (less? (car next) last))
(loop (car next) (cdr next))))))))
;;; (cl:merge a b less?)
;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
;;; and returns a new list in which the elements of a and b have been stably
;;; interleaved so that (sorted? (merge a b less?) less?).
;;; Note: this does _not_ accept arrays. See below.
;@
(define (cl:merge a b less?) "merges two sorted lists"
(cond ((null? a) b)
((null? b) a)
(else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
;; The loop handles the merging of non-empty lists. It has
;; been written this way to save testing and car/cdring.
(if (less? y x)
(if (null? b)
(cons y (cons x a))
(cons y (loop x a (car b) (cdr b))))
;; x <= y
(if (null? a)
(cons x (cons y b))
(cons x (loop (car a) (cdr a) y b))))))))
;;; (cl:merge! a b less?)
;;; takes two sorted lists a and b and smashes their cdr fields to form a
;;; single sorted list including the elements of both.
;;; Note: this does _not_ accept arrays.
;@
(define (cl:merge! a b less?) "merges two sorted lists"
(define (loop r a b)
(if (less? (car b) (car a))
(begin (set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b))))
;; (car a) <= (car b)
(begin (set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b)))))
(cond ((null? a) b)
((null? b) a)
((less? (car b) (car a))
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)))
b)
(else (if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b))
a)))
;;; (cl:sort! sequence less?)
;;; sorts the list, array, or string sequence destructively. It uses
;;; a version of merge-sort invented, to the best of my knowledge, by
;;; David H. D. Warren, and first used in the DEC-10 Prolog system.
;;; R. A. O'Keefe adapted it to work destructively in Scheme.
;@
(define (cl:sort! seq less?) "sorts a sequence destructively; merge-sort"
(define (step n)
(cond ((> n 2)
(let* ((j (quotient n 2))
(a (step j))
(k (- n j))
(b (step k)))
(cl:merge! a b less?)))
((= n 2)
(let ((x (car seq))
(y (cadr seq))
(p seq))
(set! seq (cddr seq))
(cond ((less? y x)
(set-car! p y)
(set-car! (cdr p) x)))
(set-cdr! (cdr p) '())
p))
((= n 1)
(let ((p seq))
(set! seq (cdr seq))
(set-cdr! p '())
p))
(else '())))
(step (length seq)))
;;; (cl:sort sequence less?)
;;; sorts a array, string, or list non-destructively. It does this
;;; by sorting a copy of the sequence. My understanding is that the
;;; Standard says that the result of append is always "newly
;;; allocated" except for sharing structure with "the last argument",
;;; so (append x '()) ought to be a standard way of copying a list x.
;@
(define (cl:sort seq less?) "sorts a sequence non-destructively; merge-sort"
(cond ((vector? seq)
(list->vector (cl:sort! (vector->list seq) less?)))
((string? seq)
(list->string (cl:sort! (string->list seq) less?)))
(else (cl:sort! (append seq '()) less?))))

163
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.4/stdlib/util.scm Normal file
View File

@@ -0,0 +1,163 @@
(define (list . objs) "creates a list from objects"
objs)
(define (id obj) "returns an object"
obj)
(define (flip func) "flips two arguments for a function"
(lambda (arg1 arg2)
(func arg2 arg1)))
(define (list-tail l k) "get tail of a list"
(if (zero? k)
l
(list-tail (cdr l) (- k 1))))
(define (list-ref l k) "get reference to list element at certain point"
(car (list-tail l k)))
(define (append i a) "append something to a list"
(foldr (lambda (ax ix) (cons ax ix)) a i))
(define (curry func arg1) "curry a function"
(lambda (arg)
(func arg1 arg)))
(define (compose f g) "compose two functions"
(lambda (arg)
(f (apply g arg))))
(define (foldr func end l) "fold right"
(if (null? l)
end
(func (car l) (foldr func end (cdr l)))))
(define (foldl func accum l) "fold left"
(if (null? l)
accum
(foldl func (func accum (car l)) (cdr l))))
(define (generate func init pred)
(if (pred init)
(cons init '())
(cons init (unfold func (func init) pred))))
(define (sum . l) "sum of values"
(fold + 0 l))
(define (product . l) "product of values"
(fold * 1 l))
(define (max first . l) "maximum of values"
(fold (lambda (old new)
(if (> old new) old new))
first
l))
(define (min first . l) "minimum of values"
(fold (lambda (old new)
(if (< old new) old new))
first
l))
(define (length l) "length of list"
(fold (lambda (x y)
(+ x 1))
0
l))
(define (reverse l) "reverse list"
(fold (flip cons) '() l))
(define (my-mem-helper obj lst cmp-proc)
(cond
((null? lst) #f)
((cmp-proc obj (car lst)) lst)
(else (my-mem-helper obj (cdr lst) cmp-proc))))
(define (memq obj lst) (my-mem-helper obj lst eq?))
(define (memv obj lst) (my-mem-helper obj lst eqv?))
(define (member obj lst) (my-mem-helper obj lst equal?))
(define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))
(define (assq obj alist) (fold (mem-helper (curry eq? obj) car) #f alist))
(define (assv obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist))
(define (assoc obj alist) (fold (mem-helper (curry equal? obj) car) #f alist))
(define (map func l) "map function to list"
(foldr (lambda (x y)
(cons (func x) y))
'()
l))
(define (foreach func l) "apply function to each element on the list"
(foldl (lambda (x y)
(cons (func x) y))
'()
l))
(define (filter pred l) "filter list through preidcate"
(foldr (lambda (x y)
(if (pred x)
(cons x y)
y))
'()
l))
(define (any? pred lst) "does anything in the list satisfy the predicate?"
(let any* ((l (map pred lst)))
(cond
((null? l) #f)
((car l) #t)
(else
(any* (cdr l))))))
(define (every? pred lst) "do all values in the list satisfy the predicate?"
(let every* ((l (map pred lst)))
(cond
((null? l) #t)
((car l)
(every* (cdr l)))
(else
#f))))
(define all? every?)
(define (case x . cs)
if (== cs ())
("No Case Found")
(if (== x (caar cs))
(cadar cs)
(unpack case (join (list x) (cdr cs)))))
(define (iota n) "makes a list from numbers from 0 to n"
(let ((acc '()))
(do ((i 0 (+ i 1))) ((= i n)) (set! acc (append acc (list i)))) acc))
(define (unzip1-with-cdr . lists)
(unzip1-with-cdr-iterative lists '() '()))
(define (unzip1-with-cdr-iterative lists cars cdrs)
(if (null? lists)
(cons cars cdrs)
(let ((car1 (caar lists))
(cdr1 (cdar lists)))
(unzip1-with-cdr-iterative
(cdr lists)
(append cars (list car1))
(append cdrs (list cdr1))))))
(define (for-each proc . lists) "applies a function to a bunch of arguments"
(if (null? lists)
(apply proc)
(if (null? (car lists))
#t
(let* ((unz (apply unzip1-with-cdr lists))
(cars (car unz))
(cdrs (cdr unz)))
(apply proc cars) (apply map (cons proc cdrs))))))

17
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/assets/complete_license.as Normal file
View File

@@ -0,0 +1,17 @@
zepto - the minimal Scheme Interpreter
Copyright (C) 2015 Veit Heller
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

9
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/assets/grandeur.as Normal file
View File

@@ -0,0 +1,9 @@
Hoffnung ist ein verdammtes Ding, das sich zwischen zwei ersten Sonnenstrahlen versteckt.
Ein lärmiges Gefühl in der Langzeile, dessen Positivismus mich erbrechen macht;
palindrome Gleichheit der Winkel, die nicht überraschend ist -
hündische Liebelei mit ungeborener Zeit.
Vielleicht gastrisches Rauschen in der Ödnis oder eine Ewigkeit;
wenn ihr mich danach fragt, weiss ich von nichts.

5
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/assets/license_interactive.as Normal file
View File

@@ -0,0 +1,5 @@
zepto version 0.6.4, Copyright (C) 2015 Veit Heller
zepto comes with ABSOLUTELY NO WARRANTY; for details type `:complete-license'.
This is free software, and you are welcome to redistribute it
under certain conditions; contact the author for details.

22
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/char.scm Normal file
View File

@@ -0,0 +1,22 @@
(define (char-cmp? cmp a b) "compares two chars with a compare option cmp"
(cmp (char->integer a) (char->integer b)))
(define (char-ci-cmp? cmp a b) "compares two chars case insensitive with a compare option cmp"
(cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char=? a b) "are chars equal" (char-cmp? = a b))
(define (char<? a b) "is char less than" (char-cmp? < a b))
(define (char>? a b) "is char greater than" (char-cmp? > a b))
(define (char<=? a b) "is char less than or equal to" (char-cmp? <= a b))
(define (char>=? a b) "is char greater than or equal to" (char-cmp? >= a b))
(define (char-ci=? a b) "are chars equal; case insensitive"
(char-ci-cmp? = a b))
(define (char-ci<? a b) "is char less than; case insensitive"
(char-ci-cmp? < a b))
(define (char-ci>? a b) "is char greater than; case insensitive"
(char-ci-cmp? > a b))
(define (char-ci<=? a b) "is char less than or equal to; case insensitive"
(char-ci-cmp? <= a b))
(define (char-ci>=? a b) "is char greater than or equal to; case insensitive"
(char-ci-cmp? >= a b))

316
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/comlist.scm Normal file
View File

@@ -0,0 +1,316 @@
;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
; Copyright (C) 1991, 1993, 1995, 2001, 2003 Aubrey Jaffer.
; Copyright (C) 2000 Colin Walters
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;; Some of these functions may be already defined in your Scheme.
;;; Comment out those definitions for functions which are already defined.
;;;; LIST FUNCTIONS FROM COMMON LISP
(define (cl:assoc-adjoin pair lst)
(if (assoc (car pair) lst)
lst
(cons pair lst)))
;; with precedence to first lst
(define cl:assoc-union
(letrec ((onion (lambda (lst1 lst2)
(if (null? lst1)
lst2
(onion (cdr lst1) (cl:assoc-adjoin (car lst1) lst2))))))
(lambda (lst1 lst2)
(cond ((null? lst1) lst2)
((null? lst2) lst1)
(else (onion (reverse lst2) lst1))))))
;;; Some tail-recursive optimizations made by
;;; Colin Walters <walters@cis.ohio-state.edu>
;;; AGJ restored order July 2001.
;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define (cl:make-list k . init)
(set! init (if (pair? init) (car init)))
(do ((k (+ -1 k) (+ -1 k))
(result '() (cons init result)))
((negative? k) result)))
;@
(define (cl:copy-list lst) (append lst '()))
;@
(define (cl:adjoin obj lst) (if (member obj lst) lst (cons obj lst)))
;@
(define cl:union
(letrec ((onion
(lambda (lst1 lst2)
(if (null? lst1)
lst2
(onion (cdr lst1) (cl:adjoin (car lst1) lst2))))))
(lambda (lst1 lst2)
(cond ((null? lst1) lst2)
((null? lst2) lst1)
((null? (cdr lst1)) (cl:adjoin (car lst1) lst2))
((null? (cdr lst2)) (cl:adjoin (car lst2) lst1))
((< (length lst2) (length lst1)) (onion (reverse lst2) lst1))
(else (onion (reverse lst1) lst2))))))
;@
(define (cl:intersection lst1 lst2)
(if (null? lst2)
lst2
(let build-intersection ((lst1 lst1)
(result '()))
(cond ((null? lst1)
(if (null? result)
'()
(reverse result)))
((member (car lst1) lst2)
(build-intersection (cdr lst1) (cons (car lst1) result)))
(else (build-intersection (cdr lst1) result))))))
;@
(define (cl:set-difference lst1 lst2)
(if (null? lst2)
lst1
(let build-difference ((lst1 lst1)
(result '()))
(cond ((null? lst1) (reverse result))
((member (car lst1) lst2) (build-difference (cdr lst1) result))
(else (build-difference (cdr lst1) (cons (car lst1) result)))))))
;@
(define (cl:subset? lst1 lst2)
(or (eq? lst1 lst2)
(let loop ((lst1 lst1))
(or (null? lst1)
(and (member (car lst1) lst2)
(loop (cdr lst1)))))))
;@
(define (cl:position obj lst)
(define pos (lambda (n lst)
(cond ((null? lst) #f)
((equal? obj (car lst)) n)
(else (pos (+ 1 n) (cdr lst))))))
(pos 0 lst))
;@
(define (cl:reduce-init pred? init lst)
(if (null? lst)
init
(cl:reduce-init pred? (pred? init (car lst)) (cdr lst))))
;@
(define (cl:reduce pred? lst)
(cond ((null? lst) lst)
((null? (cdr lst)) (car lst))
(else (cl:reduce-init pred? (car lst) (cdr lst)))))
;@
(define (cl:some pred lst . rest)
(cond ((null? rest)
(let mapf ((lst lst))
(and (not (null? lst))
(or (pred (car lst)) (mapf (cdr lst))))))
(else (let mapf ((lst lst) (rest rest))
(and (not (null? lst))
(or (apply pred (car lst) (map car rest))
(mapf (cdr lst) (map cdr rest))))))))
;@
(define (cl:every pred lst . rest)
(cond ((null? rest)
(let mapf ((lst lst))
(or (null? lst)
(and (pred (car lst)) (mapf (cdr lst))))))
(else (let mapf ((lst lst) (rest rest))
(or (null? lst)
(and (apply pred (car lst) (map car rest))
(mapf (cdr lst) (map cdr rest))))))))
;@
(define (cl:notany pred . ls) (not (apply cl:some pred ls)))
;@
(define (cl:notevery pred . ls) (not (apply cl:every pred ls)))
;@
(define (cl:list-of?? predicate . bound)
(define (errout) (apply error 'list-of?? predicate bound))
(case (length bound)
((0)
(lambda (obj)
(and (list? obj)
(cl:every predicate obj))))
((1)
(set! bound (car bound))
(cond ((negative? bound)
(set! bound (- bound))
(lambda (obj)
(and (list? obj)
(<= bound (length obj))
(cl:every predicate obj))))
(else
(lambda (obj)
(and (list? obj)
(<= (length obj) bound)
(cl:every predicate obj))))))
((2)
(let ((low (car bound))
(high (cadr bound)))
(cond ((or (negative? low) (negative? high)) (errout))
((< high low)
(set! high (car bound))
(set! low (cadr bound))))
(lambda (obj)
(and (list? obj)
(<= low (length obj) high)
(cl:every predicate obj)))))
(else (errout))))
;@
(define (cl:find-if pred? lst)
(cond ((null? lst) #f)
((pred? (car lst)) (car lst))
(else (cl:find-if pred? (cdr lst)))))
;@
(define (cl:member-if pred? lst)
(cond ((null? lst) #f)
((pred? (car lst)) lst)
(else (cl:member-if pred? (cdr lst)))))
;@
(define (cl:remove obj lst)
(define head (list '*head*))
(let remove ((lst lst)
(tail head))
(cond ((null? lst))
((eqv? obj (car lst)) (remove (cdr lst) tail))
(else
(set-cdr! tail (list (car lst)))
(remove (cdr lst) (cdr tail)))))
(cdr head))
;@
(define (cl:remove-if pred? lst)
(let remove-if ((lst lst)
(result '()))
(cond ((null? lst) (reverse result))
((pred? (car lst)) (remove-if (cdr lst) result))
(else (remove-if (cdr lst) (cons (car lst) result))))))
;@
(define (cl:remove-if-not pred? lst)
(let remove-if-not ((lst lst)
(result '()))
(cond ((null? lst) (reverse result))
((pred? (car lst)) (remove-if-not (cdr lst) (cons (car lst) result)))
(else (remove-if-not (cdr lst) result)))))
;@
(define cl:nconc
(lambda args
(cond ((null? args) '())
((null? (cdr args)) (car args))
((null? (car args)) (apply cl:nconc (cdr args)))
(else
(set-cdr! (last-pair (car args))
(apply cl:nconc (cdr args)))
(car args)))))
;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define (cl:nreverse rev-it)
;;; Reverse order of elements of LIST by mutating cdrs.
(cond ((null? rev-it) rev-it)
((not (list? rev-it))
(error "nreverse: Not a list in arg1" rev-it))
(else (do ((reved '() rev-it)
(rev-cdr (cdr rev-it) (cdr rev-cdr))
(rev-it rev-it rev-cdr))
((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it)))))
;@
(define (cl:last lst n)
(cl:nthcdr (- (length lst) n) lst))
;@
(define (cl:butlast lst n)
(cl:butnthcdr (- (length lst) n) lst))
;@
(define (cl:nthcdr n lst)
(if (zero? n) lst (cl:nthcdr (+ -1 n) (cdr lst))))
;@
(define (cl:butnthcdr k lst)
(cond ((negative? k) lst) ;(slib:error "negative argument to butnthcdr" k)
; SIMSYNCH FIFO8 uses negative k.
((or (zero? k) (null? lst)) '())
(else (let ((ans (list (car lst))))
(do ((lst (cdr lst) (cdr lst))
(tail ans (cdr tail))
(k (+ -2 k) (+ -1 k)))
((or (negative? k) (null? lst)) ans)
(set-cdr! tail (list (car lst))))))))
;;;; CONDITIONALS
;@
(define (cl:and? . args)
(cond ((null? args) #t)
((car args) (apply cl:and? (cdr args)))
(else #f)))
;@
(define (cl:or? . args)
(cond ((null? args) #f)
((car args) #t)
(else (apply cl:or? (cdr args)))))
;;;@ Checks to see if a list has any duplicate MEMBERs.
(define (cl:has-duplicates? lst)
(cond ((null? lst) #f)
((member (car lst) (cdr lst)) #t)
(else (cl:has-duplicates? (cdr lst)))))
;;;@ remove duplicates of MEMBERs of a list
(define cl:remove-duplicates
(letrec ((rem-dup (lambda (lst nlst)
(cond ((null? lst) (if (null? nlst) nlst (reverse nlst)))
((member (car lst) nlst) (rem-dup (cdr lst) nlst))
(else (rem-dup (cdr lst) (cons (car lst) nlst)))))))
(lambda (lst)
(rem-dup lst '()))))
;@
(define cl:list*
(letrec ((list*1 (lambda (obj)
(if (null? (cdr obj))
(car obj)
(cons (car obj) (list*1 (cdr obj)))))))
(lambda (obj1 . obj2)
(if (null? obj2)
obj1
(cons obj1 (list*1 obj2))))))
;@
(define (cl:atom? obj)
(not (pair? obj)))
;@
(define (cl:delete obj lst)
(let delete ((lst lst))
(cond ((null? lst) '())
((equal? obj (car lst)) (delete (cdr lst)))
(else
(set-cdr! lst (delete (cdr lst)))
lst))))
;@
(define (cl:delete-if pred lst)
(let delete-if ((lst lst))
(cond ((null? lst) '())
((pred (car lst)) (delete-if (cdr lst)))
(else
(set-cdr! lst (delete-if (cdr lst)))
lst))))
;@
(define (cl:delete-if-not pred lst)
(let delete-if ((lst lst))
(cond ((null? lst) '())
((not (pred (car lst))) (delete-if (cdr lst)))
(else
(set-cdr! lst (delete-if (cdr lst)))
lst))))

8
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/definitions.scm Normal file
View File

@@ -0,0 +1,8 @@
(define len length)
(define nil '())
(define ok '())
(define fold foldl)
(define reduce fold)
(define ceil ceiling)
(define head car)
(define tail list-tail)

24
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/delay.scm Normal file
View File

@@ -0,0 +1,24 @@
;; All implementations here are "borrowed" from
;; husk-scheme (github.com/justinethier/husk-scheme).
(define force
(lambda (object)
(object)))
(define-syntax delay
(syntax-rules ()
((delay expression)
(make-promise (lambda () expression)))))
(define make-promise
(lambda (proc)
(let ((result-ready? #f)
(result #f))
(lambda ()
(if result-ready?
result
(let ((x (proc)))
(if result-ready?
result
(begin (set! result x)
(set! result-ready? #t)
result))))))))

76
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/extra.scm Normal file
View File

@@ -0,0 +1,76 @@
;; All definitions here are "borrowed" from
;; husk (github.com/justinethier/husk-scheme).
(define-syntax cond
(syntax-rules (else =>)
((cond (else result1 result2 ...))
((lambda () result1 result2 ...)))
((cond (test => result))
(let ((temp test))
(if temp (result temp))))
((cond (test => result) clause1 clause2 ...)
(let ((temp test))
(if temp
(result temp)
(cond clause1 clause2 ...))))
((cond (test)) test)
((cond (test) clause1 clause2 ...)
(let ((temp test))
(if temp
temp
(cond clause1 clause2 ...))))
((cond (test result1 result2 ...))
(if test ((lambda () result1 result2 ...))))
((cond (test result1 result2 ...)
clause1 clause2 ...)
(if test
((lambda () result1 result2 ...))
(cond clause1 clause2 ...)))))
(define-syntax case
(syntax-rules (else =>)
((case (key ...)
clauses ...)
(let ((atom-key (key ...)))
(case atom-key clauses ...)))
((case key
(else => result))
(result key))
((case key
(else result1 result2 ...))
(if #t ((lambda () result1 result2 ...))))
((case key
((atoms ...) result1 result2 ...))
(if (memv key '(atoms ...))
((lambda () result1 result2 ...))))
((case key
((atoms ...) => result)
clause clauses ...)
(if (memv key '(atoms ...))
(result key)
(case key clause clauses ...)))
((case key
((atoms ...) result1 result2 ...)
clause clauses ...)
(if (memv key '(atoms ...))
((lambda () result1 result2 ...))
(case key clause clauses ...)))))
(define-syntax when
(syntax-rules ()
((when test result1 result2 ...)
(if test
(begin result1 result2 ...)))))
(define-syntax unless
(syntax-rules ()
((unless test result1 result2 ...)
(if (not test)
(begin result1 result2 ...)))))
(define-syntax letrec*
(syntax-rules ()
((letrec* ((var1 init1) ...) body1 body2 ...)
(let ((var1 #f) ...)
(set! var1 init1)
...
(let () body1 body2 ...)))))

38
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/io.scm Normal file
View File

@@ -0,0 +1,38 @@
(define (call-with-input-file s p) "open an input file s and apply a function to it, then close the file"
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((res (p inport)))
(close-input-port inport)
res))))
(define (call-with-output-file s p) "open an output file s and apply a function to it, then close the file"
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((res (p outport)))
(close-output-port outport)
res))))
(define (with-input-from-file s p) "open an input file s and run a function while it's open"
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((prev-inport (current-input-port)))
(set-input-port inport)
(let ((res (p)))
(close-input-port inport)
(set-input-port prev-inport)
res)))))
(define (with-output-to-file s p) "open an output file s and run a function while it's open"
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((prev-outport (current-output-port)))
(set-output-port outport)
(let ((res (p)))
(close-output-port outport)
(set-output-port prev-outport)
res)))))

68
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/let.scm Normal file
View File

@@ -0,0 +1,68 @@
;; All implementations here are "borrowed" from
;; husk-scheme (github.com/justinethier/husk-scheme).
(define-syntax let
(syntax-rules ()
((_ ((x v) ...) e1 e2 ...)
((lambda (x ...) e1 e2 ...) v ...))
((_ name ((x v) ...) e1 e2 ...)
(let*
((f (lambda (name)
(lambda (x ...) e1 e2 ...)))
(ff ((lambda (proc) (f (lambda (x ...) ((proc proc)
x ...))))
(lambda (proc) (f (lambda (x ...) ((proc proc)
x ...)))))))
(ff v ...)))))
(define-syntax let*
(syntax-rules ()
((let* () body1 body2 ...)
(let () body1 body2 ...))
((let* ((name1 val1) (name2 val2) ...)
body1 body2 ...)
(let ((name1 val1))
(let* ((name2 val2) ...)
body1 body2 ...)))))
(define-syntax letrec
(syntax-rules ()
((letrec ((var1 init1) ...) body ...)
(letrec "generate_temp_names"
(var1 ...)
()
((var1 init1) ...)
body ...))
((letrec "generate_temp_names"
()
(temp1 ...)
((var1 init1) ...)
body ...)
(let ((var1 #f) ...)
(let ((temp1 init1) ...)
(set! var1 temp1)
...
body ...)))
((letrec "generate_temp_names"
(x y ...)
(temp ...)
((var1 init1) ...)
body ...)
(letrec "generate_temp_names"
(y ...)
(newtemp temp ...)
((var1 init1) ...)
body ...))))
(define-syntax do
(syntax-rules ()
((_ ((var init . step) ...)
(test expr ...)
command ...)
(let loop ((var init) ...)
(if test
(begin expr ...)
(begin (begin command ...)
(loop
(if (null? (cdr (list var . step)))
(car (list var . step))
(cadr (list var . step))) ...)))))))

9
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/logical.scm Normal file
View File

@@ -0,0 +1,9 @@
(define (and . lst) "logical and on multiple values" (fold && #t lst))
(define (or . lst) "logical or on multiple values" (fold || #f lst))
(define (not x) "logical not" (if x #f #t))
(define (null? obj) "test for null object"
(if (eqv? obj '())
#t
#f))

124
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/marsaglia.scm Normal file
View File

@@ -0,0 +1,124 @@
; george marsaglia's random number generators,
; taken from http://programmingpraxis.codepad.org/sf8Z4pJP, edited slightly
; for testing the rngs, a test routine is included (test-rng).
; Testing might take a while, though, because do notation is still very slow.
(define (ipow b e)
(cond ((zero? e) 1)
((even? e) (ipow (* b b) (/ e 2)))
(else (* b (ipow (* b b) (/ (- e 1) 2))))))
(define (logand a b)
(if (or (zero? a) (zero? b)) 0
(+ (* (logand (floor (/ a 2)) (floor (/ b 2))) 2)
(if (or (even? a) (even? b)) 0 1))))
(define (logxor a b)
(cond ((zero? a) b)
((zero? b) a)
(else
(+ (* (logxor (floor (/ a 2)) (floor (/ b 2))) 2)
(if (even? a)
(if (even? b) 0 1)
(if (even? b) 1 0))))))
(define (ash int cnt)
(if (negative? cnt)
(let ((n (ipow 2 (- cnt))))
(if (negative? int)
(+ -1 (quotient (+ 1 int) n))
(quotient int n)))
(* (ipow 2 cnt) int)))
(define mwc #f)
(define shr3 #f)
(define cong #f)
(define fib #f)
(define kiss #f)
(define lfib4 #f)
(define swb #f)
(define uni #f)
(define vni #f)
(define settable #f)
(let ((z 362436069) (w 521288629) (jsr 123456789)
(jcong 380116160) (a 224466889) (b 7584631)
(t (make-vector 256 0)) (x 0) (y 0) (c 0))
(define (mod8 n) (modulo n 256))
(define (mod32 n) (modulo n 4294967296))
(define (ref i) (vector-ref t (mod8 i)))
(set! mwc (lambda ()
(set! z (mod32 (+ (* 36969 (logand z 65535)) (ash z -16))))
(set! w (mod32 (+ (* 18000 (logand w 65535)) (ash w -16))))
(mod32 (+ (ash z 16) w))))
(set! shr3 (lambda ()
(set! jsr (mod32 (logxor jsr (ash jsr 17))))
(set! jsr (mod32 (logxor jsr (ash jsr -13))))
(set! jsr (mod32 (logxor jsr (ash jsr 5)))) jsr))
(set! cong (lambda ()
(set! jcong (mod32 (+ (* 69069 jcong) 1234567))) jcong))
(set! fib (lambda ()
(set! b (mod32 (+ a b))) (set! a (mod32 (- b a))) a))
(set! kiss (lambda ()
(mod32 (+ (logxor (mwc) (cong)) (shr3)))))
(set! lfib4 (lambda ()
(set! c (mod8 (+ c 1)))
(vector-set! t c (mod32 (+ (ref c) (ref (+ c 58))
(ref (+ c 119)) (ref (+ c 178))))) (ref c)))
(set! swb (lambda ()
(set! c (mod8 (+ c 1)))
(let ((bro (if (< x y) 1 0)))
(set! x (mod32 (ref (+ c 34))))
(set! y (mod32 (+ (ref (+ c 19)) bro)))
(vector-set! t c (mod32 (- x y)))
(vector-ref t c))))
(set! uni (lambda ()
(* (kiss) 2.328306e-10)))
(set! vni (lambda ()
(* (- (kiss) 2147483648) 4.6566133e-10)))
(set! settable (lambda (i1 i2 i3 i4 i5 i6)
(set! z i1) (set! w i2) (set! jsr i3) (set! jcong i4)
(set! a i5) (set! b i6) (set! x 0) (set! y 0) (set! c 0)
(do ((i 0 (+ i 1))) ((= i 256))
(vector-set! t i (kiss))))))
(define-syntax rng-assert
(syntax-rules ()
((rng-assert expr result)
(if (not (equal? expr result))
(write
'("failed assertion: "
"expected " result
", returned " expr))
(display "test succesful.")))))
(define (test-rng)
(let ((k 0))
(settable 12345 65435 34221 12345 9983651 95746118)
(display "First test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 1064612766)) (set! k (lfib4)))
(display "Second test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 627749721)) (set! k (swb)))
(display "Third test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 1372460312)) (set! k (kiss)))
(display "Fourth test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 1529210297)) (set! k (cong)))
(display "Fifth test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 2642725982)) (set! k (shr3)))
(display "Sixth test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 904977562)) (set! k (mwc)))
(display "Seventh test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 3519793928)) (set! k (fib)))))
;(test-rng)

27
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/math.scm Normal file
View File

@@ -0,0 +1,27 @@
(define exact? integer?)
(define (inexact? x) "is inexact number" (and (real? x) (not (integer? x))))
(define (even? n) "is even" (= (remainder n 2) 0))
(define (odd? n) "is odd" (not (= (remainder n 2) 0)))
(define (zero? n) "is zero" (= n 0))
(define (positive? n) "is positive" (> n 0))
(define (negative? n) "is negative" (< n 0))
(define complex? number?)
(define (abs n) "absolute value of number" (if (>= n 0) n (- n)))
(define (exact->inexact n) "make inexact number from exact" (* n 1.0))
(define (<> n1 n2) "not equal" (not (= n1 n2)))
(define (succ x) "next number" (+ x 1))
(define (pred x) "previous number" (- x 1))
(define (gcd a b) "Greatest Common Divisor"
(let ((aa (abs a))
(bb (abs b)))
(if (= bb 0)
aa
(gcd bb (remainder aa bb)))))
(define (lcm a b) "Least Common Multiple"
(if (or (= a 0) (= b 0))
0
(abs (* (quotient a (gcd a b)) b))))

14
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/module.scm Normal file
View File

@@ -0,0 +1,14 @@
(load "let.scm")
(load "char.scm")
(load "extra.scm")
(load "delay.scm")
(load "io.scm")
(load "logical.scm")
(load "marsaglia.scm")
(load "math.scm")
(load "pairs.scm")
(load "random.scm")
(load "util.scm")
(load "definitions.scm")

28
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/pairs.scm Normal file
View File

@@ -0,0 +1,28 @@
(define (caar pair) (car (car pair)))
(define (cadr pair) (car (cdr pair)))
(define (cdar pair) (cdr (car pair)))
(define (cddr pair) (cdr (cdr pair)))
(define (caaar pair) (car (car (car pair))))
(define (caadr pair) (car (car (cdr pair))))
(define (cadar pair) (car (cdr (car pair))))
(define (cdaar pair) (cdr (car (car pair))))
(define (caddr pair) (car (cdr (cdr pair))))
(define (cdadr pair) (cdr (car (cdr pair))))
(define (cddar pair) (cdr (cdr (car pair))))
(define (cdddr pair) (cdr (cdr (cdr pair))))
(define (caaaar pair) (car (car (car (car pair)))))
(define (caaadr pair) (car (car (car (cdr pair)))))
(define (caadar pair) (car (car (cdr (car pair)))))
(define (caaddr pair) (car (car (cdr (cdr pair)))))
(define (cadaar pair) (car (cdr (car (car pair)))))
(define (cadadr pair) (car (cdr (car (cdr pair)))))
(define (caddar pair) (car (cdr (cdr (car pair)))))
(define (cadddr pair) (car (cdr (cdr (cdr pair)))))
(define (cdaaar pair) (cdr (car (car (car pair)))))
(define (cdaadr pair) (cdr (car (car (cdr pair)))))
(define (cdadar pair) (cdr (car (cdr (car pair)))))
(define (cdaddr pair) (cdr (car (cdr (cdr pair)))))
(define (cddaar pair) (cdr (cdr (car (car pair)))))
(define (cddadr pair) (cdr (cdr (car (cdr pair)))))
(define (cdddar pair) (cdr (cdr (cdr (car pair)))))
(define (cddddr pair) (cdr (cdr (cdr (cdr pair)))))

16
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/random.scm Normal file
View File

@@ -0,0 +1,16 @@
;; This code is taken from:
;; http://stackoverflow.com/questions/14674165/scheme-generate-random
;; It is not to be used in cryptography or related fields.
(define random
(let ((a 69069) (c 1) (m (expt 2 32)) (seed 19380110.0))
(lambda new-seed
(if (pair? new-seed)
(begin (set! seed (car new-seed)))
(begin (set! seed (modulo (+ (* seed a) c) m))))
(/ seed m))))
(define (randint . args) "generate a random integer between the given args(the lower range is optional)"
(cond ((= (length args) 1) (randint 0 (car args)))
((= (length args) 2)
(+ (car args) (floor (* (random) (- (cadr args) (car args))))))
(else (write "usage: (randint [lo] hi)"))))

119
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/sort.scm Normal file
View File

@@ -0,0 +1,119 @@
;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
;;;
;;; This code is in the public domain.
;;; Updated: 11 June 1991
;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
;;; Updated: 19 June 1995
;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09
;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
;;; Modified by Andrew Sorensen for Impromptu 2006-05-10
;;; (cl:sorted? sequence less?)
;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
;;; such that for all 1 <= i <= m,
;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
;@
(define (cl:sorted? seq less?) "returns whether a sequence is sorted"
(cond ((null? seq) #t)
(else (let loop ((last (car seq)) (next (cdr seq)))
(or (null? next)
(and (not (less? (car next) last))
(loop (car next) (cdr next))))))))
;;; (cl:merge a b less?)
;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
;;; and returns a new list in which the elements of a and b have been stably
;;; interleaved so that (sorted? (merge a b less?) less?).
;;; Note: this does _not_ accept arrays. See below.
;@
(define (cl:merge a b less?) "merges two sorted lists"
(cond ((null? a) b)
((null? b) a)
(else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
;; The loop handles the merging of non-empty lists. It has
;; been written this way to save testing and car/cdring.
(if (less? y x)
(if (null? b)
(cons y (cons x a))
(cons y (loop x a (car b) (cdr b))))
;; x <= y
(if (null? a)
(cons x (cons y b))
(cons x (loop (car a) (cdr a) y b))))))))
;;; (cl:merge! a b less?)
;;; takes two sorted lists a and b and smashes their cdr fields to form a
;;; single sorted list including the elements of both.
;;; Note: this does _not_ accept arrays.
;@
(define (cl:merge! a b less?) "merges two sorted lists"
(define (loop r a b)
(if (less? (car b) (car a))
(begin (set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b))))
;; (car a) <= (car b)
(begin (set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b)))))
(cond ((null? a) b)
((null? b) a)
((less? (car b) (car a))
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)))
b)
(else (if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b))
a)))
;;; (cl:sort! sequence less?)
;;; sorts the list, array, or string sequence destructively. It uses
;;; a version of merge-sort invented, to the best of my knowledge, by
;;; David H. D. Warren, and first used in the DEC-10 Prolog system.
;;; R. A. O'Keefe adapted it to work destructively in Scheme.
;@
(define (cl:sort! seq less?) "sorts a sequence destructively; merge-sort"
(define (step n)
(cond ((> n 2)
(let* ((j (quotient n 2))
(a (step j))
(k (- n j))
(b (step k)))
(cl:merge! a b less?)))
((= n 2)
(let ((x (car seq))
(y (cadr seq))
(p seq))
(set! seq (cddr seq))
(cond ((less? y x)
(set-car! p y)
(set-car! (cdr p) x)))
(set-cdr! (cdr p) '())
p))
((= n 1)
(let ((p seq))
(set! seq (cdr seq))
(set-cdr! p '())
p))
(else '())))
(step (length seq)))
;;; (cl:sort sequence less?)
;;; sorts a array, string, or list non-destructively. It does this
;;; by sorting a copy of the sequence. My understanding is that the
;;; Standard says that the result of append is always "newly
;;; allocated" except for sharing structure with "the last argument",
;;; so (append x '()) ought to be a standard way of copying a list x.
;@
(define (cl:sort seq less?) "sorts a sequence non-destructively; merge-sort"
(cond ((vector? seq)
(list->vector (cl:sort! (vector->list seq) less?)))
((string? seq)
(list->string (cl:sort! (string->list seq) less?)))
(else (cl:sort! (append seq '()) less?))))

163
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.5/stdlib/util.scm Normal file
View File

@@ -0,0 +1,163 @@
(define (list . objs) "creates a list from objects"
objs)
(define (id obj) "returns an object"
obj)
(define (flip func) "flips two arguments for a function"
(lambda (arg1 arg2)
(func arg2 arg1)))
(define (list-tail l k) "get tail of a list"
(if (zero? k)
l
(list-tail (cdr l) (- k 1))))
(define (list-ref l k) "get reference to list element at certain point"
(car (list-tail l k)))
(define (append i a) "append something to a list"
(foldr (lambda (ax ix) (cons ax ix)) a i))
(define (curry func arg1) "curry a function"
(lambda (arg)
(func arg1 arg)))
(define (compose f g) "compose two functions"
(lambda (arg)
(f (apply g arg))))
(define (foldr func end l) "fold right"
(if (null? l)
end
(func (car l) (foldr func end (cdr l)))))
(define (foldl func accum l) "fold left"
(if (null? l)
accum
(foldl func (func accum (car l)) (cdr l))))
(define (generate func init pred)
(if (pred init)
(cons init '())
(cons init (unfold func (func init) pred))))
(define (sum . l) "sum of values"
(fold + 0 l))
(define (product . l) "product of values"
(fold * 1 l))
(define (max first . l) "maximum of values"
(fold (lambda (old new)
(if (> old new) old new))
first
l))
(define (min first . l) "minimum of values"
(fold (lambda (old new)
(if (< old new) old new))
first
l))
(define (length l) "length of list"
(fold (lambda (x y)
(+ x 1))
0
l))
(define (reverse l) "reverse list"
(fold (flip cons) '() l))
(define (my-mem-helper obj lst cmp-proc)
(cond
((null? lst) #f)
((cmp-proc obj (car lst)) lst)
(else (my-mem-helper obj (cdr lst) cmp-proc))))
(define (memq obj lst) (my-mem-helper obj lst eq?))
(define (memv obj lst) (my-mem-helper obj lst eqv?))
(define (member obj lst) (my-mem-helper obj lst equal?))
(define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))
(define (assq obj alist) (fold (mem-helper (curry eq? obj) car) #f alist))
(define (assv obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist))
(define (assoc obj alist) (fold (mem-helper (curry equal? obj) car) #f alist))
(define (map func l) "map function to list"
(foldr (lambda (x y)
(cons (func x) y))
'()
l))
(define (foreach func l) "apply function to each element on the list"
(foldl (lambda (x y)
(cons (func x) y))
'()
l))
(define (filter pred l) "filter list through preidcate"
(foldr (lambda (x y)
(if (pred x)
(cons x y)
y))
'()
l))
(define (any? pred lst) "does anything in the list satisfy the predicate?"
(let any* ((l (map pred lst)))
(cond
((null? l) #f)
((car l) #t)
(else
(any* (cdr l))))))
(define (every? pred lst) "do all values in the list satisfy the predicate?"
(let every* ((l (map pred lst)))
(cond
((null? l) #t)
((car l)
(every* (cdr l)))
(else
#f))))
(define all? every?)
(define (case x . cs)
if (== cs ())
("No Case Found")
(if (== x (caar cs))
(cadar cs)
(unpack case (join (list x) (cdr cs)))))
(define (iota n) "makes a list from numbers from 0 to n"
(let ((acc '()))
(do ((i 0 (+ i 1))) ((= i n)) (set! acc (append acc (list i)))) acc))
(define (unzip1-with-cdr . lists)
(unzip1-with-cdr-iterative lists '() '()))
(define (unzip1-with-cdr-iterative lists cars cdrs)
(if (null? lists)
(cons cars cdrs)
(let ((car1 (caar lists))
(cdr1 (cdar lists)))
(unzip1-with-cdr-iterative
(cdr lists)
(append cars (list car1))
(append cdrs (list cdr1))))))
(define (for-each proc . lists) "applies a function to a bunch of arguments"
(if (null? lists)
(apply proc)
(if (null? (car lists))
#t
(let* ((unz (apply unzip1-with-cdr lists))
(cars (car unz))
(cdrs (cdr unz)))
(apply proc cars) (apply map (cons proc cdrs))))))