GaloisInc/cryptol
1
1
Fork 0
mirror of https://github.com/GaloisInc/cryptol.git synced 2025-01-07 08:19:12 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'release/2.2.0' into releases

Browse Source
This commit is contained in:
Adam C. Foltzer 2015-03-24 11:56:16 -07:00
commit 7deef9c8b2
290 changed files with 4692 additions and 16166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
.gitignore vendored
View File

@ -1,4 +1,3 @@
*.pyc
*\#*
*~
.DS_Store
@ -11,7 +10,13 @@ results.xml
#docs/CryptolPrims.pdf
#docs/ProgrammingCryptol.pdf
#docs/Syntax.pdf
d#ocs/Version2Changes.pdf
#docs/Version2Changes.pdf
# don't check in distribution files
cryptol-2.*
cryptol-2.*
# temporary notebook stuff until we split out the repo
/ICryptol/ICryptol-2.*
/ICryptol/profile.tar
/ICryptol/profile_cryptol/security/
/ICryptol/profile_cryptol/startup/

273
HACKING.md Normal file
View File

@ -0,0 +1,273 @@
# Cryptol development
This document explains our standards for developing Cryptol. Our goals
are to have a development process that:
- Consistently yields reliable software artifacts
- Quickly incorporates improvements and gets them into user hands
- Allows new contributors to have an immediate impact
It describes our methods and practices for:
- Testing and continuous integration
- Organizing, branching, and merging this repository
- Producing and publishing release artifacts
- **TODO**: documentation
- **TODO**: feature/release planning, ticket assignment, etc
This is a living document that is not (and possibly cannot be)
comprehensive. If something is missing or unclear, or if you have
suggestions for improving our processes, please file an issue or open
a pull request.
# Testing
Cryptol primarily uses golden testing on the Cryptol interpreter
executable. These tests provide the interpreter with input and then
check the output against an expected output file. We make at least one
test for each new issue, and keep the accumulated tests in our suite
as regression tests. The test suite itself is written using the
`test-framework` library, so it can readily output XML for consumption
by Jenkins and other CI systems.
## Running tests
To run the test suite, run `make test` from the root of the
repository. By default, you'll get output on the console for each test
that fails, either with an explanation for why it failed, or a command
line you can paste in order to compare the test results against the
expected output.
The `make test` target invokes the `cryptol-test-runner` executable,
which is defined in the `/tests/` directory. It is invoked with the
location of the `cryptol` executable, an output directory, and
standard `test-framework` command line arguments. The `test` target in
the `Makefile` provides a template for how to invoke it if you need to
use advanced parameters.
## Creaing a new test
A test consists at minimum of an `.icry` file, which is a batch-mode
file for the interpreter, and an `.icry.stdout` file, which contains
expected output (the "golden" file). As opposed to `.cry` Cryptol
source files, `.icry` files are run by the interpreter line-by-line as
if a user has typed each one in and pressed Enter.
Frequently, one creates an `.icry` file by interactively producing a
desired behavior in the interpreter, and then copying the relevant
lines of input into the file. Remember that, as with unit testing,
golden testing will only test the examples you give it, so make sure
your examples exercise many instances and corner cases of the bug or
feature.
## Expected test failures
We try to keep as few failing tests as possible in the `master`
branch. Usually tests for new features are merged into the `master`
branch in a working state. However if a new bug is reported, we often
write tests for it before it is fixed, particularly if it will take
some time to implement the fix.
To prevent confusion over which tests ought and ought not to be
failing, we add an `.icry.fails` file with an explanatory message
alongside the `.icry` script that defines the test. This will usually
reference an issue number, so that anyone running the test suite will
understand that the reason for the failure is not _their_ changes, but
rather a known issue that is already being handled.
### Example
Issue #6 was a feature request to add let-binding to the
interpreter. @dylanmc gave an example of the input he wanted to be
able to enter, so we created a file `/tests/issues/issue006.icry`
with the contents:
:let timesTwo x = x * 2
:let double x = x + x
:prove \x = timesTwo x == double x
We might not yet know what the expected output should be, so we
created a dummy file `/tests/issues/issue006.icry.stdout`:
TODO: once implemented, do something sensible here
Since this is not the output we got when running the `.icry` file,
this was now a failing test. To prevent confusion, we marked that it
was expected to fail by putting creating a
`/tests/issues/issue006.icry.fails` file with a reference to the
issue:
In development, see issue #6
As the issue progressed and we refined the design, @acfoltzer
implemented the `let` feature and came up with some additional
examples that stretch the legs of the feature further, so we updated
our `.icry` file, this time loading a supplemental `.cry` file so we
could test behavior within a module context.
`issue006.cry`:
f : [32] -> [32]
f x = x + 2
g : [32] -> [32]
g x = f x + 1
`issue006.icry`:
:l issue006.cry
g 5
let f x = 0
g 5
(f : [32] -> [32]) 5
let f x = if (x : [32]) == 0 then 1 else x * (f (x - 1))
f 5
let h x = g x
h 5
Since the feature was now implemented, we could also produce expected
output. The easiest way to do this is to interpret the `.icry` file
using the `-b` flag outside of the test runner, see if the results
look as expected, and then save those results as the new
`.icry.stdout`:
# start with a fresh build
% make
...
# tests are run from within the directory of the .icry file
% cd tests/issues
% ../../.cabal-sandbox/bin/cryptol -b issue006.icry
Loading module Cryptol
Loading module Cryptol
Loading module Main
0x00000008
0x00000008
0x00000000
0x00000078
0x00000008
At this point, it's very important to compare the results you see
against the results you expect from the inputs in the `.icry`
script. Since the results looked correct, we piped the same command
into the matching `.icry.stdout` file and removed the `.icry.fails`
file:
% ../../.cabal-sandbox/bin/cryptol -b issue006.icry.stdout
% rm issue006.icry.fails
Now the test case `issue006` passes, and will (hopefully!) break if
the let-binding feature breaks.
# Repository organization and practices
The top-level repository directories are:
- `/cryptol`: Haskell sources for the front-end `cryptol` executable
and read-eval-print loop
- `/docs`: LaTeX and Markdown sources for the Cryptol documentation
- `/examples`: Cryptol sources implementing several interesting
algorithms
- `/lib`: Cryptol standard library sources
- `/notebook`: Experimental Cryptol IPython Notebook implementation
- `/sbv`: Haskell sources for the `sbv` library, derived from Levent
Erkok's [`sbv` library](http://leventerkok.github.io/sbv/) (see
`/sbv/LICENSE`)
- `/src`: Haskell sources for the `cryptol` library (the bulk of the
implementation)
- `/tests`: Haskell sources for the Cryptol regression test suite, as
well as the Cryptol sources and expected outputs that comprise that
suite
## Branching and merging
Within the `GaloisInc/cryptol` repository, we use the
[git-flow model](http://nvie.com/posts/a-successful-git-branching-model/)
for branches and merging. Our version has two notable differences:
1. Our `master` (rather than `develop`) branch serves as the cutting
edge development branch, and our `release` (rather than `master`)
branch is where only pristine, tagged releases are committed.
2. We use `wip` (work-in-progress) branches as a centralized storage
place for (usually individual) work in progress. Whereas a
`feature` branch is expected to be relatively stable, all bets are
off with a `wip` branch. Typically `wip` branches are not actually
merged directly into `master`, but instead are rebased into a new
branch where the history is cleaned up before merging into
`master`.
In short:
- Any substantial new features should be developed on a branch
prefixed with `feature/`, and then merged into `master` when
completed.
- When we reach a feature freeze for a release, we create a new branch
prefixed with `release/`, for example `release/2.1.0`. When the
release is made, we merge those changes back into `master` and make
a snapshot commit on the `release` branch.
- If a critical bug emerges in already-released software, we create a
branch off of the relevant `release` branch commit prefixed with
`hotfix/2.1.1`. When the hotfix is complete, we merge those changes
back into `master` and make a snapshot commit on the `release`
branch.
# Releases
We take the stability and reliability of our releases very
seriously. To that end, our release process is based on principles of
_automation_, _reproducibility_, and _assurance_ (**TODO**: assurance
the right word here?).
Automation is essential for reducing the possibility of human
error. The checklist for a successful release is fairly lengthy, and
most of the steps need not be done by hand. The real points of
judgment for an individual release are deciding _when_ the codebase is
ready to be released, not _how_ it is released.
Reproducibility is essential for fixing bugs both in hotfixes and
future mainline development. If we cannot reproduce the circumstances
of a release, we might not be able to reproduce bugs that are reported
by users of that release. Bugs are often very particular about the
environment where they will arise, so it is critical to make the
environment of a release consistent.
Assurance is crucial due to the nature of development done with
Cryptol. When people use Cryptol to develop the next generations of
trustworthy systems, we want them to be sure the software was built by
the Cryptol developers, and was not corrupted during download or
replaced by a malicious third party. To this end, we sign our releases
with a [GPG key](http://www.cryptol.net/files/Galois.asc). (**TODO**:
OMG is this really not https?!)
## Cutting releases
**TODO**: make this relevant to folks outside Galois; right now the
build farm exists within the Galois network only, and Galois also
controls the release signing key.
The release process is:
1. Make sure the `release/n.n.n` branch is in a release/ready state,
with successful build artifacts across all platforms on the
relevant Jenkins job. **TODO**: get a Jenkins job running per
release branch, rather than just `master`.
1. Merge the `release/n.n.n` branch into the pristine `release` branch
and add a git tag.
1. Merge the `release/n.n.n` branch back into `master` for future
development, and delete the `release/n.n.n` branch.
1. Run the `cryptol-release` Jenkins job to create a draft
release. Specify the build number with the successful artifacts,
the textual version tag (e.g., "2.1.0"), whether it's a prerelease
(e.g., an alpha), and keep the `DRAFT` option checked.
1. On the Github page for the draft release and add a changelog
(**TODO**: how do we generate changelogs?).
1. (**TODO**: this part of the process needs to be better and
automated) Download the successfully-built artifacts _from
Jenkins_, and in the same directory run the script
`/release-infrastructure/sign.sh` from the `cryptol-internal.git`
repository. You must have the correct GPG key (D3103D7E) for this
to work.
1. Upload the `.sig` files to the draft release on Github.
1. Publish the release and announce it (**TODO**: compile mailing
lists, social media outlets, etc where we should make sure to
announce)

2
LICENSE
View File

@ -1,4 +1,4 @@
Copyright (c) 2013-2014 Galois Inc.
Copyright (c) 2013-2015 Galois Inc.
All rights reserved.
Redistribution and use in source and binary forms, with or without

2
LICENSE.rtf
View File

@ -4,7 +4,7 @@
\margl1440\margr1440\vieww12600\viewh7800\viewkind0
\pard\tx720\tx1440\tx2160\tx2880\tx3600\tx4320\tx5040\tx5760\tx6480\tx7200\tx7920\tx8640\pardirnatural
\f0\fs24 \cf0 Copyright (c) 2013-2014 Galois Inc.\
\f0\fs24 \cf0 Copyright (c) 2013-2015 Galois Inc.\
All rights reserved.\
\
Redistribution and use in source and binary forms, with or without\

219
Makefile
View File

@ -1,20 +1,24 @@
HERE := $(realpath $(dir $(lastword $(MAKEFILE_LIST))))
UNAME := $(shell uname -s)
ARCH := $(shell uname -m)
TESTS ?= issues regression renamer
TESTS ?= issues regression renamer mono-binds
TEST_DIFF ?= meld
CABAL_FLAGS ?= -j
CABAL_BUILD_FLAGS ?= -j
CABAL_INSTALL_FLAGS ?= $(CABAL_BUILD_FLAGS)
CABAL_EXE := cabal
CABAL := $(CABAL_EXE) $(CABAL_FLAGS)
CS := ./.cabal-sandbox
CS_BIN := $(CS)/bin
CABAL := cabal
CABAL_BUILD := $(CABAL) build $(CABAL_BUILD_FLAGS)
CABAL_INSTALL := $(CABAL) install $(CABAL_INSTALL_FLAGS)
CS := $(HERE)/.cabal-sandbox
CS_BIN := $(CS)/bin
# Used only for windows, to find the right Program Files. Right now we
# only cut 32-bit releases.
PROGRAM_FILES = Program\ Files
# Windows installer tools; assumes running on Cygwin and using WiX 3.7
WiX := /cygdrive/c/${PROGRAM_FILES}/WiX\ Toolset\ v3.7
# Used only for windows, to find the right Program Files.
PROGRAM_FILES = Program\ Files\ \(x86\)
# Windows installer tools; assumes running on Cygwin and using WiX 3.8
WiX := /cygdrive/c/${PROGRAM_FILES}/WiX\ Toolset\ v3.8
CANDLE := ${WiX}/bin/candle.exe
HEAT := ${WiX}/bin/heat.exe
LIGHT := ${WiX}/bin/light.exe
@ -29,14 +33,41 @@ ifneq (,$(findstring _NT,${UNAME}))
DIST := ${PKG}.msi
EXE_EXT := .exe
adjust-path = '$(shell cygpath -w $1)'
PREFIX ?=
# For a systemwide distribution .msi, use:
# PREFIX ?= ${PROGRAM_FILES}/Galois/Cryptol\ ${VERSION}
# split this up because `cabal copy` strips drive letters
PREFIX_ABS := /cygdrive/c/${PREFIX}
# since Windows installs aren't overlapping like /usr/local, we
# don't need this extra prefix
PREFIX_SHARE :=
# goes under the share prefix
PREFIX_DOC := /doc
PKG_PREFIX := ${PKG}/${PREFIX}
ROOT_PATH := /cygdrive/c
else
DIST := ${PKG}.tar.gz ${PKG}.zip
EXE_EXT :=
adjust-path = '$1'
PREFIX ?=
# For a systemwide distribution like an .rpm or .pkg, use something like:
# PREFIX ?= /usr/local
PREFIX_ABS := ${PREFIX}
PREFIX_SHARE := /share
# goes under the share prefix
PREFIX_DOC := /doc/cryptol
PKG_PREFIX := ${PKG}${PREFIX}
ROOT_PATH := /
endif
CRYPTOL_EXE := ./dist/build/cryptol/cryptol${EXE_EXT}
.PHONY: all
all: ${CS_BIN}/cryptol
all: ${CRYPTOL_EXE}
.PHONY: run
run: ${CRYPTOL_EXE}
CRYPTOLPATH=$(call adjust-path,$(CURDIR)/lib) ${CRYPTOL_EXE}
.PHONY: docs
docs:
@ -54,48 +85,113 @@ zip: ${PKG}.zip
.PHONY: msi
msi: ${PKG}.msi
# TODO: piece this apart a bit more; if right now if something fails
# during initial setup, you have to invoke this target again manually
${CS}:
$(CABAL_EXE) sandbox init
$(CABAL) sandbox init
# order-only dependency: we just want the sandbox to exist
${CS_BIN}/alex: | ${CS}
$(CABAL) install alex
$(CABAL_INSTALL) alex
# order-only dependency: we just want the sandbox to exist
${CS_BIN}/happy: | ${CS}
$(CABAL) install happy
${CS_BIN}/happy: | ${CS} ${CS_BIN}/alex
$(CABAL_INSTALL) happy
src/GitRev.hs:
sh configure
GIT_INFO_FILES :=
ifneq ("$(wildcard .git/index)","")
GIT_INFO_FILES := ${GIT_INFO_FILES} .git/index
endif
ifneq ("$(wildcard .git/HEAD)","")
GIT_INFO_FILES := ${GIT_INFO_FILES} .git/HEAD
endif
ifneq ("$(wildcard .git/packed-refs)","")
GIT_INFO_FILES := ${GIT_INFO_FILES} .git/packed-refs
endif
# It would be nice to refine these dependencies some in order to avoid
# unnecessary rebuilds, but for now it's safest to just always cabal
# install.
.PHONY: ${CS_BIN}/cryptol
${CS_BIN}/cryptol: ${CS_BIN}/alex ${CS_BIN}/happy | ${CS}
$(CABAL) install .
CRYPTOL_SRC := \
$(shell find src cryptol \
\( -name \*.hs -or -name \*.x -or -name \*.y \) \
-and \( -not -name \*\#\* \) -print) \
$(shell find lib -name \*.cry) \
${GIT_INFO_FILES}
${CS_BIN}/cryptolnb: ${CS_BIN}/alex ${CS_BIN}/happy | ${CS}
$(CABAL) install . -fnotebook
print-%:
@echo $* = $($*)
${PKG}: ${CS_BIN}/cryptol
mkdir -p ${PKG}/bin
mkdir -p ${PKG}/lib
mkdir -p ${PKG}/doc/examples
cp ${CS_BIN}/cryptol ${PKG}/bin/cryptol
cp -R docs/*.md ${PKG}/doc
cp -R docs/*.pdf ${PKG}/doc
cp -R lib/* ${PKG}/lib
cp docs/ProgrammingCryptol/aes/AES.cry ${PKG}/doc/examples
cp docs/ProgrammingCryptol/enigma/Enigma.cry ${PKG}/doc/examples
cp examples/DES.cry ${PKG}/doc/examples
cp examples/Cipher.cry ${PKG}/doc/examples
cp examples/DEStest.cry ${PKG}/doc/examples
cp examples/Test.cry ${PKG}/doc/examples
cp examples/SHA1.cry ${PKG}/doc/examples
cp examples/contrib/simon.cry ${PKG}/doc/examples/contrib
cp examples/contrib/speck.cry ${PKG}/doc/examples/contrib
cp LICENSE ${PKG}/doc
# We do things differently based on whether we have a PREFIX set by
# the user. If we do, then we know the eventual path it'll wind up in
# (useful for stuff like RPMs or Homebrew). If not, we try to be as
# relocatable as possible.
ifneq (,${PREFIX})
PREFIX_ARG := --prefix=$(call adjust-path,${PREFIX_ABS})
DESTDIR_ARG := --destdir=${PKG}
CONFIGURE_ARGS := -f-relocatable -f-self-contained \
--docdir=$(call adjust-path,${PREFIX_SHARE}/${PREFIX_DOC})
else
# This is kind of weird: 1. Prefix argument must be absolute; Cabal
# doesn't yet fully support relocatable packages. 2. We have to
# provide *some* prefix here even if we're not using it, otherwise
# `cabal copy` will make a mess in the PKG directory.
PREFIX_ARG := --prefix=$(call adjust-path,${ROOT_PATH})
DESTDIR_ARG := --destdir=${PKG}
CONFIGURE_ARGS := -f-self-contained \
--docdir=$(call adjust-path,${PREFIX_SHARE}/${PREFIX_DOC})
endif
dist/setup-config: cryptol.cabal Makefile | ${CS_BIN}/alex ${CS_BIN}/happy
$(CABAL_INSTALL) --only-dependencies
$(CABAL) configure ${PREFIX_ARG} --datasubdir=cryptol \
${CONFIGURE_ARGS}
${CRYPTOL_EXE}: $(CRYPTOL_SRC) dist/setup-config
$(CABAL_BUILD)
PKG_BIN := ${PKG_PREFIX}/bin
PKG_SHARE := ${PKG_PREFIX}${PREFIX_SHARE}
PKG_CRY := ${PKG_SHARE}/cryptol
PKG_DOC := ${PKG_SHARE}${PREFIX_DOC}
PKG_EXAMPLES := ${PKG_DOC}/examples
PKG_EXCONTRIB := ${PKG_EXAMPLES}/contrib
PKG_EXAMPLE_FILES := docs/ProgrammingCryptol/aes/AES.cry \
docs/ProgrammingCryptol/enigma/Enigma.cry \
examples/DES.cry \
examples/Cipher.cry \
examples/DEStest.cry \
examples/Test.cry \
examples/SHA1.cry \
PKG_EXCONTRIB_FILES := examples/contrib/mkrand.cry \
examples/contrib/RC4.cry \
examples/contrib/simon.cry \
examples/contrib/speck.cry
${PKG}: ${CRYPTOL_EXE} \
docs/*.md docs/*.pdf LICENSE LICENSE.rtf \
${PKG_EXAMPLE_FILES} ${PKG_EXCONTRIB_FILES}
$(CABAL) copy ${DESTDIR_ARG}
mkdir -p ${PKG_CRY}
mkdir -p ${PKG_DOC}
mkdir -p ${PKG_EXAMPLES}
mkdir -p ${PKG_EXCONTRIB}
cp docs/*.md ${PKG_DOC}
cp docs/*.pdf ${PKG_DOC}
for EXAMPLE in ${PKG_EXAMPLE_FILES}; do \
cp $$EXAMPLE ${PKG_EXAMPLES}; done
for EXAMPLE in ${PKG_EXCONTRIB_FILES}; do \
cp $$EXAMPLE ${PKG_EXCONTRIB}; done
# cleanup unwanted files
# don't want to bundle the cryptol library in the binary distribution
rm -rf ${PKG_PREFIX}/lib; rm -rf ${PKG_PREFIX}/*windows-ghc*
.PHONY: install
install: ${PKG}
[ -n "${PREFIX}" ] \
|| (echo "[error] Can't install without PREFIX set"; false)
(cd ${PKG_PREFIX}; \
find . -type d -exec install -d ${PREFIX}/{} \; ; \
find bin -not -type d -exec install -m 755 {} ${PREFIX}/{} \; ; \
find share -not -type d -exec install -m 644 {} ${PREFIX}/{} \;)
${PKG}.tar.gz: ${PKG}
tar -czvf $@ $<
@ -104,44 +200,41 @@ ${PKG}.zip: ${PKG}
zip -r $@ $<
${PKG}.msi: ${PKG} win32/cryptol.wxs
${HEAT} dir ${PKG} -o allfiles.wxs -nologo -var var.pkg -ag -wixvar -cg ALLFILES -srd -dr INSTALLDIR -sfrag
${CANDLE} -ext WixUIExtension -ext WixUtilExtension -dversion=${VERSION} -dpkg=${PKG} win32/cryptol.wxs
${CANDLE} -ext WixUIExtension -ext WixUtilExtension -dversion=${VERSION} -dpkg=${PKG} allfiles.wxs
${LIGHT} -ext WixUIExtension -ext WixUtilExtension -sval -o $@ cryptol.wixobj allfiles.wixobj
${HEAT} dir ${PKG_PREFIX} -o allfiles.wxs -nologo -var var.pkg \
-ag -wixvar -cg ALLFILES -srd -dr INSTALLDIR -sfrag
${CANDLE} -ext WixUIExtension -ext WixUtilExtension \
-dversion=${VERSION} -dpkg=${PKG_PREFIX} win32/cryptol.wxs
${CANDLE} -ext WixUIExtension -ext WixUtilExtension \
-dversion=${VERSION} -dpkg=${PKG_PREFIX} allfiles.wxs
${LIGHT} -ext WixUIExtension -ext WixUtilExtension \
-sval -o $@ cryptol.wixobj allfiles.wixobj
rm -f allfiles.wxs
rm -f *.wixobj
rm -f *.wixpdb
${CS_BIN}/cryptol-test-runner: \
$(CS_BIN)/cryptol \
${PKG} \
$(CURDIR)/tests/Main.hs \
$(CURDIR)/tests/cryptol-test-runner.cabal
$(CABAL) install ./tests
$(CABAL_INSTALL) ./tests
.PHONY: test
test: ${CS_BIN}/cryptol-test-runner
( cd tests && \
echo "Testing on $(UNAME)-$(ARCH)" && \
$(realpath $(CS_BIN)/cryptol-test-runner) \
$(foreach t,$(TESTS),-d $t) \
-c $(call adjust-path,$(realpath $(CS_BIN)/cryptol$(EXE_EXT))) \
$(TESTS) \
-c $(call adjust-path,${CURDIR}/${PKG_BIN}/cryptol${EXE_EXT}) \
-r output \
-T --hide-successes \
-T --jxml=$(call adjust-path,$(CURDIR)/results.xml) \
$(if $(TEST_DIFF),-p $(TEST_DIFF),) \
)
.PHONY: notebook
notebook: ${CS_BIN}/cryptolnb
cd notebook && ./notebook.sh
.PHONY: clean
clean:
cabal clean
rm -f src/GitRev.hs
rm -f $(CS_BIN)/cryptol
rm -f $(CS_BIN)/cryptol-test-suite
rm -f $(CS_BIN)/cryptolnb
rm -rf cryptol-${VERSION}*/
rm -rf cryptol-${VERSION}*.tar.gz
rm -rf cryptol-${VERSION}*.zip
@ -149,7 +242,7 @@ clean:
.PHONY: squeaky
squeaky: clean
-$(CABAL_EXE) sandbox delete
-$(CABAL) sandbox delete
(cd docs; make clean)
rm -rf dist
rm -rf tests/dist

76
README.md
View File

@ -1,6 +1,6 @@
# Cryptol, version 2
This version of Cryptol is (C) 2013-2014 Galois, Inc., and
This version of Cryptol is (C) 2013-2015 Galois, Inc., and
distributed under a standard, three-clause BSD license. Please see
the file LICENSE, distributed with this software, for specific
terms and conditions.
@ -56,23 +56,10 @@ Windows. We regularly build and test it in the following environments:
## Prerequisites
Cryptol is developed using GHC 7.6.3 and cabal-install 1.18. While you
can install these independently, the easiest way to get the correct
versions is to:
1. Install [Haskell Platform 2013.2.0.0](http://www.haskell.org/platform/)
**Mac Users**: the current version of the Haskell Platform has
some incompatibilities with Mac OS X 10.9; it is easier to install
GHC, cabal-install, alex, and happy from
[MacPorts](https://www.macports.org/) or
[Homebrew](http://brew.sh/).
1. Run `cabal update`
1. Run `cabal install cabal-install`
1. Add cabal-install's binary path to your `PATH` variable (usually `~/.cabal/bin`)
Cryptol is developed using GHC 7.8.4 and cabal-install 1.22. The
easiest way to get the correct versions is to follow the instructions
on the
[haskell.org downloads page](https://www.haskell.org/downloads).
Some supporting non-Haskell libraries are required to build
Cryptol. Most should already be present for your operating system, but
@ -91,6 +78,7 @@ From the Cryptol source directory, run:
This will build Cryptol in place. From there, there are additional targets:
- `make run`: run Cryptol in the current directory
- `make test`: run the regression test suite (note: 4 failures is expected)
- `make docs`: build the Cryptol documentation (requires
[pandoc](http://johnmacfarlane.net/pandoc/) and
@ -99,36 +87,16 @@ This will build Cryptol in place. From there, there are additional targets:
- `make dist`: build a platform-specific distribution. On all
platforms except Windows, this is currently equivalent to `make
tarball`. On Windows, this will build an `.msi` package using
[WiX Toolset 3.7](http://wixtoolset.org/), which must be installed
[WiX Toolset 3.8](http://wixtoolset.org/), which must be installed
separately.
## Installing Cryptol
Aside from the `docs` target, these will leave you with a Cryptol
binary at `.cabal-sandbox/bin/cryptol` in your source directory. You
can either use that binary directly, or use the results of `tarball`
or `dist` to install Cryptol in a location of your choice.
# Checking your Installation
Run Cryptol, and at the prompt type:
Cryptol> :prove True
If Cryptol responds
Q.E.D.
then Cryptol is installed correctly. If it prints something like
*** An error occurred.
*** Unable to locate executable for cvc4
*** Executable specified: "cvc4"
then make sure you've installed [CVC4](#getting-cvc4), and that the
binary is on your `PATH`.
As noted above, `make test` currently results in four failures. An issue has been filed on GitHub for each of them.
If you run `cabal install` in your source directory after running one
of these `make` targets, you will end up with a binary in
`.cabal-sandbox/bin/cryptol`. You can either use that binary directly,
or use the results of `tarball` or `dist` to install Cryptol in a
location of your choice.
# Contributing
@ -153,10 +121,12 @@ send email to <cryptol@galois.com>.
## Developers
If you plan to do development work on the Cryptol interpreter, please
make a fork of the GitHub repository and send along pull
requests. This makes it easier for us to track development and to
incorporate your changes.
If you'd like to get involved with Cryptol development, see the list
of
[low-hanging fruit](https://github.com/GaloisInc/cryptol/labels/low-hanging%20fruit). These
are tasks which should be straightforward to implement. Make a
fork of this GitHub repository and send along pull requests, and we'll
be happy to incorporate your changes.
### Repository Structure
@ -166,16 +136,16 @@ incorporate your changes.
- `/examples`: Cryptol sources implementing several interesting
algorithms
- `/lib`: Cryptol standard library sources
- `/notebook`: Experimental Cryptol IPython Notebook implementation
- `/sbv`: Haskell sources for the `sbv` library, derived from Levent
Erkok's [`sbv` library](http://leventerkok.github.io/sbv/) (see
`/sbv/LICENSE`)
- `/src`: Haskell sources for the `cryptol` library (the bulk of the
implementation)
- `/tests`: Haskell sources for the Cryptol regression test suite, as
well as the Cryptol sources and expected outputs that comprise that
suite
### Cryptol Notebook (Experimental)
The ICryptol notebook interface is now a
[standalone project](https://github.com/GaloisInc/ICryptol).
# Where to Look Next
@ -219,5 +189,3 @@ Cryptol has been funded by, and lots of design input was provided by
the team at the
[NSA's Trusted Systems Research Group](http://www.nsa.gov/research/ia_research/),
including Brad Martin, Frank Taylor and Sean Weaver.

2
Setup.hs
View File

@ -1,6 +1,6 @@
-- |
-- Module : $Header$
-- Copyright : (c) 2013-2014 Galois, Inc.
-- Copyright : (c) 2013-2015 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional

866
cabal.config Normal file
View File

@ -0,0 +1,866 @@
-- Stackage snapshot from: http://www.stackage.org/snapshot/lts-1.12
-- Please place this file next to your .cabal file as cabal.config
-- To only use tested packages, uncomment the following line:
-- remote-repo: stackage-lts-1.12:http://www.stackage.org/snapshot/lts-1.12
constraints: abstract-deque ==0.3,
abstract-par ==0.3.3,
accelerate ==0.15.0.0,
ace ==0.6,
action-permutations ==0.0.0.1,
active ==0.1.0.18,
AC-Vector ==2.3.2,
ad ==4.2.1.1,
adjunctions ==4.2,
aeson ==0.8.0.2,
aeson-pretty ==0.7.2,
aeson-qq ==0.7.4,
aeson-utils ==0.2.2.1,
alarmclock ==0.2.0.5,
alex ==3.1.4,
amqp ==0.10.1,
ansi-terminal ==0.6.2.1,
ansi-wl-pprint ==0.6.7.1,
appar ==0.1.4,
approximate ==0.2.1.1,
arbtt ==0.8.1.4,
arithmoi ==0.4.1.1,
array installed,
arrow-list ==0.6.1.5,
asn1-data ==0.7.1,
asn1-encoding ==0.9.0,
asn1-parse ==0.9.0,
asn1-types ==0.3.0,
async ==2.0.2,
atto-lisp ==0.2.2,
attoparsec ==0.12.1.3,
attoparsec-conduit ==1.1.0,
attoparsec-enumerator ==0.3.3,
attoparsec-expr ==0.1.1.1,
authenticate ==1.3.2.11,
auto-update ==0.1.2.1,
aws ==0.11.2,
bake ==0.2,
bank-holidays-england ==0.1.0.2,
barecheck ==0.2.0.6,
base installed,
base16-bytestring ==0.1.1.6,
base64-bytestring ==1.0.0.1,
base-compat ==0.5.0,
base-prelude ==0.1.16,
base-unicode-symbols ==0.2.2.4,
basic-prelude ==0.3.11.1,
bifunctors ==4.2.1,
binary installed,
binary-conduit ==1.2.3,
binary-list ==1.0.1.0,
bindings-DSL ==1.0.22,
bioace ==0.0.1,
bioalign ==0.0.5,
biocore ==0.3.1,
biofasta ==0.0.3,
biofastq ==0.1,
biophd ==0.0.5,
biopsl ==0.4,
biosff ==0.3.7.1,
bits ==0.4,
BlastHTTP ==1.0.1,
blastxml ==0.3.2,
blaze-builder ==0.3.3.4,
blaze-builder-enumerator ==0.2.0.6,
blaze-html ==0.7.1.0,
blaze-markup ==0.6.3.0,
blaze-svg ==0.3.4.1,
blaze-textual ==0.2.0.9,
BlogLiterately ==0.7.1.7,
BlogLiterately-diagrams ==0.1.4.3,
bloodhound ==0.5.0.1,
bmp ==1.2.5.2,
Boolean ==0.2.3,
bool-extras ==0.4.0,
bound ==1.0.4,
BoundedChan ==1.0.3.0,
broadcast-chan ==0.1.0,
bson ==0.3.1,
bumper ==0.6.0.3,
byteable ==0.1.1,
bytedump ==1.0,
byteorder ==1.0.4,
bytes ==0.14.1.3,
bytestring installed,
bytestring-builder ==0.10.4.1.2,
bytestring-lexing ==0.4.3.2,
bytestring-mmap ==0.2.2,
bytestring-progress ==1.0.3,
bytestring-show ==0.3.5.6,
bytestring-trie ==0.2.4,
bzlib ==0.5.0.5,
bzlib-conduit ==0.2.1.3,
c2hs ==0.20.1,
Cabal installed,
cabal-install ==1.18.0.8,
cabal-src ==0.2.5,
cairo ==0.13.1.0,
case-insensitive ==1.2.0.4,
cases ==0.1.2,
cassava ==0.4.2.2,
cautious-file ==1.0.2,
cereal ==0.4.1.1,
cereal-conduit ==0.7.2.3,
certificate ==1.3.9,
charset ==0.3.7,
Chart ==1.3.3,
Chart-diagrams ==1.3.3,
ChasingBottoms ==1.3.0.11,
check-email ==1.0,
checkers ==0.4.1,
chell ==0.4.0.1,
chell-quickcheck ==0.2.4,
chunked-data ==0.1.0.1,
cipher-aes ==0.2.10,
cipher-blowfish ==0.0.3,
cipher-camellia ==0.0.2,
cipher-des ==0.0.6,
cipher-rc4 ==0.1.4,
circle-packing ==0.1.0.4,
classy-prelude ==0.10.5,
classy-prelude-conduit ==0.10.5,
classy-prelude-yesod ==0.10.5,
clientsession ==0.9.1.1,
clock ==0.4.1.3,
cmdargs ==0.10.12,
code-builder ==0.1.3,
colour ==2.3.3,
comonad ==4.2.4,
comonads-fd ==4.0,
comonad-transformers ==4.0,
compdata ==0.9,
compensated ==0.6.1,
composition ==1.0.1.0,
compressed ==3.10,
concatenative ==1.0.1,
concurrent-extra ==0.7.0.9,
concurrent-supply ==0.1.7,
cond ==0.4.1.1,
conduit ==1.2.4,
conduit-combinators ==0.3.0.6,
conduit-extra ==1.1.7.1,
configurator ==0.3.0.0,
connection ==0.2.4,
constraints ==0.4.1.3,
containers installed,
containers-unicode-symbols ==0.3.1.1,
contravariant ==1.2.2.1,
control-monad-free ==0.5.3,
control-monad-loop ==0.1,
convertible ==1.1.0.0,
cookie ==0.4.1.4,
courier ==0.1.0.15,
cpphs ==1.18.9,
cprng-aes ==0.6.1,
cpu ==0.1.2,
criterion ==1.0.2.0,
crypto-api ==0.13.2,
cryptocipher ==0.6.2,
crypto-cipher-tests ==0.0.11,
crypto-cipher-types ==0.0.9,
cryptohash ==0.11.6,
cryptohash-conduit ==0.1.1,
cryptohash-cryptoapi ==0.1.3,
crypto-numbers ==0.2.7,
crypto-pubkey ==0.2.8,
crypto-pubkey-types ==0.4.3,
crypto-random ==0.0.8,
crypto-random-api ==0.2.0,
css-text ==0.1.2.1,
csv ==0.1.2,
csv-conduit ==0.6.3,
curl ==1.3.8,
data-accessor ==0.2.2.6,
data-accessor-mtl ==0.2.0.4,
data-binary-ieee754 ==0.4.4,
data-default ==0.5.3,
data-default-class ==0.0.1,
data-default-instances-base ==0.0.1,
data-default-instances-containers ==0.0.1,
data-default-instances-dlist ==0.0.1,
data-default-instances-old-locale ==0.0.1,
data-inttrie ==0.1.0,
data-lens-light ==0.1.2.1,
data-memocombinators ==0.5.1,
data-reify ==0.6,
DAV ==1.0.3,
Decimal ==0.4.2,
deepseq installed,
deepseq-generics ==0.1.1.2,
derive ==2.5.21,
diagrams ==1.2,
diagrams-builder ==0.6.0.3,
diagrams-cairo ==1.2.0.6,
diagrams-contrib ==1.1.2.5,
diagrams-core ==1.2.0.5,
diagrams-haddock ==0.2.2.13,
diagrams-lib ==1.2.0.8,
diagrams-postscript ==1.1.0.4,
diagrams-svg ==1.1.0.4,
Diff ==0.3.0,
digest ==0.0.1.2,
digestive-functors ==0.7.1.4,
dimensional ==0.13.0.1,
directory installed,
directory-tree ==0.12.0,
direct-sqlite ==2.3.15,
distributed-process ==0.5.3,
distributed-process-async ==0.2.1,
distributed-process-client-server ==0.1.2,
distributed-process-execution ==0.1.1,
distributed-process-extras ==0.2.0,
distributed-process-simplelocalnet ==0.2.2.0,
distributed-process-supervisor ==0.1.2,
distributed-process-task ==0.1.1,
distributed-static ==0.3.1.0,
distributive ==0.4.4,
djinn-ghc ==0.0.2.3,
djinn-lib ==0.0.1.2,
dlist ==0.7.1,
dlist-instances ==0.1,
doctest ==0.9.13,
double-conversion ==2.0.1.0,
dual-tree ==0.2.0.5,
easy-file ==0.2.0,
either ==4.3.3.2,
elm-build-lib ==0.14.0.0,
elm-compiler ==0.14.1,
elm-core-sources ==1.0.0,
elm-package ==0.2.2,
email-validate ==2.0.1,
enclosed-exceptions ==1.0.1,
entropy ==0.3.6,
enumerator ==0.4.20,
eq ==4.0.3,
erf ==2.0.0.0,
errorcall-eq-instance ==0.1.0,
errors ==1.4.7,
ersatz ==0.2.6.1,
esqueleto ==2.1.2.1,
exceptions ==0.6.1,
exception-transformers ==0.3.0.4,
executable-path ==0.0.3,
extensible-exceptions ==0.1.1.4,
extra ==1.0.1,
failure ==0.2.0.3,
fast-logger ==2.2.3,
fay ==0.21.2.1,
fay-base ==0.19.4.2,
fay-builder ==0.2.0.3,
fay-dom ==0.5.0.1,
fay-jquery ==0.6.0.3,
fay-text ==0.3.2.2,
fay-uri ==0.2.0.0,
fb ==1.0.8,
fb-persistent ==0.3.4,
fclabels ==2.0.2.2,
FenwickTree ==0.1.2,
fgl ==5.5.1.0,
file-embed ==0.0.8.2,
file-location ==0.4.6,
filemanip ==0.3.6.3,
filepath installed,
fingertree ==0.1.0.1,
fixed ==0.2.1.1,
fixed-list ==0.1.5,
flexible-defaults ==0.0.1.1,
focus ==0.1.3,
foldl ==1.0.7,
FontyFruity ==0.4.1,
force-layout ==0.3.0.10,
foreign-store ==0.1,
foreign-var ==0.0.0.1,
formatting ==6.0.0,
fpco-api ==1.2.0.5,
free ==4.10.0.1,
freenect ==1.2,
frisby ==0.2,
fsnotify ==0.1.0.3,
fuzzcheck ==0.1.1,
gd ==3000.7.3,
generic-aeson ==0.2.0.2,
generic-deriving ==1.6.3,
GenericPretty ==1.2.1,
generics-sop ==0.1.1,
ghc-heap-view ==0.5.3,
ghcid ==0.3.4,
ghc-mod ==5.2.1.2,
ghc-mtl ==1.2.1.0,
ghc-paths ==0.1.0.9,
ghc-prim installed,
ghc-syb-utils ==0.2.3,
gio ==0.13.0.4,
git-embed ==0.1.0,
gl ==0.6.3,
glib ==0.13.1.0,
Glob ==0.7.5,
GLURaw ==1.4.0.2,
GLUT ==2.5.1.1,
graph-core ==0.2.1.0,
graphs ==0.5.0.1,
gravatar ==0.6,
groundhog ==0.7.0.2,
groundhog-mysql ==0.7.0.1,
groundhog-postgresql ==0.7.0.2,
groundhog-sqlite ==0.7.0.1,
groundhog-th ==0.7.0,
groupoids ==4.0,
groups ==0.4.0.0,
gtk ==0.13.4,
gtk2hs-buildtools ==0.13.0.3,
haddock-api ==2.15.0.2,
haddock-library ==1.1.1,
half ==0.2.0.1,
HandsomeSoup ==0.3.5,
happstack-server ==7.3.9,
happy ==1.19.5,
hashable ==1.2.3.1,
hashable-extras ==0.2.0.1,
hashmap ==1.3.0.1,
hashtables ==1.2.0.2,
haskeline installed,
haskell2010 installed,
haskell98 installed,
haskell-lexer ==1.0,
haskell-names ==0.4.1,
haskell-packages ==0.2.4.4,
haskell-src ==1.0.2.0,
haskell-src-exts ==1.16.0.1,
haskell-src-meta ==0.6.0.8,
hasql ==0.7.2,
hasql-backend ==0.4.0,
hasql-postgres ==0.10.2,
hastache ==0.6.1,
HaTeX ==3.16.0.0,
HaXml ==1.25.3,
haxr ==3000.10.3.1,
HCodecs ==0.5,
hdaemonize ==0.5.0.0,
hdevtools ==0.1.0.6,
heaps ==0.3.2,
hebrew-time ==0.1.1,
heist ==0.14.1,
here ==1.2.7,
heredoc ==0.2.0.0,
hflags ==0.4,
highlighting-kate ==0.5.11.1,
hinotify ==0.3.7,
hint ==0.4.2.2,
histogram-fill ==0.8.4.1,
hit ==0.6.3,
hjsmin ==0.1.4.7,
hledger ==0.24,
hledger-lib ==0.24,
hlibgit2 ==0.18.0.14,
hlint ==1.9.16,
hmatrix ==0.16.1.4,
hmatrix-gsl ==0.16.0.3,
hoauth2 ==0.4.3,
holy-project ==0.1.1.1,
hoogle ==4.2.38,
hoopl installed,
hOpenPGP ==1.11,
hostname ==1.0,
hostname-validate ==1.0.0,
hourglass ==0.2.8,
hpc installed,
hPDB ==1.2.0.2,
hPDB-examples ==1.2.0.1,
hs-bibutils ==5.5,
hscolour ==1.20.3,
hse-cpp ==0.1,
hslogger ==1.2.8,
hslua ==0.3.13,
hspec ==2.1.4,
hspec2 ==0.6.1,
hspec-core ==2.1.4,
hspec-discover ==2.1.4,
hspec-expectations ==0.6.1.1,
hspec-meta ==2.0.0,
hspec-wai ==0.6.3,
hspec-wai-json ==0.6.0,
HStringTemplate ==0.7.3,
hsyslog ==2.0,
HTF ==0.12.2.3,
html ==1.0.1.2,
html-conduit ==1.1.1.1,
HTTP ==4000.2.19,
http-client ==0.4.8.1,
http-client-tls ==0.2.2,
http-conduit ==2.1.5,
http-date ==0.0.5,
http-reverse-proxy ==0.4.1.2,
http-types ==0.8.6,
HUnit ==1.2.5.2,
hweblib ==0.6.3,
hxt ==9.3.1.15,
hxt-charproperties ==9.2.0.1,
hxt-http ==9.1.5.2,
hxt-pickle-utils ==0.1.0.2,
hxt-regex-xmlschema ==9.2.0.2,
hxt-relaxng ==9.1.5.5,
hxt-unicode ==9.0.2.4,
hybrid-vectors ==0.1.2.1,
hyphenation ==0.4.2.1,
idna ==0.3.0,
ieee754 ==0.7.6,
IfElse ==0.85,
imagesize-conduit ==1.0.0.4,
immortal ==0.2,
incremental-parser ==0.2.3.4,
indents ==0.3.3,
ini ==0.3.1,
integer-gmp installed,
integration ==0.2.1,
interpolate ==0.1.0,
interpolatedstring-perl6 ==0.9.0,
intervals ==0.7.1,
io-choice ==0.0.5,
io-manager ==0.1.0.2,
io-memoize ==1.1.1.0,
iproute ==1.3.1,
iterable ==3.0,
ixset ==1.0.6,
js-flot ==0.8.3,
js-jquery ==1.11.2,
json-autotype ==0.2.5.8,
json-schema ==0.7.3.1,
JuicyPixels ==3.2.3,
JuicyPixels-repa ==0.7,
kan-extensions ==4.2.1,
kdt ==0.2.2,
keter ==1.3.9.1,
keys ==3.10.1,
kure ==2.16.8,
language-c ==0.4.7,
language-ecmascript ==0.16.2,
language-glsl ==0.1.1,
language-haskell-extract ==0.2.4,
language-java ==0.2.7,
language-javascript ==0.5.13.3,
lazy-csv ==0.5,
lca ==0.2.4,
lens ==4.6.0.1,
lens-aeson ==1.0.0.3,
lens-family-th ==0.4.1.0,
lhs2tex ==1.18.1,
libgit ==0.3.0,
libnotify ==0.1.1.0,
lifted-async ==0.2.0.2,
lifted-base ==0.2.3.6,
linear ==1.15.5,
linear-accelerate ==0.2,
list-t ==0.4.3,
loch-th ==0.2.1,
log-domain ==0.9.3,
logfloat ==0.12.1,
logict ==0.6.0.2,
loop ==0.2.0,
lucid ==2.5,
lzma-conduit ==1.1.3,
machines ==0.4.1,
mandrill ==0.1.1.0,
map-syntax ==0.2,
markdown ==0.1.13.1,
markdown-unlit ==0.2.0.1,
math-functions ==0.1.5.2,
matrix ==0.3.4.2,
MaybeT ==0.1.2,
MemoTrie ==0.6.2,
mersenne-random-pure64 ==0.2.0.4,
messagepack ==0.3.0,
messagepack-rpc ==0.1.0.3,
mime-mail ==0.4.8.1,
mime-mail-ses ==0.3.2.2,
mime-types ==0.1.0.5,
missing-foreign ==0.1.1,
MissingH ==1.3.0.1,
mmap ==0.5.9,
mmorph ==1.0.4,
MonadCatchIO-transformers ==0.3.1.3,
monad-control ==0.3.3.1,
monad-coroutine ==0.8.0.1,
monadcryptorandom ==0.6.1,
monad-extras ==0.5.9,
monadic-arrays ==0.2.1.3,
monad-journal ==0.6.0.2,
monad-logger ==0.3.13.1,
monad-loops ==0.4.2.1,
monad-par ==0.3.4.7,
monad-parallel ==0.7.1.4,
monad-par-extras ==0.3.3,
monad-primitive ==0.1,
monad-products ==4.0.0.1,
MonadPrompt ==1.0.0.5,
MonadRandom ==0.3.0.1,
monad-st ==0.2.4,
monads-tf ==0.1.0.2,
mongoDB ==2.0.3,
monoid-extras ==0.3.3.5,
monoid-subclasses ==0.3.6.2,
mono-traversable ==0.7.0,
mtl ==2.1.3.1,
mtlparse ==0.1.4.0,
mtl-prelude ==1.0.3,
multimap ==1.2.1,
multipart ==0.1.2,
MusicBrainz ==0.2.3,
mutable-containers ==0.2.1.2,
mwc-random ==0.13.3.0,
mysql ==0.1.1.7,
mysql-simple ==0.2.2.4,
nanospec ==0.2.0,
nats ==1,
neat-interpolation ==0.2.2,
nettle ==0.1.0,
network ==2.6.0.2,
network-conduit-tls ==1.1.1,
network-info ==0.2.0.5,
network-multicast ==0.0.11,
network-simple ==0.4.0.4,
network-transport ==0.4.1.0,
network-transport-tcp ==0.4.1,
network-transport-tests ==0.2.2.0,
network-uri ==2.6.0.1,
newtype ==0.2,
nsis ==0.2.4,
numbers ==3000.2.0.1,
numeric-extras ==0.0.3,
NumInstances ==1.4,
numtype ==1.1,
Octree ==0.5.4.2,
old-locale installed,
old-time installed,
OneTuple ==0.2.1,
opaleye ==0.3.1,
OpenGL ==2.9.2.0,
OpenGLRaw ==1.5.0.1,
openpgp-asciiarmor ==0.1,
operational ==0.2.3.2,
options ==1.2.1.1,
optparse-applicative ==0.11.0.2,
osdkeys ==0.0,
pandoc ==1.13.2,
pandoc-citeproc ==0.6,
pandoc-types ==1.12.4.1,
pango ==0.13.0.5,
parallel ==3.2.0.6,
parallel-io ==0.3.3,
parseargs ==0.1.5.2,
parsec ==3.1.8,
parsers ==0.12.1.1,
partial-handler ==0.1.0,
path-pieces ==0.1.5,
patience ==0.1.1,
pcre-light ==0.4.0.3,
pdfinfo ==1.5.2,
pem ==0.2.2,
persistent ==2.1.1.7,
persistent-mongoDB ==2.1.2.1,
persistent-mysql ==2.1.2.1,
persistent-postgresql ==2.1.2.2,
persistent-sqlite ==2.1.1.2,
persistent-template ==2.1.0.1,
phantom-state ==0.2.0.2,
pipes ==4.1.4,
pipes-concurrency ==2.0.3,
pipes-parse ==3.0.2,
placeholders ==0.1,
pointed ==4.2,
polyparse ==1.10,
pool-conduit ==0.1.2.3,
postgresql-binary ==0.5.1,
postgresql-libpq ==0.9.0.2,
postgresql-simple ==0.4.10.0,
pqueue ==1.2.1,
prefix-units ==0.1.0.2,
prelude-extras ==0.4,
present ==2.2,
pretty installed,
prettyclass ==1.0.0.0,
pretty-class ==1.0.1.1,
pretty-show ==1.6.8.2,
primes ==0.2.1.0,
primitive ==0.5.4.0,
process installed,
process-conduit ==1.2.0.1,
process-extras ==0.2.0,
product-profunctors ==0.6,
profunctor-extras ==4.0,
profunctors ==4.3.2,
project-template ==0.1.4.2,
publicsuffixlist ==0.1,
punycode ==2.0,
pure-io ==0.2.1,
pureMD5 ==2.1.2.1,
pwstore-fast ==2.4.4,
quandl-api ==0.2.0.0,
QuasiText ==0.1.2.5,
QuickCheck ==2.7.6,
quickcheck-assertions ==0.1.1,
quickcheck-instances ==0.3.10,
quickcheck-io ==0.1.1,
quickcheck-unicode ==1.0.0.0,
quickpull ==0.4.0.0,
rainbow ==0.20.0.4,
rainbow-tests ==0.20.0.4,
random ==1.0.1.1,
random-fu ==0.2.6.2,
random-shuffle ==0.0.4,
random-source ==0.3.0.6,
rank1dynamic ==0.2.0.1,
Rasterific ==0.4.2,
raw-strings-qq ==1.0.2,
ReadArgs ==1.2.2,
reducers ==3.10.3.1,
reflection ==1.5.1.2,
regex-applicative ==0.3.1,
regex-base ==0.93.2,
regex-compat ==0.95.1,
regex-pcre-builtin ==0.94.4.8.8.35,
regex-posix ==0.95.2,
regexpr ==0.5.4,
regex-tdfa ==1.2.0,
regex-tdfa-rc ==1.1.8.3,
regular ==0.3.4.4,
regular-xmlpickler ==0.2,
rematch ==0.2.0.0,
repa ==3.3.1.2,
repa-algorithms ==3.3.1.2,
repa-devil ==0.3.2.2,
repa-io ==3.3.1.2,
reroute ==0.2.2.1,
resource-pool ==0.2.3.2,
resourcet ==1.1.4.1,
rest-client ==0.4.0.5,
rest-core ==0.33.1.2,
rest-gen ==0.16.1.8,
rest-happstack ==0.2.10.4,
rest-snap ==0.1.17.14,
rest-stringmap ==0.2.0.3,
rest-types ==1.11.1.1,
rest-wai ==0.1.0.4,
rev-state ==0.1,
rfc5051 ==0.1.0.3,
runmemo ==1.0.0.1,
rvar ==0.2.0.2,
safe ==0.3.8,
safecopy ==0.8.4,
scientific ==0.3.3.7,
scotty ==0.9.0,
scrobble ==0.2.1.1,
securemem ==0.1.7,
semigroupoid-extras ==4.0,
semigroupoids ==4.2,
semigroups ==0.16.2.2,
sendfile ==0.7.9,
seqloc ==0.6.1.1,
setenv ==0.1.1.3,
SHA ==1.6.4.1,
shake ==0.14.3,
shake-language-c ==0.6.4,
shakespeare ==2.0.4.1,
shakespeare-i18n ==1.1.0,
shakespeare-text ==1.1.0,
shell-conduit ==4.5.2,
shelly ==1.5.7,
silently ==1.2.4.1,
simple-reflect ==0.3.2,
simple-sendfile ==0.2.18,
singletons ==1.0,
siphash ==1.0.3,
skein ==1.0.9.2,
slave-thread ==0.1.5,
smallcheck ==1.1.1,
smtLib ==1.0.7,
snap ==0.13.3.2,
snap-core ==0.9.6.4,
snaplet-fay ==0.3.3.11,
snap-server ==0.9.4.6,
socks ==0.5.4,
sodium ==0.11.0.3,
sourcemap ==0.1.3.0,
speculation ==1.5.0.2,
sphinx ==0.6.0.1,
split ==0.2.2,
Spock ==0.7.7.0,
Spock-digestive ==0.1.0.0,
Spock-worker ==0.2.1.3,
spoon ==0.3.1,
sqlite-simple ==0.4.8.0,
stackage ==0.3.1,
stateref ==0.3,
statestack ==0.2.0.3,
statistics ==0.13.2.1,
statistics-linreg ==0.3,
stm ==2.4.4,
stm-chans ==3.0.0.2,
stm-conduit ==2.5.4,
stm-containers ==0.2.8,
stm-stats ==0.2.0.0,
storable-complex ==0.2.2,
storable-endian ==0.2.5,
streaming-commons ==0.1.10.0,
streams ==3.2,
strict ==0.3.2,
stringable ==0.1.3,
stringbuilder ==0.5.0,
stringprep ==1.0.0,
stringsearch ==0.3.6.5,
stylish-haskell ==0.5.11.1,
SVGFonts ==1.4.0.3,
syb ==0.4.4,
syb-with-class ==0.6.1.5,
system-canonicalpath ==0.2.3.0,
system-fileio ==0.3.16.1,
system-filepath ==0.4.13.2,
system-posix-redirect ==1.1.0.1,
tabular ==0.2.2.7,
tagged ==0.7.3,
tagshare ==0.0,
tagsoup ==0.13.3,
tagstream-conduit ==0.5.5.3,
tar ==0.4.1.0,
tardis ==0.3.0.0,
tasty ==0.10.1,
tasty-ant-xml ==1.0.1,
tasty-golden ==2.2.2.4,
tasty-hunit ==0.9.1,
tasty-kat ==0.0.3,
tasty-quickcheck ==0.8.3.2,
tasty-smallcheck ==0.8.0.1,
tasty-th ==0.1.3,
template-haskell installed,
temporary ==1.2.0.3,
temporary-rc ==1.2.0.3,
terminal-progress-bar ==0.0.1.4,
terminal-size ==0.3.0,
terminfo installed,
test-framework ==0.8.1.1,
test-framework-hunit ==0.3.0.1,
test-framework-quickcheck2 ==0.3.0.3,
test-framework-th ==0.2.4,
testing-feat ==0.4.0.2,
testpack ==2.1.3.0,
texmath ==0.8.0.1,
text ==1.2.0.4,
text-binary ==0.1.0,
text-format ==0.3.1.1,
text-icu ==0.7.0.1,
tf-random ==0.5,
th-desugar ==1.4.2.1,
th-expand-syns ==0.3.0.6,
th-extras ==0.0.0.2,
th-lift ==0.7.2,
th-orphans ==0.8.3,
threads ==0.5.1.3,
th-reify-many ==0.1.3,
thyme ==0.3.5.5,
time installed,
time-compat ==0.1.0.3,
time-lens ==0.4.0.1,
timezone-olson ==0.1.6,
timezone-series ==0.1.4,
tls ==1.2.16,
tls-debug ==0.3.4,
tostring ==0.2.1.1,
transformers installed,
transformers-base ==0.4.4,
transformers-compat ==0.3.3.3,
traverse-with-class ==0.2.0.3,
tree-view ==0.4,
tuple ==0.3.0.2,
type-eq ==0.4.2,
type-list ==0.0.0.1,
udbus ==0.2.1,
unbounded-delays ==0.1.0.9,
union-find ==0.2,
uniplate ==1.6.12,
unix installed,
unix-compat ==0.4.1.4,
unix-time ==0.3.5,
unordered-containers ==0.2.5.1,
uri-encode ==1.5.0.4,
url ==2.1.3,
utf8-light ==0.4.2,
utf8-string ==0.3.8,
uuid ==1.3.8,
vault ==0.3.0.4,
vector ==0.10.12.2,
vector-algorithms ==0.6.0.3,
vector-binary-instances ==0.2.1.0,
vector-instances ==3.3.0.1,
vector-space ==0.8.7,
vector-space-points ==0.2.1,
vector-th-unbox ==0.2.1.2,
vhd ==0.2.2,
void ==0.7,
wai ==3.0.2.3,
wai-app-static ==3.0.0.6,
wai-conduit ==3.0.0.2,
wai-eventsource ==3.0.0,
wai-extra ==3.0.4.5,
wai-logger ==2.2.3,
wai-middleware-static ==0.6.0.1,
wai-websockets ==3.0.0.5,
warp ==3.0.9.3,
warp-tls ==3.0.3,
webdriver ==0.6.1,
web-fpco ==0.1.1.0,
websockets ==0.9.3.0,
wizards ==1.0.1,
wl-pprint ==1.1,
wl-pprint-extras ==3.5.0.4,
wl-pprint-terminfo ==3.7.1.3,
wl-pprint-text ==1.1.0.3,
word8 ==0.1.2,
wordpass ==1.0.0.2,
X11 ==1.6.1.2,
x509 ==1.5.0.1,
x509-store ==1.5.0,
x509-system ==1.5.0,
x509-validation ==1.5.1,
xenstore ==0.1.1,
xhtml installed,
xml ==1.3.14,
xml-conduit ==1.2.3.3,
xmlgen ==0.6.2.1,
xml-hamlet ==0.4.0.10,
xmlhtml ==0.2.3.4,
xml-types ==0.3.4,
xss-sanitize ==0.3.5.5,
yackage ==0.7.0.7,
yaml ==0.8.10.1,
Yampa ==0.9.6,
YampaSynth ==0.2,
yesod ==1.4.1.4,
yesod-auth ==1.4.3.1,
yesod-auth-deskcom ==1.4.0,
yesod-auth-fb ==1.6.6,
yesod-auth-hashdb ==1.4.1.2,
yesod-auth-oauth2 ==0.0.12,
yesod-bin ==1.4.5,
yesod-core ==1.4.8.2,
yesod-eventsource ==1.4.0.1,
yesod-fay ==0.7.1,
yesod-fb ==0.3.4,
yesod-form ==1.4.4.1,
yesod-gitrepo ==0.1.1.0,
yesod-newsfeed ==1.4.0.1,
yesod-persistent ==1.4.0.2,
yesod-sitemap ==1.4.0.1,
yesod-static ==1.4.0.4,
yesod-test ==1.4.3.1,
yesod-text-markdown ==0.1.7,
yesod-websockets ==0.2.1.1,
zeromq4-haskell ==0.6.3,
zip-archive ==0.2.3.7,
zlib ==0.5.4.2,
zlib-bindings ==0.1.1.5,
zlib-enum ==0.2.3.1,
zlib-lens ==0.1.1.2

32
configure vendored
View File

@ -1,32 +0,0 @@
#!/bin/sh
has_git=`which git 2>/dev/null`
if test -d .git -a -n "$has_git"; then
HASH=`git rev-parse HEAD`
BRANCH=`git rev-parse --abbrev-ref HEAD`
# Checks if there are any lines in git status
if test -z "`git status --porcelain`"; then
DIRTY=False
else
DIRTY=True
fi
else
HASH="UNKNOWN"
BRANCH="UNKNOWN"
# well, we're not building from any git...
DIRTY="False"
fi
cat > src/GitRev.hs <<EOF
module GitRev (hash, branch, dirty) where
hash :: String
hash = "$HASH"
branch :: String
branch = "$BRANCH"
dirty :: Bool
dirty = $DIRTY
EOF

156
cryptol.cabal
View File

@ -1,23 +1,41 @@
Name: cryptol
Version: 2.1.0
Version: 2.2.0
Synopsis: Cryptol: The Language of Cryptography
Description: Cryptol is a domain-specific language for specifying cryptographic algorithms. A Cryptol implementation of an algorithm resembles its mathematical specification more closely than an implementation in a general purpose language. For more, see <http://www.cryptol.net/>.
License: BSD3
License-files: LICENSE, LICENSE.rtf
Author: Galois, Inc.
Maintainer: cryptol@galois.com
Copyright: 2013-2014 Galois Inc.
Homepage: http://www.cryptol.net/
Bug-reports: https://github.com/GaloisInc/cryptol/issues
Copyright: 2013-2015 Galois Inc.
Category: Language
Build-type: Configure
Build-type: Simple
Cabal-version: >= 1.18
data-files: lib/Cryptol.cry
data-files: *.cry
data-dir: lib
source-repository head
type: git
location: https://github.com/GaloisInc/cryptol.git
source-repository this
type: git
location: https://github.com/GaloisInc/cryptol.git
tag: v2.2.0
flag static
default: False
description: Create a statically-linked binary
flag notebook
default: False
description: Build the IPython-style Cryptol notebook interface
flag relocatable
default: True
description: Don't use the Cabal-provided data directory for looking up Cryptol libraries. This is useful when the data directory can't be known ahead of time, like for a relocatable distribution.
flag self-contained
default: True
description: Compile the text of the Cryptol Prelude into the library
library
Default-language:
@ -28,26 +46,27 @@ library
containers >= 0.5,
deepseq >= 1.3,
directory >= 1.2,
executable-path >= 0.0.3,
filepath >= 1.3,
gitrev >= 1.0,
GraphSCC >= 1.0.4,
monadLib >= 3.7.2,
mtl >= 2.2.1,
old-time >= 1.1,
presburger >= 1.1,
presburger >= 1.3,
pretty >= 1.1,
process >= 1.2,
QuickCheck >= 2.7,
random >= 1.0.1,
tf-random >= 0.5,
sbv >= 4.2,
smtLib >= 1.0.7,
syb >= 0.4,
text >= 1.1,
template-haskell,
tf-random >= 0.5,
transformers >= 0.3,
utf8-string >= 0.3
Build-tools: alex, happy
hs-source-dirs: src, sbv
hs-source-dirs: src
Exposed-modules: Cryptol.Prims.Syntax,
Cryptol.Prims.Types,
@ -108,113 +127,66 @@ library
Cryptol.Transform.Specialize,
Cryptol.Eval,
Cryptol.Eval.Arch,
Cryptol.Eval.Env,
Cryptol.Eval.Error,
Cryptol.Eval.Type,
Cryptol.Eval.Value,
Cryptol.Testing.Eval,
Cryptol.Testing.Exhaust,
Cryptol.Testing.Random,
Cryptol.Testing.Exhaust
Cryptol.Symbolic
Cryptol.Symbolic.BitVector
Cryptol.Symbolic.Prims
Cryptol.Symbolic.Value
Cryptol.Symbolic,
Cryptol.Symbolic.BitVector,
Cryptol.Symbolic.Prims,
Cryptol.Symbolic.Value,
Data.SBV,
Data.SBV.Bridge.Boolector,
Data.SBV.Bridge.CVC4,
Data.SBV.Bridge.MathSAT,
Data.SBV.Bridge.Yices,
Data.SBV.Bridge.Z3,
Data.SBV.Internals,
Data.SBV.Tools.Polynomial
Cryptol.REPL.Command,
Cryptol.REPL.Monad,
Cryptol.REPL.Trie
Other-modules: Cryptol.Parser.LexerUtils,
Cryptol.Parser.ParserUtils,
Data.SBV.BitVectors.AlgReals,
Data.SBV.BitVectors.Data,
Data.SBV.BitVectors.Model,
Data.SBV.BitVectors.PrettyNum,
Data.SBV.BitVectors.SignCast,
Data.SBV.BitVectors.Splittable,
Data.SBV.BitVectors.STree,
Data.SBV.Compilers.C,
Data.SBV.Compilers.CodeGen,
Data.SBV.SMT.SMT,
Data.SBV.SMT.SMTLib,
Data.SBV.SMT.SMTLib1,
Data.SBV.SMT.SMTLib2,
Data.SBV.Provers.Prover,
Data.SBV.Provers.SExpr,
Data.SBV.Provers.Boolector,
Data.SBV.Provers.CVC4,
Data.SBV.Provers.Yices,
Data.SBV.Provers.Z3,
Data.SBV.Provers.MathSAT,
Data.SBV.Tools.ExpectedValue,
Data.SBV.Tools.GenTest,
Data.SBV.Tools.Optimize,
Data.SBV.Utils.Boolean,
Data.SBV.Utils.TDiff,
Data.SBV.Utils.Lib,
Cryptol.Prelude,
Paths_cryptol,
GitRev
GHC-options: -Wall -O2
ghc-prof-options: -fprof-auto -prof
if flag(relocatable)
cpp-options: -DRELOCATABLE
if flag(self-contained)
build-depends: heredoc >= 0.2
cpp-options: -DSELF_CONTAINED
executable cryptol
Default-language:
Haskell98
Main-is: Main.hs
hs-source-dirs: cryptol
Other-modules: OptParser,
REPL.Command,
REPL.Haskeline,
REPL.Monad,
REPL.Trie,
REPL.Logo,
Paths_cryptol
build-depends: base,
ansi-terminal,
containers,
cryptol,
directory,
filepath,
haskeline,
monadLib,
process,
random,
tf-random,
transformers
build-depends: ansi-terminal
, base
, containers
, cryptol
, deepseq
, directory
, filepath
, haskeline
, monadLib
, process
, random
, sbv
, tf-random
, transformers
GHC-options: -Wall -O2
ghc-prof-options: -auto-all -prof -rtsopts
if os(linux) && flag(static)
ld-options: -static -pthread
executable cryptolnb
if flag(notebook)
buildable: True
else
buildable: False
Default-language:
Haskell98
Main-is: Main_notebook.hs
hs-source-dirs: cryptol, notebook
build-depends: base,
ansi-terminal,
containers,
cryptol,
directory,
filepath,
haskeline,
monadLib,
process,
random,
tf-random,
transformers
GHC-options: -Wall -O2
if os(linux) && flag(static)
ld-options: -static -pthread

118
cryptol/Main.hs
View File

@ -1,46 +1,57 @@
-- |
-- Module : $Header$
-- Copyright : (c) 2013-2014 Galois, Inc.
-- Copyright : (c) 2013-2015 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import OptParser
import REPL.Command (loadCmd,loadPrelude)
import Cryptol.REPL.Command (loadCmd,loadPrelude)
import Cryptol.REPL.Monad (REPL,updateREPLTitle,setUpdateREPLTitle,
io,prependSearchPath,setSearchPath)
import qualified Cryptol.REPL.Monad as REPL
import REPL.Haskeline
import REPL.Monad (REPL,setREPLTitle,io)
import REPL.Logo
import qualified REPL.Monad as REPL
import Cryptol.Utils.PP
import Cryptol.Version (commitHash, commitBranch, commitDirty)
import Paths_cryptol (version)
import Cryptol.Version (commitHash, commitBranch, commitDirty)
import Data.Version (showVersion)
import Cryptol.Utils.PP(pp)
import Data.Monoid (mconcat)
import System.Environment (getArgs,getProgName)
import System.Exit (exitFailure)
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import System.Console.GetOpt
(OptDescr(..),ArgOrder(..),ArgDescr(..),getOpt,usageInfo)
import System.Environment (getArgs, getProgName, lookupEnv)
import System.Exit (exitFailure)
import System.FilePath (searchPathSeparator, splitSearchPath, takeDirectory)
data Options = Options
{ optLoad :: [FilePath]
, optVersion :: Bool
, optHelp :: Bool
, optBatch :: Maybe FilePath
{ optLoad :: [FilePath]
, optVersion :: Bool
, optHelp :: Bool
, optBatch :: Maybe FilePath
, optCryptolrc :: Cryptolrc
, optCryptolPathOnly :: Bool
} deriving (Show)
defaultOptions :: Options
defaultOptions = Options
{ optLoad = []
, optVersion = False
, optHelp = False
, optBatch = Nothing
{ optLoad = []
, optVersion = False
, optHelp = False
, optBatch = Nothing
, optCryptolrc = CryrcDefault
, optCryptolPathOnly = False
}
options :: [OptDescr (OptParser Options)]
@ -53,6 +64,15 @@ options =
, Option "h" ["help"] (NoArg setHelp)
"display this message"
, Option "" ["ignore-cryptolrc"] (NoArg setCryrcDisabled)
"disable reading of .cryptolrc files"
, Option "" ["cryptolrc-script"] (ReqArg addCryrc "FILE")
"read additional .cryptolrc files"
, Option "" ["cryptolpath-only"] (NoArg setCryptolPathOnly)
"only look for .cry files in CRYPTOLPATH; don't use built-in locations"
]
-- | Set a single file to be loaded. This should be extended in the future, if
@ -72,6 +92,22 @@ setVersion = modify $ \ opts -> opts { optVersion = True }
setHelp :: OptParser Options
setHelp = modify $ \ opts -> opts { optHelp = True }
-- | Disable .cryptolrc files entirely
setCryrcDisabled :: OptParser Options
setCryrcDisabled = modify $ \ opts -> opts { optCryptolrc = CryrcDisabled }
-- | Add another file to read as a @.cryptolrc@ file, unless @.cryptolrc@
-- files have been disabled
addCryrc :: String -> OptParser Options
addCryrc path = modify $ \ opts ->
case optCryptolrc opts of
CryrcDefault -> opts { optCryptolrc = CryrcFiles [path] }
CryrcDisabled -> opts
CryrcFiles xs -> opts { optCryptolrc = CryrcFiles (path:xs) }
setCryptolPathOnly :: OptParser Options
setCryptolPathOnly = modify $ \opts -> opts { optCryptolPathOnly = True }
-- | Parse arguments.
parseArgs :: [String] -> Either [String] Options
parseArgs args = case getOpt (ReturnInOrder addFile) options args of
@ -92,10 +128,27 @@ displayHelp :: [String] -> IO ()
displayHelp errs = do
prog <- getProgName
let banner = "Usage: " ++ prog ++ " [OPTIONS]"
paraLines = fsep . map text . words . unlines
ppEnv (varname, desc) = hang varname 4 (paraLines $ desc)
envs = [
( "CRYPTOLPATH"
, [ "A `" ++ [searchPathSeparator] ++ "`-separated"
, "list of directories to be searched for Cryptol modules in"
, "addition to the default locations"
]
)
, ( "SBV_{ABC,BOOLECTOR,CVC4,MATHSAT,YICES,Z3}_OPTIONS"
, [ "A string of command-line arguments to be passed to the"
, "corresponding solver invoked for `:sat` and `:prove`"
]
)
]
putStrLn (usageInfo (concat (errs ++ [banner])) options)
print $ hang "Influential environment variables:"
4 (vcat (map ppEnv envs))
main :: IO ()
main = do
setLocaleEncoding utf8
args <- getArgs
case parseArgs args of
@ -106,12 +159,37 @@ main = do
Right opts
| optHelp opts -> displayHelp []
| optVersion opts -> displayVersion
| otherwise -> repl (optBatch opts) (setupREPL opts)
| otherwise -> repl (optCryptolrc opts)
(optBatch opts)
(setupREPL opts)
setupREPL :: Options -> REPL ()
setupREPL opts = do
smoke <- REPL.smokeTest
case smoke of
[] -> return ()
_ -> io $ do
print (hang "Errors encountered on startup; exiting:"
4 (vcat (map pp smoke)))
exitFailure
displayLogo True
setREPLTitle
setUpdateREPLTitle setREPLTitle
updateREPLTitle
mCryptolPath <- io $ lookupEnv "CRYPTOLPATH"
case mCryptolPath of
Nothing -> return ()
Just path | optCryptolPathOnly opts -> setSearchPath path'
| otherwise -> prependSearchPath path'
#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
-- Windows paths search from end to beginning
where path' = reverse (splitSearchPath path)
#else
where path' = splitSearchPath path
#endif
case optBatch opts of
Nothing -> return ()
-- add the directory containing the batch file to the module search path
Just file -> prependSearchPath [ takeDirectory file ]
case optLoad opts of
[] -> loadPrelude `REPL.catch` \x -> io $ print $ pp x
[l] -> loadCmd l `REPL.catch` \x -> io $ print $ pp x

2
cryptol/OptParser.hs
View File

@ -1,6 +1,6 @@
-- |
-- Module : $Header$
-- Copyright : (c) 2013-2014 Galois, Inc.
-- Copyright : (c) 2013-2015 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional

108
cryptol/REPL/Haskeline.hs
View File

@ -1,47 +1,48 @@
-- |
-- Module : $Header$
-- Copyright : (c) 2013-2014 Galois, Inc.
-- Copyright : (c) 2013-2015 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PatternGuards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module REPL.Haskeline where
import REPL.Command
import REPL.Monad
import REPL.Trie
import Cryptol.REPL.Command
import Cryptol.REPL.Monad
import Cryptol.REPL.Trie
import Cryptol.Utils.PP
import Control.Monad (guard, when)
import Data.Char (isAlphaNum, isSpace)
import Data.Function (on)
import Data.List (isPrefixOf,nub,sortBy)
import System.Console.Haskeline
import System.Directory(getAppUserDataDirectory,createDirectoryIfMissing)
import System.FilePath((</>))
import qualified Control.Exception as X
import Control.Monad (guard, when)
import qualified Control.Monad.IO.Class as MTL
import qualified Control.Monad.Trans.Class as MTL
import qualified Control.Exception as X
import Data.Char (isAlphaNum, isSpace)
import Data.Function (on)
import Data.List (isPrefixOf,nub,sortBy)
import System.Console.ANSI (setTitle)
import System.Console.Haskeline
import System.Directory ( doesFileExist
, getHomeDirectory
, getCurrentDirectory)
import System.FilePath ((</>))
-- | Haskeline-specific repl implementation.
--
-- XXX this needs to handle Ctrl-C, which at the moment will just cause
-- haskeline to exit. See the function 'withInterrupt' for more info on how to
-- handle this.
repl :: Maybe FilePath -> REPL () -> IO ()
repl mbBatch begin =
do settings <- setHistoryFile replSettings
runREPL isBatch (runInputTBehavior style settings body)
repl :: Cryptolrc -> Maybe FilePath -> REPL () -> IO ()
repl cryrc mbBatch begin =
do settings <- setHistoryFile (replSettings isBatch)
runREPL isBatch (runInputTBehavior behavior settings body)
where
body = withInterrupt $ do
MTL.lift evalCryptolrc
MTL.lift begin
loop
(isBatch,style) = case mbBatch of
(isBatch,behavior) = case mbBatch of
Nothing -> (False,defaultBehavior)
Just path -> (True,useFile path)
@ -70,24 +71,65 @@ repl mbBatch begin =
getInputLines newPropmpt (init l : ls)
| otherwise -> return $ Just $ unlines $ reverse $ l : ls
evalCryptolrc =
case cryrc of
CryrcDefault -> do
here <- io $ getCurrentDirectory
home <- io $ getHomeDirectory
let dcHere = here </> ".cryptolrc"
dcHome = home </> ".cryptolrc"
isHere <- io $ doesFileExist dcHere
isHome <- io $ doesFileExist dcHome
if | isHere -> slurp dcHere
| isHome -> slurp dcHome
| otherwise -> whenDebug $ io $ putStrLn "no .cryptolrc found"
CryrcFiles paths -> mapM_ slurp paths
CryrcDisabled -> return ()
-- | Actually read the contents of a file, but don't save the
-- history
--
-- XXX: friendlier error message would be nice if the file can't be
-- found, but since these will be specified on the command line it
-- should be obvious what's going wrong
slurp path = do
let settings' = defaultSettings { autoAddHistory = False }
runInputTBehavior (useFile path) settings' (withInterrupt loop)
-- | Try to set the history file.
setHistoryFile :: Settings REPL -> IO (Settings REPL)
setHistoryFile ss =
do dir <- getAppUserDataDirectory "cryptol"
createDirectoryIfMissing True dir
return ss { historyFile = Just (dir </> "history") }
do dir <- getHomeDirectory
return ss { historyFile = Just (dir </> ".cryptol_history") }
`X.catch` \(SomeException {}) -> return ss
-- | Haskeline settings for the REPL.
replSettings :: Settings REPL
replSettings = Settings
replSettings :: Bool -> Settings REPL
replSettings isBatch = Settings
{ complete = cryptolCommand
, historyFile = Nothing
, autoAddHistory = True
, autoAddHistory = not isBatch
}
-- .cryptolrc ------------------------------------------------------------------
-- | Configuration of @.cryptolrc@ file behavior. The default option
-- searches the following locations in order, and evaluates the first
-- file that exists in batch mode on interpreter startup:
--
-- 1. $PWD/.cryptolrc
-- 2. $HOME/.cryptolrc
--
-- If files are specified, they will all be evaluated, but none of the
-- default files will be (unless they are explicitly specified).
--
-- The disabled option inhibits any reading of any .cryptolrc files.
data Cryptolrc =
CryrcDefault
| CryrcDisabled
| CryrcFiles [FilePath]
deriving (Show)
-- Utilities -------------------------------------------------------------------
@ -101,6 +143,16 @@ instance MonadException REPL where
return (return a)
unREPL runBody ref
-- Titles ----------------------------------------------------------------------
mkTitle :: Maybe LoadedModule -> String
mkTitle lm = maybe "" (\ m -> pretty m ++ " - ") (lName =<< lm)
++ "cryptol"
setREPLTitle :: REPL ()
setREPLTitle = do
lm <- getLoadedMod
io (setTitle (mkTitle lm))
-- Completion ------------------------------------------------------------------

4
cryptol/REPL/Logo.hs
View File

@ -1,6 +1,6 @@
-- |
-- Module : $Header$
-- Copyright : (c) 2013-2014 Galois, Inc.
-- Copyright : (c) 2013-2015 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
@ -8,7 +8,7 @@
module REPL.Logo where
import REPL.Monad
import Cryptol.REPL.Monad
import Paths_cryptol (version)
import Cryptol.Version (commitShortHash)

BIN
docs/ProgrammingCryptol.pdf
View File

Binary file not shown.

4
docs/ProgrammingCryptol/appendices/Syntax.tex
View File

@ -333,6 +333,10 @@ f p1 p2 = e // Function definition
e where ds
\end{verbatim}
Note that by default, any local declarations without type signatures
are monomorphized. If you need a local declaration to be polymorphic,
use an explicit type signature.
\section{Explicit Type Instantiation}\label{explicit-type-instantiation}
If \texttt{f} is a polymorphic value with type:

2
docs/ProgrammingCryptol/enigma/Enigma.cry
View File

@ -1,5 +1,5 @@
// Cryptol Enigma Simulator
// Copyright (c) 2010-2013, Galois Inc.
// Copyright (c) 2010-2015, Galois Inc.
// www.cryptol.net
// You can freely use this source code for educational purposes.

2
docs/ProgrammingCryptol/enigma/Finite.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
docs/ProgrammingCryptol/enigma/Simple.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
docs/ProgrammingCryptol/enigma/ticket141.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

31
docs/ProgrammingCryptol/highAssurance/HighAssurance.tex
View File

@ -831,7 +831,7 @@ Not surprisingly, Cryptol told us that 3 is one such value. We can
search for other solutions by explicitly disallowing 3:
\begin{Verbatim}
Cryptol> :sat \x -> isSqrtOf9 x && ~(elem (x, [3]))
\x -> isSqrtOf9 x && ~(elem (x, [3])) 125 = True
\x -> isSqrtOf9 x && ~(elem (x, [3])) 131 = True
\end{Verbatim}
Note the use of the \lamex to\indLamExp indicate the new
constraint. (Of course, we could have defined another function {\tt
@ -842,18 +842,31 @@ express the constraint {\tt x} must not be 3. In response, Cryptol
told us that {\tt 125} is another solution. Indeed $125 * 125 =
9\imod{2^7}$, as you can verify separately. We can search for more:
\begin{Verbatim}
Cryptol> :sat \x -> isSqrtOf9 x && ~(elem (x, [3 125]))
\x -> isSqrtOf9 x && ~(elem (x, [3, 125]) ) 131 = True
Cryptol> :sat \x -> isSqrtOf9 x && ~(elem (x, [3, 125]))
\x -> isSqrtOf9 x && ~(elem (x, [3, 131])) 253 = True
\end{Verbatim}
And more:
Rather than manually adding solutions we have already seen, we can
search for other solutions by asking the satisfiability checker for
more solutions using the {\tt satNum} setting:
\begin{Verbatim}
Cryptol> :sat \x -> isSqrtOf9 x && ~(elem (x, [3 131 125]))
\x -> isSqrtOf9 x && ~(elem (x, [3, 131, 125]) ) 253 = True
Cryptol> :set satNum = 4
Cryptol> :sat isSqrtOf9
isSqrtOf9 3 = True
isSqrtOf9 131 = True
isSqrtOf9 125 = True
isSqrtOf9 253 = True
\end{Verbatim}
If we try one more time, we get:
By default, {\tt satNum} is set to {\tt 1}, so we only see one
solution. When we change it to {\tt 4}, the satisfiability checker
will try to find {\em up to} 4 solutions. We can also set it to {\tt
all}, which will try to find as many solutions as possible.
\begin{Verbatim}
Cryptol> :sat \x -> isSqrtOf9 x && ~(elem (x, [3, 131, 125, 253]))
Unsatisfiable.
Cryptol> :set satNum = 4
Cryptol> :sat isSqrtOf9
isSqrtOf9 3 = True
isSqrtOf9 131 = True
isSqrtOf9 125 = True
isSqrtOf9 253 = True
\end{Verbatim}
So, we can rest assured that there are exactly four 8-bit square roots
of 9; namely 3, 131, 125, and 253. (Note that Cryptol can return the

2
docs/ProgrammingCryptol/main/Cryptol-fullpage.tex
View File

@ -94,7 +94,7 @@ is aimed for the more advanced reader. It can be skipped on a first reading with
\renewcommand{\sectionmark}[1]{\markright{#1}{}}
\cfoot{}
\fancyfoot[LE,RO]{\fancyplain{}{\textsf{\thepage}}}
\fancyfoot[LO,RE]{\fancyplain{}{\textsf{\copyright\ 2010--2013, Galois, Inc.}}}
\fancyfoot[LO,RE]{\fancyplain{}{\textsf{\copyright\ 2010--2015, Galois, Inc.}}}
%% \fancyhead[LE]{\fancyplain{}{\textsf{\draftdate}}}
%% \fancyhead[RO]{\fancyplain{}{\textsf{DO NOT DISTRIBUTE!}}}
\fancyhead[RO,LE]{\fancyplain{}{}} %% outer

2
docs/ProgrammingCryptol/main/Cryptol.tex
View File

@ -109,7 +109,7 @@ without loss of continuity.}\end{minipage}}\end{center}}
}
\cfoot{}
\fancyfoot[LE,RO]{\changefont{\textsf{\thepage}}}
\fancyfoot[LO,RE]{\changefont{\textsf{\copyright\ 2010--2014, Galois, Inc.}}}
\fancyfoot[LO,RE]{\changefont{\textsf{\copyright\ 2010--2015, Galois, Inc.}}}
%% \fancyhead[LE]{\fancyplain{}{\textsf{\draftdate}}}
%% \fancyhead[RO]{\fancyplain{}{\textsf{DO NOT DISTRIBUTE!}}}
\fancyhead[RO,LE]{\fancyplain{}{}} %% outer

2
docs/ProgrammingCryptol/preface/Notice.tex
View File

@ -8,7 +8,7 @@
appear in this documentation. Of course, we appreciate bug reports
and clarification suggestions.
Copyright 2003--2014 Galois, Inc. All rights reserved by Galois,
Copyright 2003--2015 Galois, Inc. All rights reserved by Galois,
Inc.
The software installed in accordance with this documentation is

2
docs/ProgrammingCryptol/tools/compileProgrammingCryptol.hs
View File

@ -1,6 +1,6 @@
-- |
-- Module : $Header$
-- Copyright : (c) 2013-2014 Galois, Inc.
-- Copyright : (c) 2013-2015 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional

2
docs/ProgrammingCryptol/tools/genAlph.hs
View File

@ -1,6 +1,6 @@
-- |
-- Module : $Header$
-- Copyright : (c) 2013-2014 Galois, Inc.
-- Copyright : (c) 2013-2015 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional

4
docs/Syntax.md
View File

@ -296,6 +296,10 @@ Local Declarations
e where ds
Note that by default, any local declarations without type signatures
are monomorphized. If you need a local declaration to be polymorphic,
use an explicit type signature.
Explicit Type Instantiation
===========================

BIN
docs/Syntax.pdf
View File

Binary file not shown.

2
docs/chop.hs
View File

@ -2,7 +2,7 @@
-- |
-- Module : $Header$
-- Copyright : (c) 2013-2014 Galois, Inc.
-- Copyright : (c) 2013-2015 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional

16
examples/ChaChaPolyCryptolIETF.md
View File

@ -588,7 +588,7 @@ SunscreenKeystream = (parseHexString
# "c4:0c:59:45:39:8b:6e:da:1a:83:2c:89:c1:67:ea:cd:90:1d:7e:2b:f3:63."
) )
property SunscreenKeystream_correct (skref:[skwidth][8]) =
SunscreenKeystream_correct (skref:[skwidth][8]) =
take`{skwidth}
(groupBy`{8} (join (join(ChaCha20ExpandKey
Sunscreen_Key Sunscreen_Nonce 1)))) == skref
@ -1454,12 +1454,13 @@ Email: dylan@galois.com
## The ChaCha20 Block Functions
```cryptol
property TV_block_correct key nonce blockcounter result = ChaCha20Block key nonce blockcounter == result
// helper macros for higher-up properties
TV_block_correct key nonce blockcounter result = ChaCha20Block key nonce blockcounter == result
property TV_block_Keystream_correct key nonce blockcounter keystream =
TV_block_Keystream_correct key nonce blockcounter keystream =
take`{0x40} (groupBy`{8} (join (join (ChaCha20ExpandKey key nonce blockcounter)))) == keystream
property ChaCha20_block_correct key nonce blockcounter result keystream =
ChaCha20_block_correct key nonce blockcounter result keystream =
TV_block_correct key nonce blockcounter result &&
TV_block_Keystream_correct key nonce blockcounter keystream
```
@ -1590,7 +1591,7 @@ property all_block_tests_correct =
## ChaCha20 Encryption
```cryptol
property ChaCha20_enc_correct key nonce blockcounter plaintext cyphertext = ChaCha20EncryptBytes plaintext key nonce blockcounter == cyphertext
ChaCha20_enc_correct key nonce blockcounter plaintext cyphertext = ChaCha20EncryptBytes plaintext key nonce blockcounter == cyphertext
```
### Test Vector #1
@ -1721,7 +1722,7 @@ property all_enc_tests_correct =
## Poly1305 Message Authentication Code
```cryptol
property poly1305_MAC_correct key text tag = Poly1305 key text == tag
poly1305_MAC_correct key text tag = Poly1305 key text == tag
```
### Test Vector #1
@ -2055,7 +2056,8 @@ property TV1_otk_correct = Poly1305_key_correct TV1_AEAD_key TV1_AEAD_nonce TV1_
Next, we construct the AEAD buffer
```cryptol
property poly_input_correct AeadAAD cypherText result = (AeadConstruction AeadAAD cypherText) == result
// Helper macros for further properties
poly_input_correct AeadAAD cypherText result = (AeadConstruction AeadAAD cypherText) == result
property TV1_poly_input_correct = (poly_input_correct TV1_AEAD_AAD TV1_AEAD_cypherText TV1_AEAD_Poly_input)
```

2
examples/Cipher.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
examples/DES.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
examples/DEStest.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
examples/FNV-a1.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2014 Galois, Inc.
* Copyright (c) 2014-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
examples/SHA1.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2004, 2013-2014 Galois, Inc.
* Copyright (c) 2004, 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

66
examples/Salsa20.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/
@ -15,7 +15,7 @@ quarterround [y0, y1, y2, y3] = [z0, z1, z2, z3]
z3 = y3 ^ ((z2 + z1) <<< 0xd)
z0 = y0 ^ ((z3 + z2) <<< 0x12)
quarterround_passes_tests =
property quarterround_passes_tests =
(quarterround [0x00000000, 0x00000000, 0x00000000, 0x00000000] == [0x00000000, 0x00000000, 0x00000000, 0x00000000]) &&
(quarterround [0x00000001, 0x00000000, 0x00000000, 0x00000000] == [0x08008145, 0x00000080, 0x00010200, 0x20500000]) &&
(quarterround [0x00000000, 0x00000001, 0x00000000, 0x00000000] == [0x88000100, 0x00000001, 0x00000200, 0x00402000]) &&
@ -24,7 +24,7 @@ quarterround_passes_tests =
(quarterround [0xe7e8c006, 0xc4f9417d, 0x6479b4b2, 0x68c67137] == [0xe876d72b, 0x9361dfd5, 0xf1460244, 0x948541a3]) &&
(quarterround [0xd3917c5b, 0x55f1c407, 0x52a58a7a, 0x8f887a3b] == [0x3e2f308c, 0xd90a8f36, 0x6ab2a923, 0x2883524c])
// rowround : [16][32] -> [16][32]
rowround : [16][32] -> [16][32]
rowround [y0, y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12, y13, y14, y15] =
[z0, z1, z2, z3, z4, z5, z6, z7, z8, z9, z10, z11, z12, z13, z14, z15]
where
@ -33,7 +33,7 @@ rowround [y0, y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12, y13, y14, y15]
[z10, z11, z8, z9] = quarterround [y10, y11, y8, y9]
[z15, z12, z13, z14] = quarterround [y15, y12, y13, y14]
rowround_passes_tests =
property rowround_passes_tests =
(rowround [0x00000001, 0x00000000, 0x00000000, 0x00000000,
0x00000001, 0x00000000, 0x00000000, 0x00000000,
0x00000001, 0x00000000, 0x00000000, 0x00000000,
@ -51,23 +51,22 @@ rowround_passes_tests =
0x3402e183, 0x3c3af432, 0x50669f96, 0xd89ef0a8,
0x0040ede5, 0xb545fbce, 0xd257ed4f, 0x1818882d])
/* commented out for now -- not called, and type checker not yet happy
rowround_opt : [16][32] -> [16][32]
rowround_opt ys = join [ (quarterround (yi>>>i))<<<i | yi <- split ys | i <- [0 .. 0x3] ]
rowround_opt_is_rowround ys = rowround ys == rowround_opt ys
*/
rowround_opt : [16][32] -> [16][32]
rowround_opt ys = join [ (quarterround (yi<<<i))>>>i | yi <- split ys | i <- [0 .. 3] ]
property rowround_opt_is_rowround ys = rowround ys == rowround_opt ys
columnround : [16][32] -> [16][32]
columnround [x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15] =
[y0, y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12, y13, y14, y15]
[y0, y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12, y13, y14, y15]
where
[ y0, y4, y8, y12] = quarterround [ x0, x4, x8, x12]
[ y5, y9, y13, y1] = quarterround [ x5, x9, x13, x1]
[y10, y14, y2, y6] = quarterround [x10, x14, x2, x6]
[y15, y3, y7, y11] = quarterround [x15, x3, x7, x11]
columnround_passes_tests =
property columnround_passes_tests =
(columnround [0x00000001, 0x00000000, 0x00000000, 0x00000000,
0x00000001, 0x00000000, 0x00000000, 0x00000000,
0x00000001, 0x00000000, 0x00000000, 0x00000000,
@ -85,21 +84,20 @@ columnround_passes_tests =
0x789b010c, 0xd195a681, 0xeb7d5504, 0xa774135c,
0x481c2027, 0x53a8e4b5, 0x4c1f89c5, 0x3f78c9c8])
/* commented out for now -- not called, and type checker not yet happy
columnround_opt : [16][32] -> [16][32]
columnround_opt xs = join (transpose [ (quarterround (xi<<<i))>>>i | xi <- transpose(split xs) | i <- [0 .. 3] ])
columnround_opt_is_columnround xs = columnround xs == columnround_opt xs
*/
property columnround_is_transpose_of_rowround ys =
rowround ys == join(transpose(split(columnround(xs))))
where xs = join(transpose(split(ys)))
rowround ys == join(transpose(split`{4}(columnround xs)))
where xs = join(transpose(split`{4} ys))
doubleround : [16][32] -> [16][32]
doubleround(xs) = rowround(columnround(xs))
doubleround_passes_tests =
property doubleround_passes_tests =
(doubleround [0x00000001, 0x00000000, 0x00000000, 0x00000000,
0x00000000, 0x00000000, 0x00000000, 0x00000000,
0x00000000, 0x00000000, 0x00000000, 0x00000000,
@ -117,17 +115,10 @@ doubleround_passes_tests =
0xca531c29, 0x8e7943db, 0xac1680cd, 0xd503ca00,
0xa74b2ad6, 0xbc331c5c, 0x1dda24c7, 0xee928277])
// byteify : {n}(fin n) => [n][32] -> [n][8] // ideal
byteify : [32] -> [4][8] // help the type checker along
byteify xs = groupBy`{8}xs
wordendianswap : [4][8] -> [4][8]
wordendianswap b = reverse b
littleendian : [4][8] -> [32]
littleendian b = join(reverse b)
littleendian_passes_tests =
property littleendian_passes_tests =
(littleendian [ 0, 0, 0, 0] == 0x00000000) &&
(littleendian [ 86, 75, 30, 9] == 0x091e4b56) &&
(littleendian [255, 255, 255, 250] == 0xfaffffff)
@ -135,16 +126,16 @@ littleendian_passes_tests =
littleendian_inverse : [32] -> [4][8]
littleendian_inverse b = reverse(split b)
littleendian_is_invertable b = littleendian_inverse(littleendian(b)) == b
property littleendian_is_invertable b = littleendian_inverse(littleendian b) == b
Salsa20 : [64][8] -> [64][8]
Salsa20 xs = join(ar)
Salsa20 xs = join ar
where
ar = [ wordendianswap (byteify words) | words <- xw + (zs@0xa) ]
xw = [ littleendian(xi) | xi <- split xs ]
zs = [xw] # [ doubleround(zi) | zi <- zs ]
ar = [ littleendian_inverse words | words <- xw + zs@10 ]
xw = [ littleendian xi | xi <- split xs ]
zs = [xw] # [ doubleround zi | zi <- zs ]
Salsa20_passes_tests =
property Salsa20_passes_tests =
(Salsa20 [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
@ -170,23 +161,22 @@ Salsa20_passes_tests =
69, 144, 51, 57, 29, 29, 150, 26, 150, 30, 235, 249, 190, 163, 251, 48,
27, 111, 114, 114, 118, 40, 152, 157, 180, 57, 27, 94, 107, 42, 236, 35])
property Salsa20_has_no_collisions x1 x2 =
if(x1 != x2) then doubleround(x1) != doubleround(x2) else True
property Salsa20_has_no_collisions x1 x2 =
if(x1 != x2) then (doubleround x1) != (doubleround x2) else True
// Salsa 20 supports two key sizes, [16][8] and [32][8]
Salsa20_expansion : {a} (a >= 1, 2 >= a) => ([16*a][8], [16][8]) -> [64][8]
Salsa20_expansion(k, n) = z
where
[s0, s1, s2, s3] = split("expand 32-byte k") : [4][4][8]
[t0, t1, t2, t3] = split("expand 16-byte k") : [4][4][8]
[s0, s1, s2, s3] = split "expand 32-byte k" : [4][4][8]
[t0, t1, t2, t3] = split "expand 16-byte k" : [4][4][8]
x = if(`a == 2) then s0 # k0 # s1 # n # s2 # k1 # s3
else t0 # k0 # t1 # n # t2 # k0 # t3
z = Salsa20(x)
[k0, k1] = (split(k#zero)):[2][16][8]
Salsa20_encrypt : {a, b} (a >= 1, 2 >= a, fin b) => ([16*a][8], [8][8], [b][8]) -> [b][8]
Salsa20_encrypt : {a, l} (a >= 1, 2 >= a, l <= 2^^70) => ([16*a][8], [8][8], [l][8]) -> [l][8]
Salsa20_encrypt(k, v, m) = c
where
salsa = take`{b} (join [ Salsa20_expansion(k, v#(split i)) | i <- [0, 1 ... ] ])
where
salsa = take (join [ Salsa20_expansion(k, v#(split i)) | i <- [0, 1 ... ] ])
c = m ^ salsa

2
examples/Test.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
examples/TripleDES.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
examples/ZUC.cry
View File

@ -1,4 +1,4 @@
// Copyright (c) 2011, 2014 Galois, Inc.
// Copyright (c) 2011-2015 Galois, Inc.
// An implementation of ZUC, Version 1.5
// Version info: If the following variable is set to True, then we implement

38
examples/contrib/RC4.cry Normal file
View File

@ -0,0 +1,38 @@
swap : [256][8] -> [8] -> [8] -> [256][8]
swap s i j = [ s @ (if n == i then j else
if n == j then i else
n)
| n <- [0..255]
]
ksa_step : [inf][8] -> [8] -> [8] -> [256][8] -> ([8],[256][8])
ksa_step key i j s = (j', swap s i j')
where j' = j + s@i + key@i
ksa : [inf][8] -> [256][8]
ksa key = (go ! 0).1 where
go : [257]([8],[256][8])
go = [(0,[0..255])] # [ ksa_step key i j s
| i <- [0..255]
| (j,s) <- go
]
ks_step : [8] -> [8] -> [256][8] -> ([8],[256][8],[8])
ks_step i j s = (j',s',s@(s@i + s@j'))
where j' = j + s@i
s' = swap s i j'
ks key = [ k | (_,_,k) <- drop`{1} go ] where
go = [(0,ksa key',0)] # [ ks_step i j s
| i <- loop
| (j,s,k) <- go
]
key' = key # key'
loop = [1..255] # [0] # loop
///////
// "Test vectors" from wikipedia
property test1 = take (ks "Key") == [0xEB,0x9F,0x77,0x81,0xB7,0x34,0xCA,0x72,0xA7,0x19]
property test2 = take (ks "Wiki") == [0x60,0x44,0xDB,0x6D,0x41,0xB7]
property test3 = take (ks "Secret") == [0x04,0xD4,0x6B,0x05,0x3C,0xA8,0x7B,0x59]

14
examples/contrib/README.md Normal file
View File

@ -0,0 +1,14 @@
# Contributed Examples
These are Cryptol examples submitted by members of the community. If
you build something cool you'd like to share, send us a pull request
and we'll add it here!
A good example includes:
- A link to a description of the algorithm, like a NIST spec or a paper
- Test vectors, if applicable, preferably tested with `property` definitions
- Comments that help readers learn from your example
Note that contributions must be compatible with the BSD3 license we
use for the rest of the releases.

119
examples/contrib/mkrand.cry Normal file
View File

@ -0,0 +1,119 @@
/*
MKRAND - A Digital Random Bit Generator
The MIT License (MIT)
Copyright (c) 2014, TAG Universal Machine.
Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated documentation
files (the "Software"), to deal in the Software without
restriction, including without limitation the rights to use, copy,
modify, merge, publish, distribute, sublicense, and/or sell copies
of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.
--
USAGE
Create a 128 bit seed:
seed = seedUnit
Once the seed is created, you may use it to generate a stream of random bits:
take `{100} (randBytes seed)
Here a string is encoded with seedUnit, using the deterministic random stream as a
one-time pad against which to XOR the string:
Encode:
randXOR seedUnit "Deus Ex Machina"
[0x28, 0x2b, 0x2c, 0xfa, 0x92, 0xca, 0xb3, 0xcb, 0xed, 0x50, 0xc2,v0x1b, 0x11, 0x0e, 0x70]
Decode:
:set ascii=on
randXOR seedUnit [0x28, 0x2b, 0x2c, 0xfa, 0x92, 0xca, 0xb3, 0xcb, 0xed, 0x50, 0xc2,0x1b, 0x11, 0x0e, 0x70]
"Deus Ex Machina"
*/
module MKRAND where
type Seg = [0x80]
type Field = [0x80]Seg
/* Canonical seed - a segment with a single True bit in the center */
seedUnit:Seg
seedUnit = (0 :[63]) # (1:[1]) # (0:[64])
/*
* Field - Unfold an application of Rule 30 to a seed
*/
field: Seg -> [inf]Seg
field s = new
where
new = [s] # [ rule30 row | row <- new]
rule30 r = [ a ^ (b || c) | a <- r >>> 1
| b <- r
| c <- r <<< 1
]
/* SHA30 - Use the input segment as the seed, generate two square fields,
* keep the center column of the second.
*/
sha30: Seg -> Seg
sha30 s = take`{0x80} (drop`{0x80} [ r @ ((((width r) / 2)-1):[8]) | r <- field s])
/*
* RAND - Seed XOR (SHA30 Seed)
*/
rands : Seg -> [inf]Seg
rands s = rest
where
rand p = p ^ (sha30 p)
rest = [rand s] # [rand x | x <- rest]
/* Break segments into bytes */
randBytes : Seg -> [inf][8]
randBytes s = groupBy`{8} (join (rands s))
/* XOR a byte string into a random byte string, using the given seed */
randXOR : {n} Seg -> String n -> String n
randXOR seed src = [s ^ r | s <- src
| r <- randBytes seed
]
/* OTP example */
property otp_encdec =
randXOR seedUnit "Deus Ex Machina" == c
&& randXOR seedUnit c == "Deus Ex Machina"
where c = [ 0x28, 0x2b, 0x2c, 0xfa
, 0x92, 0xca, 0xb3, 0xcb
, 0xed, 0x50, 0xc2, 0x1b
, 0x11, 0x0e, 0x70]
otp_involutive : {len} (fin len) => String len -> Bit
otp_involutive msg = randXOR seedUnit (randXOR seedUnit msg) == msg
property otp_involutive_32 msg = otp_involutive (msg : String 32)

2
examples/contrib/simon.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
examples/contrib/speck.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
examples/funstuff/FoxChickenCorn.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
examples/funstuff/NQueens.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
examples/funstuff/marble.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
examples/maliciousSHA/malicious_SHA1.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2004, 2013-2014 Galois, Inc.
* Copyright (c) 2004, 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

2
lib/Cryptol.cry
View File

@ -1,5 +1,5 @@
/*
* Copyright (c) 2013-2014 Galois, Inc.
* Copyright (c) 2013-2015 Galois, Inc.
* Distributed under the terms of the BSD3 license (see LICENSE file)
*/

1
notebook/.gitignore vendored
View File

@ -1 +0,0 @@
history.sqlite

1662
notebook/AES.ipynb
View File

File diff suppressed because it is too large Load Diff

101
notebook/Main_notebook.hs
View File

@ -1,101 +0,0 @@
-- |
-- Module : $Header$
-- Copyright : (c) 2013-2014 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
module Main where
import Notebook
import REPL.Command
import REPL.Monad (lName, lPath)
import qualified REPL.Monad as REPL
import qualified Cryptol.ModuleSystem as M
import Cryptol.Parser (defaultConfig, parseModule, Config(..))
import qualified Cryptol.Parser.AST as P
import qualified Cryptol.TypeCheck.AST as T
import Cryptol.Utils.PP (pp)
import Control.Applicative ((<$>))
import Control.Monad (forever, forM_)
import System.IO (hFlush, stdout)
main :: IO ()
main = runNB $ do
liftREPL loadPrelude `catch` \x -> io $ print $ pp x
io $ putStr "<READY>" >> hFlush stdout
let loop = do
line <- io getLine
runExns $ case line of
"<BEGINMOD>" ->
handleModFrag =<< parseModFrag =<< readUntil (== "<ENDMOD>")
"<BEGINAUTO>" ->
handleAuto =<< readUntil (== "<ENDAUTO>")
_ ->
handleCmd line
io $ putStr "<DONE>" >> hFlush stdout
forever loop
-- Input Handling --------------------------------------------------------------
-- | Determine whether the input is a module fragment or a series of
-- interactive commands, and behave accordingly.
handleAuto :: String -> NB ()
handleAuto str = do
let cfg = defaultConfig { cfgSource = "<notebook>" }
cmdParses cmd =
case parseCommand findNbCommand cmd of
Just (Unknown _) -> False
Just (Ambiguous _ _) -> False
_ -> True
case parseModule cfg str of
Right m -> handleModFrag m
Left modExn -> do
let cmds = lines str
if and (map cmdParses cmds)
then forM_ cmds handleCmd
else raise (AutoParseError modExn)
parseModFrag :: String -> NB P.Module
parseModFrag str = liftREPL $ replParse (parseModule cfg) str
where cfg = defaultConfig { cfgSource = "<notebook>" }
-- | Read a module fragment and incorporate it into the current context.
handleModFrag :: P.Module -> NB ()
handleModFrag m = do
let m' = removeIncludes $ removeImports m
old <- getTopDecls
let new = modNamedDecls m'
merged = updateNamedDecls old new
doLoad = try $ liftREPL $ liftModuleCmd (M.loadModule (moduleFromDecls nbName merged))
em'' <- doLoad
-- only update the top decls if the module successfully loaded
case em'' of
Left exn -> raise exn
Right m'' -> do
setTopDecls merged
liftREPL $ REPL.setLoadedMod REPL.LoadedModule
{ lName = Just (T.mName m'')
, lPath = "<notebook>"
}
readUntil :: (String -> Bool) -> NB String
readUntil shouldStop = unlines . reverse <$> go []
where go xs = do
line <- io getLine
if shouldStop line
then return xs
else go (line : xs)
-- | Treat a line as an interactive command.
handleCmd :: String -> NB ()
handleCmd line =
case parseCommand findNbCommand line of
Nothing -> return ()
Just cmd -> do
liftREPL $ runCommand cmd

190
notebook/Notebook.hs
View File

@ -1,190 +0,0 @@
-- |
-- Module : $Header$
-- Copyright : (c) 2013-2014 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
-- Portability : portable
{-# LANGUAGE DeriveDataTypeable #-}
module Notebook where
import REPL.Command (loadPrelude,findNbCommand,parseCommand,runCommand,replParse,liftModuleCmd)
import REPL.Monad (REPL(..) ,runREPL, lName, lPath)
import qualified REPL.Monad as REPL
import qualified Cryptol.ModuleSystem as M
import Cryptol.Parser (defaultConfig, parseModule, Config(..), ParseError)
import qualified Cryptol.Parser.AST as P
import Cryptol.Parser.Names (allNamesD, tnamesNT)
import Cryptol.Parser.Position (Located(..), emptyRange)
import qualified Cryptol.TypeCheck.AST as T
import Cryptol.Utils.PP (PP(..), pp, hang, text)
import Control.Applicative ((<$>))
import qualified Control.Exception as X
import Control.Monad (forever)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef)
import Data.List (isPrefixOf)
import qualified Data.Set as Set
import Data.Typeable (Typeable)
import System.IO (hFlush, stdout)
-- Notebook Environment --------------------------------------------------------
-- | All of the top-level declarations along with all of the names
-- that they define. We need to associate the names in order to remove
-- declarations from the module context when they're overwritten.
type NamedDecls = [([P.QName], P.TopDecl)]
data RW = RW
{ eNamedDecls :: NamedDecls
}
-- | The default environment is simple now but might get more
-- complicated, so it's made in IO.
defaultRW :: IO RW
defaultRW = return RW { eNamedDecls = [] }
-- Notebook Monad --------------------------------------------------------------
-- | The Notebook is just a REPL augmented with an incrementally-built module.
newtype NB a = NB { unNB :: IORef RW -> REPL a }
instance Functor NB where
{-# INLINE fmap #-}
fmap f m = NB (\ref -> fmap f (unNB m ref))
instance Monad NB where
{-# INLINE return #-}
return x = NB (\_ -> return x)
{-# INLINE (>>=) #-}
m >>= f = NB $ \ref -> do
x <- unNB m ref
unNB (f x) ref
-- | Run a NB action with a fresh environment.
runNB :: NB a -> IO a
runNB m = do
ref <- newIORef =<< defaultRW
runREPL True $ unNB m ref
-- | Lift a REPL action into the NB monad.
liftREPL :: REPL a -> NB a
liftREPL m = NB (\_ -> m)
-- Primitives ------------------------------------------------------------------
io :: IO a -> NB a
io m = liftREPL (REPL.io m)
getRW :: NB RW
getRW = NB (\ref -> REPL.io (readIORef ref))
modifyRW_ :: (RW -> RW) -> NB ()
modifyRW_ f = NB (\ref -> REPL.io (modifyIORef ref f))
getTopDecls :: NB NamedDecls
getTopDecls = eNamedDecls `fmap` getRW
setTopDecls :: NamedDecls -> NB ()
setTopDecls nds = modifyRW_ (\rw -> rw { eNamedDecls = nds })
modifyTopDecls :: (NamedDecls -> NamedDecls) -> NB NamedDecls
modifyTopDecls f = do
nds <- f `fmap` getTopDecls
setTopDecls nds
return nds
-- Exceptions ------------------------------------------------------------------
-- | Notebook exceptions.
data NBException
= REPLException REPL.REPLException
| AutoParseError ParseError
deriving (Show, Typeable)
instance X.Exception NBException
instance PP NBException where
ppPrec _ nbe = case nbe of
REPLException exn -> pp exn
AutoParseError exn ->
hang (text "[error] Failed to parse cell as a module or as interactive input")
4 (pp exn)
-- | Raise an exception
raise :: NBException -> NB a
raise exn = io (X.throwIO exn)
-- | Catch an exception
catch :: NB a -> (NBException -> NB a) -> NB a
catch m k = NB (\ref ->
REPL (\replRef -> unREPL (unNB m ref) replRef
`X.catches`
-- catch a REPLException or a NBException
[ X.Handler $ \e -> unREPL (unNB (k (REPLException e)) ref) replRef
, X.Handler $ \e -> unREPL (unNB (k e) ref) replRef
]))
-- | Try running a possibly-excepting computation
try :: NB a -> NB (Either NBException a)
try m = catch (Right `fmap` m) (return . Left)
-- | Try running the given action, printing any exceptions that arise.
runExns :: NB () -> NB ()
runExns m = m `catch` \x -> io $ print $ pp x
-- Module Manipulation ---------------------------------------------------------
nbName :: P.Located P.ModName
nbName = Located { srcRange = emptyRange
, thing = P.ModName ["Notebook"]
}
-- | Distill a module into a list of decls along with the names
-- defined by those decls.
modNamedDecls :: P.Module -> NamedDecls
modNamedDecls m = [(tdNames td, td) | td <- P.mDecls m]
-- | Build a module of the given name using the given list of
-- declarations.
moduleFromDecls :: P.Located P.ModName -> NamedDecls -> P.Module
moduleFromDecls name nds =
P.Module { P.mName = name
, P.mImports = []
, P.mDecls = map snd nds
}
-- | In @updateNamedDecls old new = result@, @result@ is a
-- right-biased combination of @old@ and @new@ with the following
-- semantics:
--
-- If a name @x@ is defined in @old@ and not @new@, or in @new@ and
-- not @old@, all declarations of @x@ are in @result@.
--
-- If a name @x@ is defined in both @old@ and @new@, /none/ of the
-- declarations of @x@ from @old@ are in @result@, and all
-- declarations of @x@ from @new@ are in @result@.
updateNamedDecls :: NamedDecls -> NamedDecls -> NamedDecls
updateNamedDecls old new = filteredOld ++ new
where newNames = Set.fromList $ concat $ map fst new
containsNewName = any (\x -> Set.member x newNames)
filteredOld = filter (\(xs,_) -> not (containsNewName xs)) old
-- | The names defined by a top level declaration
tdNames :: P.TopDecl -> [P.QName]
tdNames (P.Decl d) = map P.thing $ allNamesD $ P.tlValue d
tdNames (P.TDNewtype d) = map P.thing $ fst $ tnamesNT $ P.tlValue d
tdNames (P.Include _) = []
removeIncludes :: P.Module -> P.Module
removeIncludes m = m { P.mDecls = decls' }
where decls' = filter (not . isInclude) $ P.mDecls m
isInclude (P.Include _) = True
isInclude _ = False
removeImports :: P.Module -> P.Module
removeImports m = m { P.mImports = [] }

90
notebook/cryptol2py.py
View File

@ -1,90 +0,0 @@
# -*- coding utf-8 -*-
"""
Module for controlling a Cryptol session from python.
"""
import pexpect
def interruptable(method):
"""
Decorator for methods that can be sent a KeyboardInterrupt
exception; passes a Ctrl-C to the underlying cryptol process
"""
def inner(self, *args):
result = None
try:
result = method(self, *args)
except KeyboardInterrupt:
self.cryptol.sendcontrol('c')
raise Cryptol2Interrupt()
return result
return inner
class Cryptol2Py:
def __init__(self):
self.cryptol = setup_cryptol_process()
self.cryptol.expect("<READY>")
def stop(self):
self.cryptol.sendcontrol('c')
@interruptable
def runInteractive(self, code):
out = []
for line in code.splitlines():
self.cryptol.sendline(line)
self.cryptol.expect("<DONE>", timeout=600)
out.append(self.cryptol.before)
return '\n'.join(out)
@interruptable
def addModuleFragment(self, code):
self.cryptol.sendline("<BEGINMOD>")
if code[-1] == '\n':
self.cryptol.send(code)
else:
self.cryptol.sendline(code)
self.cryptol.sendline("<ENDMOD>")
self.cryptol.expect("<DONE>")
return self.cryptol.before
@interruptable
def runAuto(self, code):
"""
Send a block of code to the cryptol process using the AUTO input
mode. This will attempt to automatically determine whether the
input is a module fragment or a sequence of interactive
commands.
"""
self.cryptol.sendline("<BEGINAUTO>")
if code[-1] == '\n':
self.cryptol.send(code)
else:
self.cryptol.sendline(code)
self.cryptol.sendline("<ENDAUTO>")
self.cryptol.expect("<DONE>", timeout=600)
return self.cryptol.before
def setup_cryptol_process():
"""
Static method that setups up an interactive cryptol process.
"""
cryptol = pexpect.spawn("../.cabal-sandbox/bin/cryptolnb")
cryptol.setecho(False)
return cryptol
class Cryptol2PyError:
pass
class Cryptol2Interrupt:
def _render_traceback_(self):
return ["<interrupted>"]
def test():
cry = Cryptol2Py()
return cry.runAuto("1+1")
if __name__ == "__main__":
print test()

88
notebook/cryptolmagic.py
View File

@ -1,88 +0,0 @@
# -*- coding: utf-8 -*-
"""
===========
cryptolmagic
===========
Magics for interacting with Cryptol2
"""
from pprint import pprint
from IPython.core.magic import Magics, magics_class, cell_magic
from IPython.core.displaypub import publish_display_data
from cryptol2py import Cryptol2Py
@magics_class
class Cryptol2Magics(Magics):
"""A set of magics useful for interactive work with Cryptol2
"""
def __init__(self, shell):
"""
Parameters
----------
shell : IPython shell
"""
super(Cryptol2Magics, self).__init__(shell)
self.cryptol = Cryptol2Py()
@cell_magic
def icry(self, line, cell=None):
'''
Execute code in Cryptol2 and return results including errors if there are
any.
'''
if None == cell:
out = ""
else:
out = self.cryptol.runInteractive(cell)
publish_display_data("cryptol2magic", {'text/plain' : out})
@cell_magic
def cry(self, line, cell=None):
'''
Add the code to the current module in the Cryptol2 context.
'''
if None == cell:
out = ""
else:
out = self.cryptol.addModuleFragment(cell)
publish_display_data("cryptol2magic", {'text/plain' : out})
@cell_magic
def cryauto(self, line, cell=None):
"""
Execute code in either module or interactive mode in Cryptol 2,
depending on which one successfully parses.
"""
if None == cell:
out = ""
else:
out = self.cryptol.runAuto(cell)
publish_display_data("cryptol2magic", {'text/plain' : out})
def load_ipython_extension(ip):
"""
We want the default magic to be cryauto, but we want to allow
other magics to work if they are specified.
"""
ip.register_magics(Cryptol2Magics)
def new_run_cell(self, cell, **kwds):
if cell.startswith("%"):
newcell = cell
else:
newcell = "%%cryauto\n" + cell
self.old_run_cell(newcell, **kwds)
from IPython.core.interactiveshell import InteractiveShell
func_type = type(InteractiveShell.run_cell)
ip.old_run_cell = ip.run_cell
ip.run_cell = func_type(new_run_cell, ip, InteractiveShell)
ip.write("cryptolmagic loaded")

23
notebook/notebook.sh
View File

@ -1,23 +0,0 @@
#!/bin/sh
#
# Edit these paths to suit your needs; by default all of the python
# files for connecting to Cryptol are in the same directory as this
# script.
#
CRYNB_ROOT="$( cd "$(dirname "$0")" ; pwd -P )"
IPNB_MAGICS=$CRYNB_ROOT
#
# Leave everything below this line alone
#
export CRYNB_ROOT
export PYTHONPATH=$PYTHONPATH:$IPNB_MAGICS
pushd $CRYNB_ROOT
ipython notebook \
--profile-dir=$CRYNB_ROOT/profile_cryptol \
--ext=cryptolmagic
popd

1948
notebook/pexpect.py
View File

File diff suppressed because it is too large Load Diff

514
notebook/profile_cryptol/ipython_config.py
View File

@ -1,514 +0,0 @@
# Configuration file for ipython.
c = get_config()
#------------------------------------------------------------------------------
# InteractiveShellApp configuration
#------------------------------------------------------------------------------
# A Mixin for applications that start InteractiveShell instances.
#
# Provides configurables for loading extensions and executing files as part of
# configuring a Shell environment.
#
# The following methods should be called by the :meth:`initialize` method of the
# subclass:
#
# - :meth:`init_path`
# - :meth:`init_shell` (to be implemented by the subclass)
# - :meth:`init_gui_pylab`
# - :meth:`init_extensions`
# - :meth:`init_code`
# Execute the given command string.
# c.InteractiveShellApp.code_to_run = ''
# lines of code to run at IPython startup.
# c.InteractiveShellApp.exec_lines = []
# Enable GUI event loop integration with any of ('glut', 'gtk', 'gtk3', 'none',
# 'osx', 'pyglet', 'qt', 'qt4', 'tk', 'wx').
# c.InteractiveShellApp.gui = None
# Pre-load matplotlib and numpy for interactive use, selecting a particular
# matplotlib backend and loop integration.
# c.InteractiveShellApp.pylab = None
# Configure matplotlib for interactive use with the default matplotlib backend.
# c.InteractiveShellApp.matplotlib = None
# If true, IPython will populate the user namespace with numpy, pylab, etc. and
# an 'import *' is done from numpy and pylab, when using pylab mode.
#
# When False, pylab mode should not import any names into the user namespace.
# c.InteractiveShellApp.pylab_import_all = True
# A list of dotted module names of IPython extensions to load.
# c.InteractiveShellApp.extensions = []
# Run the module as a script.
# c.InteractiveShellApp.module_to_run = ''
# dotted module name of an IPython extension to load.
# c.InteractiveShellApp.extra_extension = ''
# List of files to run at IPython startup.
# c.InteractiveShellApp.exec_files = []
# A file to be run
# c.InteractiveShellApp.file_to_run = ''
#------------------------------------------------------------------------------
# TerminalIPythonApp configuration
#------------------------------------------------------------------------------
# TerminalIPythonApp will inherit config from: BaseIPythonApplication,
# Application, InteractiveShellApp
# Pre-load matplotlib and numpy for interactive use, selecting a particular
# matplotlib backend and loop integration.
# c.TerminalIPythonApp.pylab = None
# Create a massive crash report when IPython encounters what may be an internal
# error. The default is to append a short message to the usual traceback
# c.TerminalIPythonApp.verbose_crash = False
# Run the module as a script.
# c.TerminalIPythonApp.module_to_run = ''
# The date format used by logging formatters for %(asctime)s
# c.TerminalIPythonApp.log_datefmt = '%Y-%m-%d %H:%M:%S'
# Whether to overwrite existing config files when copying
# c.TerminalIPythonApp.overwrite = False
# Execute the given command string.
# c.TerminalIPythonApp.code_to_run = ''
# Set the log level by value or name.
# c.TerminalIPythonApp.log_level = 30
# lines of code to run at IPython startup.
# c.TerminalIPythonApp.exec_lines = []
# Suppress warning messages about legacy config files
# c.TerminalIPythonApp.ignore_old_config = False
# Path to an extra config file to load.
#
# If specified, load this config file in addition to any other IPython config.
# c.TerminalIPythonApp.extra_config_file = u''
# dotted module name of an IPython extension to load.
# c.TerminalIPythonApp.extra_extension = ''
# A file to be run
# c.TerminalIPythonApp.file_to_run = ''
# The IPython profile to use.
# c.TerminalIPythonApp.profile = u'default'
# Configure matplotlib for interactive use with the default matplotlib backend.
# c.TerminalIPythonApp.matplotlib = None
# If a command or file is given via the command-line, e.g. 'ipython foo.py
# c.TerminalIPythonApp.force_interact = False
# If true, IPython will populate the user namespace with numpy, pylab, etc. and
# an 'import *' is done from numpy and pylab, when using pylab mode.
#
# When False, pylab mode should not import any names into the user namespace.
# c.TerminalIPythonApp.pylab_import_all = True
# The name of the IPython directory. This directory is used for logging
# configuration (through profiles), history storage, etc. The default is usually
# $HOME/.ipython. This options can also be specified through the environment
# variable IPYTHONDIR.
# c.TerminalIPythonApp.ipython_dir = u'/Users/acfoltzer/.ipython'
# Whether to display a banner upon starting IPython.
# c.TerminalIPythonApp.display_banner = True
# Whether to install the default config files into the profile dir. If a new
# profile is being created, and IPython contains config files for that profile,
# then they will be staged into the new directory. Otherwise, default config
# files will be automatically generated.
# c.TerminalIPythonApp.copy_config_files = False
# List of files to run at IPython startup.
# c.TerminalIPythonApp.exec_files = []
# Enable GUI event loop integration with any of ('glut', 'gtk', 'gtk3', 'none',
# 'osx', 'pyglet', 'qt', 'qt4', 'tk', 'wx').
# c.TerminalIPythonApp.gui = None
# A list of dotted module names of IPython extensions to load.
# c.TerminalIPythonApp.extensions = []
# Start IPython quickly by skipping the loading of config files.
# c.TerminalIPythonApp.quick = False
# The Logging format template
# c.TerminalIPythonApp.log_format = '[%(name)s]%(highlevel)s %(message)s'
#------------------------------------------------------------------------------
# TerminalInteractiveShell configuration
#------------------------------------------------------------------------------
# TerminalInteractiveShell will inherit config from: InteractiveShell
# auto editing of files with syntax errors.
# c.TerminalInteractiveShell.autoedit_syntax = False
# Use colors for displaying information about objects. Because this information
# is passed through a pager (like 'less'), and some pagers get confused with
# color codes, this capability can be turned off.
# c.TerminalInteractiveShell.color_info = True
# A list of ast.NodeTransformer subclass instances, which will be applied to
# user input before code is run.
# c.TerminalInteractiveShell.ast_transformers = []
#
# c.TerminalInteractiveShell.history_length = 10000
# Don't call post-execute functions that have failed in the past.
# c.TerminalInteractiveShell.disable_failing_post_execute = False
# Show rewritten input, e.g. for autocall.
# c.TerminalInteractiveShell.show_rewritten_input = True
# Set the color scheme (NoColor, Linux, or LightBG).
# c.TerminalInteractiveShell.colors = 'LightBG'
# Autoindent IPython code entered interactively.
# c.TerminalInteractiveShell.autoindent = True
#
# c.TerminalInteractiveShell.separate_in = '\n'
# Deprecated, use PromptManager.in2_template
# c.TerminalInteractiveShell.prompt_in2 = ' .\\D.: '
#
# c.TerminalInteractiveShell.separate_out = ''
# Deprecated, use PromptManager.in_template
# c.TerminalInteractiveShell.prompt_in1 = 'In [\\#]: '
# Make IPython automatically call any callable object even if you didn't type
# explicit parentheses. For example, 'str 43' becomes 'str(43)' automatically.
# The value can be '0' to disable the feature, '1' for 'smart' autocall, where
# it is not applied if there are no more arguments on the line, and '2' for
# 'full' autocall, where all callable objects are automatically called (even if
# no arguments are present).
# c.TerminalInteractiveShell.autocall = 0
# Number of lines of your screen, used to control printing of very long strings.
# Strings longer than this number of lines will be sent through a pager instead
# of directly printed. The default value for this is 0, which means IPython
# will auto-detect your screen size every time it needs to print certain
# potentially long strings (this doesn't change the behavior of the 'print'
# keyword, it's only triggered internally). If for some reason this isn't
# working well (it needs curses support), specify it yourself. Otherwise don't
# change the default.
# c.TerminalInteractiveShell.screen_length = 0
# Set the editor used by IPython (default to $EDITOR/vi/notepad).
# c.TerminalInteractiveShell.editor = 'emacs'
# Deprecated, use PromptManager.justify
# c.TerminalInteractiveShell.prompts_pad_left = True
# The part of the banner to be printed before the profile
# c.TerminalInteractiveShell.banner1 = 'Python 2.7.5 |Anaconda 1.7.0 (x86_64)| (default, Jun 28 2013, 22:20:13) \nType "copyright", "credits" or "license" for more information.\n\nIPython 1.1.0 -- An enhanced Interactive Python.\n? -> Introduction and overview of IPython\'s features.\n%quickref -> Quick reference.\nhelp -> Python\'s own help system.\nobject? -> Details about \'object\', use \'object??\' for extra details.\n'
#
# c.TerminalInteractiveShell.readline_parse_and_bind = ['tab: complete', '"\\C-l": clear-screen', 'set show-all-if-ambiguous on', '"\\C-o": tab-insert', '"\\C-r": reverse-search-history', '"\\C-s": forward-search-history', '"\\C-p": history-search-backward', '"\\C-n": history-search-forward', '"\\e[A": history-search-backward', '"\\e[B": history-search-forward', '"\\C-k": kill-line', '"\\C-u": unix-line-discard']
# The part of the banner to be printed after the profile
# c.TerminalInteractiveShell.banner2 = ''
#
# c.TerminalInteractiveShell.separate_out2 = ''
#
# c.TerminalInteractiveShell.wildcards_case_sensitive = True
#
# c.TerminalInteractiveShell.debug = False
# Set to confirm when you try to exit IPython with an EOF (Control-D in Unix,
# Control-Z/Enter in Windows). By typing 'exit' or 'quit', you can force a
# direct exit without any confirmation.
# c.TerminalInteractiveShell.confirm_exit = True
#
# c.TerminalInteractiveShell.ipython_dir = ''
#
# c.TerminalInteractiveShell.readline_remove_delims = '-/~'
# Start logging to the default log file.
# c.TerminalInteractiveShell.logstart = False
# The name of the logfile to use.
# c.TerminalInteractiveShell.logfile = ''
# The shell program to be used for paging.
# c.TerminalInteractiveShell.pager = 'less'
# Enable magic commands to be called without the leading %.
# c.TerminalInteractiveShell.automagic = True
# Save multi-line entries as one entry in readline history
# c.TerminalInteractiveShell.multiline_history = True
#
# c.TerminalInteractiveShell.readline_use = True
# Enable deep (recursive) reloading by default. IPython can use the deep_reload
# module which reloads changes in modules recursively (it replaces the reload()
# function, so you don't need to change anything to use it). deep_reload()
# forces a full reload of modules whose code may have changed, which the default
# reload() function does not. When deep_reload is off, IPython will use the
# normal reload(), but deep_reload will still be available as dreload().
# c.TerminalInteractiveShell.deep_reload = False
# Start logging to the given file in append mode.
# c.TerminalInteractiveShell.logappend = ''
#
# c.TerminalInteractiveShell.xmode = 'Context'
#
# c.TerminalInteractiveShell.quiet = False
# Enable auto setting the terminal title.
# c.TerminalInteractiveShell.term_title = False
#
# c.TerminalInteractiveShell.object_info_string_level = 0
# Deprecated, use PromptManager.out_template
# c.TerminalInteractiveShell.prompt_out = 'Out[\\#]: '
# Set the size of the output cache. The default is 1000, you can change it
# permanently in your config file. Setting it to 0 completely disables the
# caching system, and the minimum value accepted is 20 (if you provide a value
# less than 20, it is reset to 0 and a warning is issued). This limit is
# defined because otherwise you'll spend more time re-flushing a too small cache
# than working
# c.TerminalInteractiveShell.cache_size = 1000
# 'all', 'last', 'last_expr' or 'none', specifying which nodes should be run
# interactively (displaying output from expressions).
# c.TerminalInteractiveShell.ast_node_interactivity = 'last_expr'
# Automatically call the pdb debugger after every exception.
# c.TerminalInteractiveShell.pdb = False
#------------------------------------------------------------------------------
# PromptManager configuration
#------------------------------------------------------------------------------
# This is the primary interface for producing IPython's prompts.
# Output prompt. '\#' will be transformed to the prompt number
# c.PromptManager.out_template = 'Out[\\#]: '
# Continuation prompt.
# c.PromptManager.in2_template = ' .\\D.: '
# If True (default), each prompt will be right-aligned with the preceding one.
# c.PromptManager.justify = True
# Input prompt. '\#' will be transformed to the prompt number
# c.PromptManager.in_template = 'In [\\#]: '
#
# c.PromptManager.color_scheme = 'Linux'
#------------------------------------------------------------------------------
# HistoryManager configuration
#------------------------------------------------------------------------------
# A class to organize all history-related functionality in one place.
# HistoryManager will inherit config from: HistoryAccessor
#
# c.HistoryManager.db_log_output = False
#
# c.HistoryManager.db_cache_size = 0
# Path to file to use for SQLite history database.
#
# By default, IPython will put the history database in the IPython profile
# directory. If you would rather share one history among profiles, you can set
# this value in each, so that they are consistent.
#
# Due to an issue with fcntl, SQLite is known to misbehave on some NFS mounts.
# If you see IPython hanging, try setting this to something on a local disk,
# e.g::
#
# ipython --HistoryManager.hist_file=/tmp/ipython_hist.sqlite
# c.HistoryManager.hist_file = u''
# Options for configuring the SQLite connection
#
# These options are passed as keyword args to sqlite3.connect when establishing
# database conenctions.
# c.HistoryManager.connection_options = {}
# enable the SQLite history
#
# set enabled=False to disable the SQLite history, in which case there will be
# no stored history, no SQLite connection, and no background saving thread.
# This may be necessary in some threaded environments where IPython is embedded.
# c.HistoryManager.enabled = True
#------------------------------------------------------------------------------
# ProfileDir configuration
#------------------------------------------------------------------------------
# An object to manage the profile directory and its resources.
#
# The profile directory is used by all IPython applications, to manage
# configuration, logging and security.
#
# This object knows how to find, create and manage these directories. This
# should be used by any code that wants to handle profiles.
# Set the profile location directly. This overrides the logic used by the
# `profile` option.
# c.ProfileDir.location = u''
#------------------------------------------------------------------------------
# PlainTextFormatter configuration
#------------------------------------------------------------------------------
# The default pretty-printer.
#
# This uses :mod:`IPython.lib.pretty` to compute the format data of the object.
# If the object cannot be pretty printed, :func:`repr` is used. See the
# documentation of :mod:`IPython.lib.pretty` for details on how to write pretty
# printers. Here is a simple example::
#
# def dtype_pprinter(obj, p, cycle):
# if cycle:
# return p.text('dtype(...)')
# if hasattr(obj, 'fields'):
# if obj.fields is None:
# p.text(repr(obj))
# else:
# p.begin_group(7, 'dtype([')
# for i, field in enumerate(obj.descr):
# if i > 0:
# p.text(',')
# p.breakable()
# p.pretty(field)
# p.end_group(7, '])')
# PlainTextFormatter will inherit config from: BaseFormatter
#
# c.PlainTextFormatter.type_printers = {}
#
# c.PlainTextFormatter.newline = '\n'
#
# c.PlainTextFormatter.float_precision = ''
#
# c.PlainTextFormatter.verbose = False
#
# c.PlainTextFormatter.deferred_printers = {}
#
# c.PlainTextFormatter.pprint = True
#
# c.PlainTextFormatter.max_width = 79
#
# c.PlainTextFormatter.singleton_printers = {}
#------------------------------------------------------------------------------
# IPCompleter configuration
#------------------------------------------------------------------------------
# Extension of the completer class with IPython-specific features
# IPCompleter will inherit config from: Completer
# Instruct the completer to omit private method names
#
# Specifically, when completing on ``object.<tab>``.
#
# When 2 [default]: all names that start with '_' will be excluded.
#
# When 1: all 'magic' names (``__foo__``) will be excluded.
#
# When 0: nothing will be excluded.
# c.IPCompleter.omit__names = 2
# Whether to merge completion results into a single list
#
# If False, only the completion results from the first non-empty completer will
# be returned.
# c.IPCompleter.merge_completions = True
# Instruct the completer to use __all__ for the completion
#
# Specifically, when completing on ``object.<tab>``.
#
# When True: only those names in obj.__all__ will be included.
#
# When False [default]: the __all__ attribute is ignored
# c.IPCompleter.limit_to__all__ = False
# Activate greedy completion
#
# This will enable completion on elements of lists, results of function calls,
# etc., but can be unsafe because the code is actually evaluated on TAB.
# c.IPCompleter.greedy = False
#------------------------------------------------------------------------------
# ScriptMagics configuration
#------------------------------------------------------------------------------
# Magics for talking to scripts
#
# This defines a base `%%script` cell magic for running a cell with a program in
# a subprocess, and registers a few top-level magics that call %%script with
# common interpreters.
# Extra script cell magics to define
#
# This generates simple wrappers of `%%script foo` as `%%foo`.
#
# If you want to add script magics that aren't on your path, specify them in
# script_paths
# c.ScriptMagics.script_magics = []
# Dict mapping short 'ruby' names to full paths, such as '/opt/secret/bin/ruby'
#
# Only necessary for items in script_magics where the default path will not find
# the right interpreter.
# c.ScriptMagics.script_paths = {}
#------------------------------------------------------------------------------
# StoreMagics configuration
#------------------------------------------------------------------------------
# Lightweight persistence for python variables.
#
# Provides the %store magic.
# If True, any %store-d variables will be automatically restored when IPython
# starts.
# c.StoreMagics.autorestore = False

11
notebook/profile_cryptol/startup/README
View File

@ -1,11 +0,0 @@
This is the IPython startup directory
.py and .ipy files in this directory will be run *prior* to any code or files specified
via the exec_lines or exec_files configurables whenever you load this profile.
Files will be run in lexicographical order, so you can control the execution order of files
with a prefix, e.g.::
00-first.py
50-middle.py
99-last.ipy

BIN
notebook/profile_cryptol/static/base/images/ipynblogo.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 13 KiB

7
notebook/profile_cryptol/static/custom/custom.css
View File

@ -1,7 +0,0 @@
/*
Placeholder for custom user CSS
mainly to be overridden in profile/static/custom/custom.css
This will always be an empty file in IPython
*/

49
notebook/profile_cryptol/static/custom/custom.js
View File

@ -1,49 +0,0 @@
// leave at least 2 line with only a star on it below, or doc generation fails
/**
*
*
* Placeholder for custom user javascript
* mainly to be overridden in profile/static/custom/custom.js
* This will always be an empty file in IPython
*
* User could add any javascript in the `profile/static/custom/custom.js` file
* (and should create it if it does not exist).
* It will be executed by the ipython notebook at load time.
*
* Same thing with `profile/static/custom/custom.css` to inject custom css into the notebook.
*
* Example :
*
* Create a custom button in toolbar that execute `%qtconsole` in kernel
* and hence open a qtconsole attached to the same kernel as the current notebook
*
* $([IPython.events]).on('app_initialized.NotebookApp', function(){
* IPython.toolbar.add_buttons_group([
* {
* 'label' : 'run qtconsole',
* 'icon' : 'icon-terminal', // select your icon from http://fortawesome.github.io/Font-Awesome/icons
* 'callback': function () {
* IPython.notebook.kernel.execute('%qtconsole')
* }
* }
* // add more button here if needed.
* ]);
* });
*
* Example :
*
* Use `jQuery.getScript(url [, success(script, textStatus, jqXHR)] );`
* to load custom script into the notebook.
*
* // to load the metadata ui extension example.
* $.getScript('/static/notebook/js/celltoolbarpresets/example.js');
* // or
* // to load the metadata ui extension to control slideshow mode / reveal js for nbconvert
* $.getScript('/static/notebook/js/celltoolbarpresets/slideshow.js');
*
*
* @module IPython
* @namespace IPython
* @class customjs
* @static
*/

5
sbv/Data/README
View File

@ -1,5 +0,0 @@
NOTE: The files in this directory are a slightly modified copy of
Levent Erkok's SBV library (http://github.com/LeventErkok/sbv). Their
inclusion here is temporary; they will be removed once the required
changes have been identified and incorporated into the distributed
version.

730
sbv/Data/SBV.hs
View File

@ -1,730 +0,0 @@
---------------------------------------------------------------------------------
-- |
-- Module : Data.SBV
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- (The sbv library is hosted at <http://github.com/LeventErkok/sbv>.
-- Comments, bug reports, and patches are always welcome.)
--
-- SBV: SMT Based Verification
--
-- Express properties about Haskell programs and automatically prove
-- them using SMT solvers.
--
-- >>> prove $ \x -> x `shiftL` 2 .== 4 * (x :: SWord8)
-- Q.E.D.
--
-- >>> prove $ forAll ["x"] $ \x -> x `shiftL` 2 .== (x :: SWord8)
-- Falsifiable. Counter-example:
-- x = 51 :: SWord8
--
-- The function 'prove' has the following type:
--
-- @
-- 'prove' :: 'Provable' a => a -> 'IO' 'ThmResult'
-- @
--
-- The class 'Provable' comes with instances for n-ary predicates, for arbitrary n.
-- The predicates are just regular Haskell functions over symbolic signed and unsigned
-- bit-vectors. Functions for checking satisfiability ('sat' and 'allSat') are also
-- provided.
--
-- In particular, the sbv library introduces the types:
--
-- * 'SBool': Symbolic Booleans (bits).
--
-- * 'SWord8', 'SWord16', 'SWord32', 'SWord64': Symbolic Words (unsigned).
--
-- * 'SInt8', 'SInt16', 'SInt32', 'SInt64': Symbolic Ints (signed).
--
-- * 'SInteger': Unbounded signed integers.
--
-- * 'SReal': Algebraic-real numbers
--
-- * 'SFloat': IEEE-754 single-precision floating point values
--
-- * 'SDouble': IEEE-754 double-precision floating point values
--
-- * 'SArray', 'SFunArray': Flat arrays of symbolic values.
--
-- * Symbolic polynomials over GF(2^n), polynomial arithmetic, and CRCs.
--
-- * Uninterpreted constants and functions over symbolic values, with user
-- defined SMT-Lib axioms.
--
-- * Uninterpreted sorts, and proofs over such sorts, potentially with axioms.
--
-- The user can construct ordinary Haskell programs using these types, which behave
-- very similar to their concrete counterparts. In particular these types belong to the
-- standard classes 'Num', 'Bits', custom versions of 'Eq' ('EqSymbolic')
-- and 'Ord' ('OrdSymbolic'), along with several other custom classes for simplifying
-- programming with symbolic values. The framework takes full advantage of Haskell's type
-- inference to avoid many common mistakes.
--
-- Furthermore, predicates (i.e., functions that return 'SBool') built out of
-- these types can also be:
--
-- * proven correct via an external SMT solver (the 'prove' function)
--
-- * checked for satisfiability (the 'sat', 'allSat' functions)
--
-- * used in synthesis (the `sat` function with existentials)
--
-- * quick-checked
--
-- If a predicate is not valid, 'prove' will return a counterexample: An
-- assignment to inputs such that the predicate fails. The 'sat' function will
-- return a satisfying assignment, if there is one. The 'allSat' function returns
-- all satisfying assignments, lazily.
--
-- The sbv library uses third-party SMT solvers via the standard SMT-Lib interface:
-- <http://goedel.cs.uiowa.edu/smtlib/>.
--
-- The SBV library is designed to work with any SMT-Lib compliant SMT-solver.
-- Currently, we support the following SMT-Solvers out-of-the box:
--
-- * Z3 from Microsoft: <http://research.microsoft.com/en-us/um/redmond/projects/z3/>
--
-- * Yices from SRI: <http://yices.csl.sri.com/>
--
-- * CVC4 from New York University and University of Iowa: <http://cvc4.cs.nyu.edu/>
--
-- * Boolector from Johannes Kepler University: <http://fmv.jku.at/boolector/>
--
-- * MathSAT from Fondazione Bruno Kessler and DISI-University of Trento: <http://mathsat.fbk.eu/>
--
-- SBV also allows calling these solvers in parallel, either getting results from multiple solvers
-- or returning the fastest one. (See 'proveWithAll', 'proveWithAny', etc.)
--
-- Support for other compliant solvers can be added relatively easily, please
-- get in touch if there is a solver you'd like to see included.
---------------------------------------------------------------------------------
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}
module Data.SBV (
-- * Programming with symbolic values
-- $progIntro
-- ** Symbolic types
-- *** Symbolic bit
SBool
-- *** Unsigned symbolic bit-vectors
, SWord8, SWord16, SWord32, SWord64
-- *** Signed symbolic bit-vectors
, SInt8, SInt16, SInt32, SInt64
-- *** Signed unbounded integers
-- $unboundedLimitations
, SInteger
-- *** IEEE-floating point numbers
-- $floatingPoints
, SFloat, SDouble, RoundingMode(..), nan, infinity, sNaN, sInfinity, fusedMA, isSNaN, isFPPoint
-- *** Signed algebraic reals
-- $algReals
, SReal, AlgReal, toSReal
-- ** Creating a symbolic variable
-- $createSym
, sBool, sWord8, sWord16, sWord32, sWord64, sInt8, sInt16, sInt32, sInt64, sInteger, sReal, sFloat, sDouble
-- ** Creating a list of symbolic variables
-- $createSyms
, sBools, sWord8s, sWord16s, sWord32s, sWord64s, sInt8s, sInt16s, sInt32s, sInt64s, sIntegers, sReals, sFloats, sDoubles
-- *** Abstract SBV type
, SBV
-- *** Arrays of symbolic values
, SymArray(..), SArray, SFunArray, mkSFunArray
-- *** Full binary trees
, STree, readSTree, writeSTree, mkSTree
-- ** Operations on symbolic values
-- *** Word level
, sbvTestBit, sbvPopCount, sbvShiftLeft, sbvShiftRight, sbvSignedShiftArithRight, setBitTo, oneIf, lsb, msb
, sbvRotateLeft, sbvRotateRight
-- *** Predicates
, allEqual, allDifferent, inRange, sElem
-- *** Addition and Multiplication with high-bits
, fullAdder, fullMultiplier
-- *** Blasting/Unblasting
, blastBE, blastLE, FromBits(..)
-- *** Splitting, joining, and extending
, Splittable(..)
-- *** Sign-casting
, SignCast(..)
-- ** Polynomial arithmetic and CRCs
, Polynomial(..), crcBV, crc
-- ** Conditionals: Mergeable values
, Mergeable(..), ite, iteLazy, sBranch
-- ** Symbolic equality
, EqSymbolic(..)
-- ** Symbolic ordering
, OrdSymbolic(..)
-- ** Symbolic integral numbers
, SIntegral
-- ** Division
, SDivisible(..)
-- ** The Boolean class
, Boolean(..)
-- *** Generalizations of boolean operations
, bAnd, bOr, bAny, bAll
-- ** Pretty-printing and reading numbers in Hex & Binary
, PrettyNum(..), readBin
-- * Uninterpreted sorts, constants, and functions
-- $uninterpreted
, Uninterpreted(..), addAxiom
-- * Properties, proofs, and satisfiability
-- $proveIntro
-- ** Predicates
, Predicate, Provable(..), Equality(..)
-- ** Proving properties
, prove, proveWith, isTheorem, isTheoremWith
-- ** Checking satisfiability
, sat, satWith, isSatisfiable, isSatisfiableWith
-- ** Finding all satisfying assignments
, allSat, allSatWith
-- ** Satisfying a sequence of boolean conditions
, solve
-- ** Adding constraints
-- $constrainIntro
, constrain, pConstrain
-- ** Checking constraint vacuity
, isVacuous, isVacuousWith
-- * Proving properties using multiple solvers
-- $multiIntro
, proveWithAll, proveWithAny, satWithAll, satWithAny, allSatWithAll, allSatWithAny
-- * Optimization
-- $optimizeIntro
, minimize, maximize, optimize
, minimizeWith, maximizeWith, optimizeWith
-- * Computing expected values
, expectedValue, expectedValueWith
-- * Model extraction
-- $modelExtraction
-- ** Inspecting proof results
-- $resultTypes
, ThmResult(..), SatResult(..), AllSatResult(..), SMTResult(..)
-- ** Programmable model extraction
-- $programmableExtraction
, SatModel(..), Modelable(..), displayModels, extractModels
, getModelDictionaries, getModelValues, getModelUninterpretedValues
-- * SMT Interface: Configurations and solvers
, SMTConfig(..), SMTLibLogic(..), Logic(..), OptimizeOpts(..), Solver(..), SMTSolver(..), boolector, cvc4, yices, z3, mathSAT, defaultSolverConfig, sbvCurrentSolver, defaultSMTCfg, sbvCheckSolverInstallation, sbvAvailableSolvers
-- * Symbolic computations
, Symbolic, output, SymWord(..)
-- * Getting SMT-Lib output (for offline analysis)
, compileToSMTLib, generateSMTBenchmarks
-- * Test case generation
, genTest, getTestValues, TestVectors, TestStyle(..), renderTest, CW(..), HasKind(..), Kind(..), cwToBool
-- * Code generation from symbolic programs
-- $cCodeGeneration
, SBVCodeGen
-- ** Setting code-generation options
, cgPerformRTCs, cgSetDriverValues, cgGenerateDriver, cgGenerateMakefile
-- ** Designating inputs
, cgInput, cgInputArr
-- ** Designating outputs
, cgOutput, cgOutputArr
-- ** Designating return values
, cgReturn, cgReturnArr
-- ** Code generation with uninterpreted functions
, cgAddPrototype, cgAddDecl, cgAddLDFlags
-- ** Code generation with 'SInteger' and 'SReal' types
-- $unboundedCGen
, cgIntegerSize, cgSRealType, CgSRealType(..)
-- ** Compilation to C
, compileToC, compileToCLib
-- * Module exports
-- $moduleExportIntro
, module Data.Bits
, module Data.Word
, module Data.Int
, module Data.Ratio
) where
import Control.Monad (filterM)
import Control.Concurrent.Async (async, waitAny, waitAnyCancel)
import System.IO.Unsafe (unsafeInterleaveIO) -- only used safely!
import Data.SBV.BitVectors.AlgReals
import Data.SBV.BitVectors.Data
import Data.SBV.BitVectors.Model
import Data.SBV.BitVectors.PrettyNum
import Data.SBV.BitVectors.SignCast
import Data.SBV.BitVectors.Splittable
import Data.SBV.BitVectors.STree
import Data.SBV.Compilers.C
import Data.SBV.Compilers.CodeGen
import Data.SBV.Provers.Prover
import Data.SBV.Tools.GenTest
import Data.SBV.Tools.ExpectedValue
import Data.SBV.Tools.Optimize
import Data.SBV.Tools.Polynomial
import Data.SBV.Utils.Boolean
import Data.Bits
import Data.Int
import Data.Ratio
import Data.Word
-- | The currently active solver, obtained by importing "Data.SBV".
-- To have other solvers /current/, import one of the bridge
-- modules "Data.SBV.Bridge.CVC4", "Data.SBV.Bridge.Yices", or
-- "Data.SBV.Bridge.Z3" directly.
sbvCurrentSolver :: SMTConfig
sbvCurrentSolver = z3
-- | Note that the floating point value NaN does not compare equal to itself,
-- so we need a special recognizer for that. Haskell provides the isNaN predicate
-- with the `RealFrac` class, which unfortunately is not currently implementable for
-- symbolic cases. (Requires trigonometric functions etc.) Thus, we provide this
-- recognizer separately. Note that the definition simply tests equality against
-- itself, which fails for NaN. Who said equality for floating point was reflexive?
isSNaN :: (Floating a, SymWord a) => SBV a -> SBool
isSNaN x = x ./= x
-- | We call a FP number FPPoint if it is neither NaN, nor +/- infinity.
isFPPoint :: (Floating a, SymWord a) => SBV a -> SBool
isFPPoint x = x .== x -- gets rid of NaN's
&&& x .< sInfinity -- gets rid of +inf
&&& x .> -sInfinity -- gets rid of -inf
-- | Form the symbolic conjunction of a given list of boolean conditions. Useful in expressing
-- problems with constraints, like the following:
--
-- @
-- do [x, y, z] <- sIntegers [\"x\", \"y\", \"z\"]
-- solve [x .> 5, y + z .< x]
-- @
solve :: [SBool] -> Symbolic SBool
solve = return . bAnd
-- | Check whether the given solver is installed and is ready to go. This call does a
-- simple call to the solver to ensure all is well.
sbvCheckSolverInstallation :: SMTConfig -> IO Bool
sbvCheckSolverInstallation cfg = do ThmResult r <- proveWith cfg $ \x -> (x+x) .== ((x*2) :: SWord8)
case r of
Unsatisfiable _ -> return True
_ -> return False
-- | The default configs corresponding to supported SMT solvers
defaultSolverConfig :: Solver -> SMTConfig
defaultSolverConfig Z3 = z3
defaultSolverConfig Yices = yices
defaultSolverConfig Boolector = boolector
defaultSolverConfig CVC4 = cvc4
defaultSolverConfig MathSAT = mathSAT
-- | Return the known available solver configs, installed on your machine.
sbvAvailableSolvers :: IO [SMTConfig]
sbvAvailableSolvers = filterM sbvCheckSolverInstallation (map defaultSolverConfig [minBound .. maxBound])
sbvWithAny :: Provable a => [SMTConfig] -> (SMTConfig -> a -> IO b) -> a -> IO (Solver, b)
sbvWithAny [] _ _ = error "SBV.withAny: No solvers given!"
sbvWithAny solvers what a = snd `fmap` (mapM try solvers >>= waitAnyCancel)
where try s = async $ what s a >>= \r -> return (name (solver s), r)
sbvWithAll :: Provable a => [SMTConfig] -> (SMTConfig -> a -> IO b) -> a -> IO [(Solver, b)]
sbvWithAll solvers what a = mapM try solvers >>= (unsafeInterleaveIO . go)
where try s = async $ what s a >>= \r -> return (name (solver s), r)
go [] = return []
go as = do (d, r) <- waitAny as
rs <- unsafeInterleaveIO $ go (filter (/= d) as)
return (r : rs)
-- | Prove a property with multiple solvers, running them in separate threads. The
-- results will be returned in the order produced.
proveWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, ThmResult)]
proveWithAll = (`sbvWithAll` proveWith)
-- | Prove a property with multiple solvers, running them in separate threads. Only
-- the result of the first one to finish will be returned, remaining threads will be killed.
proveWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, ThmResult)
proveWithAny = (`sbvWithAny` proveWith)
-- | Find a satisfying assignment to a property with multiple solvers, running them in separate threads. The
-- results will be returned in the order produced.
satWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, SatResult)]
satWithAll = (`sbvWithAll` satWith)
-- | Find a satisfying assignment to a property with multiple solvers, running them in separate threads. Only
-- the result of the first one to finish will be returned, remaining threads will be killed.
satWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, SatResult)
satWithAny = (`sbvWithAny` satWith)
-- | Find all satisfying assignments to a property with multiple solvers, running them in separate threads. Only
-- the result of the first one to finish will be returned, remaining threads will be killed.
allSatWithAll :: Provable a => [SMTConfig] -> a -> IO [(Solver, AllSatResult)]
allSatWithAll = (`sbvWithAll` allSatWith)
-- | Find all satisfying assignments to a property with multiple solvers, running them in separate threads. Only
-- the result of the first one to finish will be returned, remaining threads will be killed.
allSatWithAny :: Provable a => [SMTConfig] -> a -> IO (Solver, AllSatResult)
allSatWithAny = (`sbvWithAny` allSatWith)
-- | Equality as a proof method. Allows for
-- very concise construction of equivalence proofs, which is very typical in
-- bit-precise proofs.
infix 4 ===
class Equality a where
(===) :: a -> a -> IO ThmResult
instance (SymWord a, EqSymbolic z) => Equality (SBV a -> z) where
k === l = prove $ \a -> k a .== l a
instance (SymWord a, SymWord b, EqSymbolic z) => Equality (SBV a -> SBV b -> z) where
k === l = prove $ \a b -> k a b .== l a b
instance (SymWord a, SymWord b, EqSymbolic z) => Equality ((SBV a, SBV b) -> z) where
k === l = prove $ \a b -> k (a, b) .== l (a, b)
instance (SymWord a, SymWord b, SymWord c, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> z) where
k === l = prove $ \a b c -> k a b c .== l a b c
instance (SymWord a, SymWord b, SymWord c, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c) -> z) where
k === l = prove $ \a b c -> k (a, b, c) .== l (a, b, c)
instance (SymWord a, SymWord b, SymWord c, SymWord d, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> z) where
k === l = prove $ \a b c d -> k a b c d .== l a b c d
instance (SymWord a, SymWord b, SymWord c, SymWord d, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d) -> z) where
k === l = prove $ \a b c d -> k (a, b, c, d) .== l (a, b, c, d)
instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> z) where
k === l = prove $ \a b c d e -> k a b c d e .== l a b c d e
instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e) -> z) where
k === l = prove $ \a b c d e -> k (a, b, c, d, e) .== l (a, b, c, d, e)
instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> z) where
k === l = prove $ \a b c d e f -> k a b c d e f .== l a b c d e f
instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> z) where
k === l = prove $ \a b c d e f -> k (a, b, c, d, e, f) .== l (a, b, c, d, e, f)
instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SymWord g, EqSymbolic z) => Equality (SBV a -> SBV b -> SBV c -> SBV d -> SBV e -> SBV f -> SBV g -> z) where
k === l = prove $ \a b c d e f g -> k a b c d e f g .== l a b c d e f g
instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SymWord g, EqSymbolic z) => Equality ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> z) where
k === l = prove $ \a b c d e f g -> k (a, b, c, d, e, f, g) .== l (a, b, c, d, e, f, g)
-- Haddock section documentation
{- $progIntro
The SBV library is really two things:
* A framework for writing symbolic programs in Haskell, i.e., programs operating on
symbolic values along with the usual concrete counterparts.
* A framework for proving properties of such programs using SMT solvers.
The programming goal of SBV is to provide a /seamless/ experience, i.e., let people program
in the usual Haskell style without distractions of symbolic coding. While Haskell helps
in some aspects (the 'Num' and 'Bits' classes simplify coding), it makes life harder
in others. For instance, @if-then-else@ only takes 'Bool' as a test in Haskell, and
comparisons ('>' etc.) only return 'Bool's. Clearly we would like these values to be
symbolic (i.e., 'SBool'), thus stopping us from using some native Haskell constructs.
When symbolic versions of operators are needed, they are typically obtained by prepending a dot,
for instance '==' becomes '.=='. Care has been taken to make the transition painless. In
particular, any Haskell program you build out of symbolic components is fully concretely
executable within Haskell, without the need for any custom interpreters. (They are truly
Haskell programs, not AST's built out of pieces of syntax.) This provides for an integrated
feel of the system, one of the original design goals for SBV.
-}
{- $proveIntro
The SBV library provides a "push-button" verification system via automated SMT solving. The
design goal is to let SMT solvers be used without any knowledge of how SMT solvers work
or how different logics operate. The details are hidden behind the SBV framework, providing
Haskell programmers with a clean API that is unencumbered by the details of individual solvers.
To that end, we use the SMT-Lib standard (<http://goedel.cs.uiowa.edu/smtlib/>)
to communicate with arbitrary SMT solvers.
-}
{- $multiIntro
On a multi-core machine, it might be desirable to try a given property using multiple SMT solvers,
using parallel threads. Even with machines with single-cores, threading can be helpful if you
want to try out multiple-solvers but do not know which one would work the best
for the problem at hand ahead of time.
The functions in this section allow proving/satisfiability-checking with multiple
backends at the same time. Each function comes in two variants, one that
returns the results from all solvers, the other that returns the fastest one.
The @All@ variants, (i.e., 'proveWithAll', 'satWithAll', 'allSatWithAll') run all solvers and
return all the results. SBV internally makes sure that the result is lazily generated; so,
the order of solvers given does not matter. In other words, the order of results will follow
the order of the solvers as they finish, not as given by the user. These variants are useful when you
want to make sure multiple-solvers agree (or disagree!) on a given problem.
The @Any@ variants, (i.e., 'proveWithAny', 'satWithAny', 'allSatWithAny') will run all the solvers
in parallel, and return the results of the first one finishing. The other threads will then be killed. These variants
are useful when you do not care if the solvers produce the same result, but rather want to get the
solution as quickly as possible, taking advantage of modern many-core machines.
Note that the function 'sbvAvailableSolvers' will return all the installed solvers, which can be
used as the first argument to all these functions, if you simply want to try all available solvers on a machine.
-}
{- $optimizeIntro
Symbolic optimization. A call of the form:
@minimize Quantified cost n valid@
returns @Just xs@, such that:
* @xs@ has precisely @n@ elements
* @valid xs@ holds
* @cost xs@ is minimal. That is, for all sequences @ys@ that satisfy the first two criteria above, @cost xs .<= cost ys@ holds.
If there is no such sequence, then 'minimize' will return 'Nothing'.
The function 'maximize' is similar, except the comparator is '.>='. So the value returned has the largest cost (or value, in that case).
The function 'optimize' allows the user to give a custom comparison function.
The 'OptimizeOpts' argument controls how the optimization is done. If 'Quantified' is used, then the SBV optimization engine satisfies the following predicate:
@exists xs. forall ys. valid xs && (valid ys ``implies`` (cost xs ``cmp`` cost ys))@
Note that this may cause efficiency problems as it involves alternating quantifiers.
If 'OptimizeOpts' is set to 'Iterative' 'True', then SBV will programmatically
search for an optimal solution, by repeatedly calling the solver appropriately. (The boolean argument controls whether progress reports are given. Use
'False' for quiet operation.) Note that the quantified and iterative versions are two different optimization approaches and may not necessarily yield the same
results. In particular, the quantified version can find solutions where there is no global optimum value, while the iterative version would simply loop forever
in such cases. On the other hand, the iterative version might be more suitable if the quantified version of the problem is too hard to deal with by the SMT solver.
-}
{- $modelExtraction
The default 'Show' instances for prover calls provide all the counter-example information in a
human-readable form and should be sufficient for most casual uses of sbv. However, tools built
on top of sbv will inevitably need to look into the constructed models more deeply, programmatically
extracting their results and performing actions based on them. The API provided in this section
aims at simplifying this task.
-}
{- $resultTypes
'ThmResult', 'SatResult', and 'AllSatResult' are simple newtype wrappers over 'SMTResult'. Their
main purpose is so that we can provide custom 'Show' instances to print results accordingly.
-}
{- $programmableExtraction
While default 'Show' instances are sufficient for most use cases, it is sometimes desirable (especially
for library construction) that the SMT-models are reinterpreted in terms of domain types. Programmable
extraction allows getting arbitrarily typed models out of SMT models.
-}
{- $cCodeGeneration
The SBV library can generate straight-line executable code in C. (While other target languages are
certainly possible, currently only C is supported.) The generated code will perform no run-time memory-allocations,
(no calls to @malloc@), so its memory usage can be predicted ahead of time. Also, the functions will execute precisely the
same instructions in all calls, so they have predictable timing properties as well. The generated code
has no loops or jumps, and is typically quite fast. While the generated code can be large due to complete unrolling,
these characteristics make them suitable for use in hard real-time systems, as well as in traditional computing.
-}
{- $unboundedCGen
The types 'SInteger' and 'SReal' are unbounded quantities that have no direct counterparts in the C language. Therefore,
it is not possible to generate standard C code for SBV programs using these types, unless custom libraries are available. To
overcome this, SBV allows the user to explicitly set what the corresponding types should be for these two cases, using
the functions below. Note that while these mappings will produce valid C code, the resulting code will be subject to
overflow/underflows for 'SInteger', and rounding for 'SReal', so there is an implicit loss of precision.
If the user does /not/ specify these mappings, then SBV will
refuse to compile programs that involve these types.
-}
{- $moduleExportIntro
The SBV library exports the following modules wholesale, as user programs will have to import these
modules to make any sensible use of the SBV functionality.
-}
{- $createSym
These functions simplify declaring symbolic variables of various types. Strictly speaking, they are just synonyms
for 'free' (specialized at the given type), but they might be easier to use.
-}
{- $createSyms
These functions simplify declaring a sequence symbolic variables of various types. Strictly speaking, they are just synonyms
for 'mapM' 'free' (specialized at the given type), but they might be easier to use.
-}
{- $unboundedLimitations
The SBV library supports unbounded signed integers with the type 'SInteger', which are not subject to
overflow/underflow as it is the case with the bounded types, such as 'SWord8', 'SInt16', etc. However,
some bit-vector based operations are /not/ supported for the 'SInteger' type while in the verification mode. That
is, you can use these operations on 'SInteger' values during normal programming/simulation.
but the SMT translation will not support these operations since there corresponding operations are not supported in SMT-Lib.
Note that this should rarely be a problem in practice, as these operations are mostly meaningful on fixed-size
bit-vectors. The operations that are restricted to bounded word/int sizes are:
* Rotations and shifts: 'rotateL', 'rotateR', 'shiftL', 'shiftR'
* Bitwise logical ops: '.&.', '.|.', 'xor', 'complement'
* Extraction and concatenation: 'split', '#', and 'extend' (see the 'Splittable' class)
Usual arithmetic ('+', '-', '*', 'sQuotRem', 'sQuot', 'sRem', 'sDivMod', 'sDiv', 'sMod') and logical operations ('.<', '.<=', '.>', '.>=', '.==', './=') operations are
supported for 'SInteger' fully, both in programming and verification modes.
-}
{- $algReals
Algebraic reals are roots of single-variable polynomials with rational coefficients. (See
<http://en.wikipedia.org/wiki/Algebraic_number>.) Note that algebraic reals are infinite
precision numbers, but they do not cover all /real/ numbers. (In particular, they cannot
represent transcendentals.) Some irrational numbers are algebraic (such as @sqrt 2@), while
others are not (such as pi and e).
SBV can deal with real numbers just fine, since the theory of reals is decidable. (See
<http://goedel.cs.uiowa.edu/smtlib/theories/Reals.smt2>.) In addition, by leveraging backend
solver capabilities, SBV can also represent and solve non-linear equations involving real-variables.
(For instance, the Z3 SMT solver, supports polynomial constraints on reals starting with v4.0.)
-}
{- $floatingPoints
Floating point numbers are defined by the IEEE-754 standard; and correspond to Haskell's
'Float' and 'Double' types. For SMT support with floating-point numbers, see the paper
by Rummer and Wahl: <http://www.philipp.ruemmer.org/publications/smt-fpa.pdf>.
-}
{- $constrainIntro
A constraint is a means for restricting the input domain of a formula. Here's a simple
example:
@
do x <- 'exists' \"x\"
y <- 'exists' \"y\"
'constrain' $ x .> y
'constrain' $ x + y .>= 12
'constrain' $ y .>= 3
...
@
The first constraint requires @x@ to be larger than @y@. The scond one says that
sum of @x@ and @y@ must be at least @12@, and the final one says that @y@ to be at least @3@.
Constraints provide an easy way to assert additional properties on the input domain, right at the point of
the introduction of variables.
Note that the proper reading of a constraint
depends on the context:
* In a 'sat' (or 'allSat') call: The constraint added is asserted
conjunctively. That is, the resulting satisfying model (if any) will
always satisfy all the constraints given.
* In a 'prove' call: In this case, the constraint acts as an implication.
The property is proved under the assumption that the constraint
holds. In other words, the constraint says that we only care about
the input space that satisfies the constraint.
* In a 'quickCheck' call: The constraint acts as a filter for 'quickCheck';
if the constraint does not hold, then the input value is considered to be irrelevant
and is skipped. Note that this is similar to 'prove', but is stronger: We do not
accept a test case to be valid just because the constraints fail on them, although
semantically the implication does hold. We simply skip that test case as a /bad/
test vector.
* In a 'genTest' call: Similar to 'quickCheck' and 'prove': If a constraint
does not hold, the input value is ignored and is not included in the test
set.
A good use case (in fact the motivating use case) for 'constrain' is attaching a
constraint to a 'forall' or 'exists' variable at the time of its creation.
Also, the conjunctive semantics for 'sat' and the implicative
semantics for 'prove' simplify programming by choosing the correct interpretation
automatically. However, one should be aware of the semantic difference. For instance, in
the presence of constraints, formulas that are /provable/ are not necessarily
/satisfiable/. To wit, consider:
@
do x <- 'exists' \"x\"
'constrain' $ x .< x
return $ x .< (x :: 'SWord8')
@
This predicate is unsatisfiable since no element of 'SWord8' is less than itself. But
it's (vacuously) true, since it excludes the entire domain of values, thus making the proof
trivial. Hence, this predicate is provable, but is not satisfiable. To make sure the given
constraints are not vacuous, the functions 'isVacuous' (and 'isVacuousWith') can be used.
Also note that this semantics imply that test case generation ('genTest') and quick-check
can take arbitrarily long in the presence of constraints, if the random input values generated
rarely satisfy the constraints. (As an extreme case, consider @'constrain' 'false'@.)
A probabilistic constraint (see 'pConstrain') attaches a probability threshold for the
constraint to be considered. For instance:
@
'pConstrain' 0.8 c
@
will make sure that the condition @c@ is satisfied 80% of the time (and correspondingly, falsified 20%
of the time), in expectation. This variant is useful for 'genTest' and 'quickCheck' functions, where we
want to filter the test cases according to some probability distribution, to make sure that the test-vectors
are drawn from interesting subsets of the input space. For instance, if we were to generate 100 test cases
with the above constraint, we'd expect about 80 of them to satisfy the condition @c@, while about 20 of them
will fail it.
The following properties hold:
@
'constrain' = 'pConstrain' 1
'pConstrain' t c = 'pConstrain' (1-t) (not c)
@
Note that while 'constrain' can be used freely, 'pConstrain' is only allowed in the contexts of
'genTest' or 'quickCheck'. Calls to 'pConstrain' in a prove/sat call will be rejected as SBV does not
deal with probabilistic constraints when it comes to satisfiability and proofs.
Also, both 'constrain' and 'pConstrain' calls during code-generation will also be rejected, for similar reasons.
-}
{- $uninterpreted
Users can introduce new uninterpreted sorts simply by defining a data-type in Haskell and registering it as such. The
following example demonstrates:
@
data B = B deriving (Eq, Ord, Data, Typeable)
instance SymWord B
instance HasKind B
@
(Note that you'll also need to use the language pragma @DeriveDataTypeable@, and import @Data.Generics@ for the above to work.)
Once GHC implements derivable user classes (<http://hackage.haskell.org/trac/ghc/ticket/5462>), we will be able to simplify this to:
@
data B = B deriving (Eq, Ord, Data, Typeable, SymWord, HasKind)
@
This is all it takes to introduce 'B' as an uninterpreted sort in SBV, which makes the type @SBV B@ automagically become available as the type
of symbolic values that ranges over 'B' values.
Uninterpreted functions over both uninterpreted and regular sorts can be declared using the facilities introduced by
the 'Uninterpreted' class.
-}
{-# ANN module "HLint: ignore Use import/export shortcut" #-}

228
sbv/Data/SBV/BitVectors/AlgReals.hs
View File

@ -1,228 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.BitVectors.AlgReals
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Algrebraic reals in Haskell.
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.SBV.BitVectors.AlgReals (AlgReal(..), mkPolyReal, algRealToSMTLib2, algRealToHaskell, mergeAlgReals, isExactRational, algRealStructuralEqual, algRealStructuralCompare) where
import Data.List (sortBy, isPrefixOf, partition)
import Data.Ratio ((%), numerator, denominator)
import Data.Function (on)
import System.Random
import Test.QuickCheck (Arbitrary(..))
-- | Algebraic reals. Note that the representation is left abstract. We represent
-- rational results explicitly, while the roots-of-polynomials are represented
-- implicitly by their defining equation
data AlgReal = AlgRational Bool Rational -- bool says it's exact (i.e., SMT-solver did not return it with ? at the end.)
| AlgPolyRoot (Integer, Polynomial) -- which root
(Maybe String) -- approximate decimal representation with given precision, if available
-- | Check wheter a given argument is an exact rational
isExactRational :: AlgReal -> Bool
isExactRational (AlgRational True _) = True
isExactRational _ = False
-- | A univariate polynomial, represented simply as a
-- coefficient list. For instance, "5x^3 + 2x - 5" is
-- represented as [(5, 3), (2, 1), (-5, 0)]
newtype Polynomial = Polynomial [(Integer, Integer)]
deriving (Eq, Ord)
-- | Construct a poly-root real with a given approximate value (either as a decimal, or polynomial-root)
mkPolyReal :: Either (Bool, String) (Integer, [(Integer, Integer)]) -> AlgReal
mkPolyReal (Left (exact, str))
= case (str, break (== '.') str) of
("", (_, _)) -> AlgRational exact 0
(_, (x, '.':y)) -> AlgRational exact (read (x++y) % (10 ^ length y))
(_, (x, _)) -> AlgRational exact (read x % 1)
mkPolyReal (Right (k, coeffs))
= AlgPolyRoot (k, Polynomial (normalize coeffs)) Nothing
where normalize :: [(Integer, Integer)] -> [(Integer, Integer)]
normalize = merge . sortBy (flip compare `on` snd)
merge [] = []
merge [x] = [x]
merge ((a, b):r@((c, d):xs))
| b == d = merge ((a+c, b):xs)
| True = (a, b) : merge r
instance Show Polynomial where
show (Polynomial xs) = chkEmpty (join (concat [term p | p@(_, x) <- xs, x /= 0])) ++ " = " ++ show c
where c = -1 * head ([k | (k, 0) <- xs] ++ [0])
term ( 0, _) = []
term ( 1, 1) = [ "x"]
term ( 1, p) = [ "x^" ++ show p]
term (-1, 1) = ["-x"]
term (-1, p) = ["-x^" ++ show p]
term (k, 1) = [show k ++ "x"]
term (k, p) = [show k ++ "x^" ++ show p]
join [] = ""
join (k:ks) = k ++ s ++ join ks
where s = case ks of
[] -> ""
(y:_) | "-" `isPrefixOf` y -> ""
| "+" `isPrefixOf` y -> ""
| True -> "+"
chkEmpty s = if null s then "0" else s
instance Show AlgReal where
show (AlgRational exact a) = showRat exact a
show (AlgPolyRoot (i, p) mbApprox) = "root(" ++ show i ++ ", " ++ show p ++ ")" ++ maybe "" app mbApprox
where app v | last v == '?' = " = " ++ init v ++ "..."
| True = " = " ++ v
-- lift unary op through an exact rational, otherwise bail
lift1 :: String -> (Rational -> Rational) -> AlgReal -> AlgReal
lift1 _ o (AlgRational e a) = AlgRational e (o a)
lift1 nm _ a = error $ "AlgReal." ++ nm ++ ": unsupported argument: " ++ show a
-- lift binary op through exact rationals, otherwise bail
lift2 :: String -> (Rational -> Rational -> Rational) -> AlgReal -> AlgReal -> AlgReal
lift2 _ o (AlgRational True a) (AlgRational True b) = AlgRational True (a `o` b)
lift2 nm _ a b = error $ "AlgReal." ++ nm ++ ": unsupported arguments: " ++ show (a, b)
-- The idea in the instances below is that we will fully support operations
-- on "AlgRational" AlgReals, but leave everything else undefined. When we are
-- on the Haskell side, the AlgReal's are *not* reachable. They only represent
-- return values from SMT solvers, which we should *not* need to manipulate.
instance Eq AlgReal where
AlgRational True a == AlgRational True b = a == b
a == b = error $ "AlgReal.==: unsupported arguments: " ++ show (a, b)
instance Ord AlgReal where
AlgRational True a `compare` AlgRational True b = a `compare` b
a `compare` b = error $ "AlgReal.compare: unsupported arguments: " ++ show (a, b)
-- | Structural equality for AlgReal; used when constants are Map keys
algRealStructuralEqual :: AlgReal -> AlgReal -> Bool
AlgRational a b `algRealStructuralEqual` AlgRational c d = (a, b) == (c, d)
AlgPolyRoot a b `algRealStructuralEqual` AlgPolyRoot c d = (a, b) == (c, d)
_ `algRealStructuralEqual` _ = False
-- | Structural comparisons for AlgReal; used when constants are Map keys
algRealStructuralCompare :: AlgReal -> AlgReal -> Ordering
AlgRational a b `algRealStructuralCompare` AlgRational c d = (a, b) `compare` (c, d)
AlgRational _ _ `algRealStructuralCompare` AlgPolyRoot _ _ = LT
AlgPolyRoot _ _ `algRealStructuralCompare` AlgRational _ _ = GT
AlgPolyRoot a b `algRealStructuralCompare` AlgPolyRoot c d = (a, b) `compare` (c, d)
instance Num AlgReal where
(+) = lift2 "+" (+)
(*) = lift2 "*" (*)
(-) = lift2 "-" (-)
negate = lift1 "negate" negate
abs = lift1 "abs" abs
signum = lift1 "signum" signum
fromInteger = AlgRational True . fromInteger
instance Fractional AlgReal where
(/) = lift2 "/" (/)
fromRational = AlgRational True
instance Real AlgReal where
toRational (AlgRational True v) = v
toRational x = error $ "AlgReal.toRational: Argument cannot be represented as a rational value: " ++ algRealToHaskell x
instance Random Rational where
random g = let (a, g') = random g
(b, g'') = random g'
in (a % b, g'')
-- this may not be quite kosher, but will do for our purposes (test-generation, mainly)
randomR (l, h) g = let (ln, ld) = (numerator l, denominator l)
(hn, hd) = (numerator h, denominator h)
(a, g') = randomR (ln*hd, hn*ld) g
in (a % (ld * hd), g')
instance Random AlgReal where
random g = let (a, g') = random g in (AlgRational True a, g')
randomR (AlgRational True l, AlgRational True h) g = let (a, g') = randomR (l, h) g in (AlgRational True a, g')
randomR lh _ = error $ "AlgReal.randomR: unsupported bounds: " ++ show lh
-- | Render an 'AlgReal' as an SMTLib2 value. Only supports rationals for the time being.
algRealToSMTLib2 :: AlgReal -> String
algRealToSMTLib2 (AlgRational True r)
| m == 0 = "0.0"
| m < 0 = "(- (/ " ++ show (abs m) ++ ".0 " ++ show n ++ ".0))"
| True = "(/ " ++ show m ++ ".0 " ++ show n ++ ".0)"
where (m, n) = (numerator r, denominator r)
algRealToSMTLib2 r@(AlgRational False _)
= error $ "SBV: Unexpected inexact rational to be converted to SMTLib2: " ++ show r
algRealToSMTLib2 (AlgPolyRoot (i, Polynomial xs) _) = "(root-obj (+ " ++ unwords (concatMap term xs) ++ ") " ++ show i ++ ")"
where term (0, _) = []
term (k, 0) = [coeff k]
term (1, 1) = ["x"]
term (1, p) = ["(^ x " ++ show p ++ ")"]
term (k, 1) = ["(* " ++ coeff k ++ " x)"]
term (k, p) = ["(* " ++ coeff k ++ " (^ x " ++ show p ++ "))"]
coeff n | n < 0 = "(- " ++ show (abs n) ++ ")"
| True = show n
-- | Render an 'AlgReal' as a Haskell value. Only supports rationals, since there is no corresponding
-- standard Haskell type that can represent root-of-polynomial variety.
algRealToHaskell :: AlgReal -> String
algRealToHaskell (AlgRational True r) = "((" ++ show r ++ ") :: Rational)"
algRealToHaskell r = error $ "SBV.algRealToHaskell: Unsupported argument: " ++ show r
-- Try to show a rational precisely if we can, with finite number of
-- digits. Otherwise, show it as a rational value.
showRat :: Bool -> Rational -> String
showRat exact r = p $ case f25 (denominator r) [] of
Nothing -> show r -- bail out, not precisely representable with finite digits
Just (noOfZeros, num) -> let present = length num
in neg $ case noOfZeros `compare` present of
LT -> let (b, a) = splitAt (present - noOfZeros) num in b ++ "." ++ if null a then "0" else a
EQ -> "0." ++ num
GT -> "0." ++ replicate (noOfZeros - present) '0' ++ num
where p = if exact then id else (++ "...")
neg = if r < 0 then ('-':) else id
-- factor a number in 2's and 5's if possible
-- If so, it'll return the number of digits after the zero
-- to reach the next power of 10, and the numerator value scaled
-- appropriately and shown as a string
f25 :: Integer -> [Integer] -> Maybe (Int, String)
f25 1 sofar = let (ts, fs) = partition (== 2) sofar
[lts, lfs] = map length [ts, fs]
noOfZeros = lts `max` lfs
in Just (noOfZeros, show (abs (numerator r) * factor ts fs))
f25 v sofar = let (q2, r2) = v `quotRem` 2
(q5, r5) = v `quotRem` 5
in case (r2, r5) of
(0, _) -> f25 q2 (2 : sofar)
(_, 0) -> f25 q5 (5 : sofar)
_ -> Nothing
-- compute the next power of 10 we need to get to
factor [] fs = product [2 | _ <- fs]
factor ts [] = product [5 | _ <- ts]
factor (_:ts) (_:fs) = factor ts fs
-- | Merge the representation of two algebraic reals, one assumed to be
-- in polynomial form, the other in decimal. Arguments can be the same
-- kind, so long as they are both rationals and equivalent; if not there
-- must be one that is precise. It's an error to pass anything
-- else to this function! (Used in reconstructing SMT counter-example values with reals).
mergeAlgReals :: String -> AlgReal -> AlgReal -> AlgReal
mergeAlgReals _ f@(AlgRational exact r) (AlgPolyRoot kp Nothing)
| exact = f
| True = AlgPolyRoot kp (Just (showRat False r))
mergeAlgReals _ (AlgPolyRoot kp Nothing) f@(AlgRational exact r)
| exact = f
| True = AlgPolyRoot kp (Just (showRat False r))
mergeAlgReals _ f@(AlgRational e1 r1) s@(AlgRational e2 r2)
| (e1, r1) == (e2, r2) = f
| e1 = f
| e2 = s
mergeAlgReals m _ _ = error m
-- Quickcheck instance
instance Arbitrary AlgReal where
arbitrary = AlgRational True `fmap` arbitrary

1436
sbv/Data/SBV/BitVectors/Data.hs
View File

File diff suppressed because it is too large Load Diff

1814
sbv/Data/SBV/BitVectors/Model.hs
View File

File diff suppressed because it is too large Load Diff

242
sbv/Data/SBV/BitVectors/PrettyNum.hs
View File

@ -1,242 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.BitVectors.PrettyNum
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Number representations in hex/bin
-----------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Data.SBV.BitVectors.PrettyNum (
PrettyNum(..), readBin, shex, shexI, sbin, sbinI
, showCFloat, showCDouble, showHFloat, showHDouble
, showSMTFloat, showSMTDouble, smtRoundingMode
) where
import Data.Char (ord)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.List (isPrefixOf)
import Data.Maybe (fromJust)
import Data.Ratio (numerator, denominator)
import Data.Word (Word8, Word16, Word32, Word64)
import Numeric (showIntAtBase, showHex, readInt)
import Data.SBV.BitVectors.Data
-- | PrettyNum class captures printing of numbers in hex and binary formats; also supporting negative numbers.
--
-- Minimal complete definition: 'hexS' and 'binS'
class PrettyNum a where
-- | Show a number in hexadecimal (starting with @0x@ and type.)
hexS :: a -> String
-- | Show a number in binary (starting with @0b@ and type.)
binS :: a -> String
-- | Show a number in hex, without prefix, or types.
hex :: a -> String
-- | Show a number in bin, without prefix, or types.
bin :: a -> String
-- Why not default methods? Because defaults need "Integral a" but Bool is not..
instance PrettyNum Bool where
{hexS = show; binS = show; hex = show; bin = show}
instance PrettyNum Word8 where
{hexS = shex True True (False,8) ; binS = sbin True True (False,8) ; hex = shex False False (False,8) ; bin = sbin False False (False,8) ;}
instance PrettyNum Int8 where
{hexS = shex True True (True,8) ; binS = sbin True True (True,8) ; hex = shex False False (True,8) ; bin = sbin False False (True,8) ;}
instance PrettyNum Word16 where
{hexS = shex True True (False,16); binS = sbin True True (False,16); hex = shex False False (False,16); bin = sbin False False (False,16);}
instance PrettyNum Int16 where
{hexS = shex True True (True,16); binS = sbin True True (True,16) ; hex = shex False False (True,16); bin = sbin False False (True,16) ;}
instance PrettyNum Word32 where
{hexS = shex True True (False,32); binS = sbin True True (False,32); hex = shex False False (False,32); bin = sbin False False (False,32);}
instance PrettyNum Int32 where
{hexS = shex True True (True,32); binS = sbin True True (True,32) ; hex = shex False False (True,32); bin = sbin False False (True,32) ;}
instance PrettyNum Word64 where
{hexS = shex True True (False,64); binS = sbin True True (False,64); hex = shex False False (False,64); bin = sbin False False (False,64);}
instance PrettyNum Int64 where
{hexS = shex True True (True,64); binS = sbin True True (True,64) ; hex = shex False False (True,64); bin = sbin False False (True,64) ;}
instance PrettyNum Integer where
{hexS = shexI True True; binS = sbinI True True; hex = shexI False False; bin = sbinI False False;}
instance PrettyNum CW where
hexS cw | cwIsBit cw = hexS (cwToBool cw)
| isReal cw = let CWAlgReal w = cwVal cw in show w
| not (isBounded cw) = let CWInteger w = cwVal cw in shexI True True w
| isUninterpreted cw = show cw
| True = let CWInteger w = cwVal cw in shex True True (hasSign cw, intSizeOf cw) w
binS cw | cwIsBit cw = binS (cwToBool cw)
| isReal cw = let CWAlgReal w = cwVal cw in show w
| not (isBounded cw) = let CWInteger w = cwVal cw in sbinI True True w
| isUninterpreted cw = show cw
| True = let CWInteger w = cwVal cw in sbin True True (hasSign cw, intSizeOf cw) w
hex cw | cwIsBit cw = hexS (cwToBool cw)
| isReal cw = let CWAlgReal w = cwVal cw in show w
| not (isBounded cw) = let CWInteger w = cwVal cw in shexI False False w
| isUninterpreted cw = show cw
| True = let CWInteger w = cwVal cw in shex False False (hasSign cw, intSizeOf cw) w
bin cw | cwIsBit cw = binS (cwToBool cw)
| isReal cw = let CWAlgReal w = cwVal cw in show w
| not (isBounded cw) = let CWInteger w = cwVal cw in sbinI False False w
| isUninterpreted cw = show cw
| True = let CWInteger w = cwVal cw in sbin False False (hasSign cw, intSizeOf cw) w
instance (SymWord a, PrettyNum a) => PrettyNum (SBV a) where
hexS s = maybe (show s) (hexS :: a -> String) $ unliteral s
binS s = maybe (show s) (binS :: a -> String) $ unliteral s
hex s = maybe (show s) (hex :: a -> String) $ unliteral s
bin s = maybe (show s) (bin :: a -> String) $ unliteral s
-- | Show as a hexadecimal value. First bool controls whether type info is printed
-- while the second boolean controls wether 0x prefix is printed. The tuple is
-- the signedness and the bit-length of the input. The length of the string
-- will /not/ depend on the value, but rather the bit-length.
shex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String
shex shType shPre (signed, size) a
| a < 0
= "-" ++ pre ++ pad l (s16 (abs (fromIntegral a :: Integer))) ++ t
| True
= pre ++ pad l (s16 a) ++ t
where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size
| True = ""
pre | shPre = "0x"
| True = ""
l = (size + 3) `div` 4
-- | Show as a hexadecimal value, integer version. Almost the same as shex above
-- except we don't have a bit-length so the length of the string will depend
-- on the actual value.
shexI :: Bool -> Bool -> Integer -> String
shexI shType shPre a
| a < 0
= "-" ++ pre ++ s16 (abs a) ++ t
| True
= pre ++ s16 a ++ t
where t | shType = " :: Integer"
| True = ""
pre | shPre = "0x"
| True = ""
-- | Similar to 'shex'; except in binary.
sbin :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> String
sbin shType shPre (signed,size) a
| a < 0
= "-" ++ pre ++ pad size (s2 (abs (fromIntegral a :: Integer))) ++ t
| True
= pre ++ pad size (s2 a) ++ t
where t | shType = " :: " ++ (if signed then "Int" else "Word") ++ show size
| True = ""
pre | shPre = "0b"
| True = ""
-- | Similar to 'shexI'; except in binary.
sbinI :: Bool -> Bool -> Integer -> String
sbinI shType shPre a
| a < 0
= "-" ++ pre ++ s2 (abs a) ++ t
| True
= pre ++ s2 a ++ t
where t | shType = " :: Integer"
| True = ""
pre | shPre = "0b"
| True = ""
-- | Pad a string to a given length. If the string is longer, then we don't drop anything.
pad :: Int -> String -> String
pad l s = replicate (l - length s) '0' ++ s
-- | Binary printer
s2 :: (Show a, Integral a) => a -> String
s2 v = showIntAtBase 2 dig v "" where dig = fromJust . flip lookup [(0, '0'), (1, '1')]
-- | Hex printer
s16 :: (Show a, Integral a) => a -> String
s16 v = showHex v ""
-- | A more convenient interface for reading binary numbers, also supports negative numbers
readBin :: Num a => String -> a
readBin ('-':s) = -(readBin s)
readBin s = case readInt 2 isDigit cvt s' of
[(a, "")] -> a
_ -> error $ "SBV.readBin: Cannot read a binary number from: " ++ show s
where cvt c = ord c - ord '0'
isDigit = (`elem` "01")
s' | "0b" `isPrefixOf` s = drop 2 s
| True = s
-- | A version of show for floats that generates correct C literals for nan/infinite. NB. Requires "math.h" to be included.
showCFloat :: Float -> String
showCFloat f
| isNaN f = "((float) NAN)"
| isInfinite f, f < 0 = "((float) (-INFINITY))"
| isInfinite f = "((float) INFINITY)"
| True = show f ++ "F"
-- | A version of show for doubles that generates correct C literals for nan/infinite. NB. Requires "math.h" to be included.
showCDouble :: Double -> String
showCDouble f
| isNaN f = "((double) NAN)"
| isInfinite f, f < 0 = "((double) (-INFINITY))"
| isInfinite f = "((double) INFINITY)"
| True = show f
-- | A version of show for floats that generates correct Haskell literals for nan/infinite
showHFloat :: Float -> String
showHFloat f
| isNaN f = "((0/0) :: Float)"
| isInfinite f, f < 0 = "((-1/0) :: Float)"
| isInfinite f = "((1/0) :: Float)"
| True = show f
-- | A version of show for doubles that generates correct Haskell literals for nan/infinite
showHDouble :: Double -> String
showHDouble d
| isNaN d = "((0/0) :: Double)"
| isInfinite d, d < 0 = "((-1/0) :: Double)"
| isInfinite d = "((1/0) :: Double)"
| True = show d
-- | A version of show for floats that generates correct SMTLib literals using the rounding mode
showSMTFloat :: RoundingMode -> Float -> String
showSMTFloat rm f
| isNaN f = as "NaN"
| isInfinite f, f < 0 = as "minusInfinity"
| isInfinite f = as "plusInfinity"
| isNegativeZero f = "(- ((_ asFloat 8 24) " ++ smtRoundingMode rm ++ " (/ 0 1)))"
| True = "((_ asFloat 8 24) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational f) ++ ")"
where as s = "(as " ++ s ++ " (_ FP 8 24))"
-- | A version of show for doubles that generates correct SMTLib literals using the rounding mode
showSMTDouble :: RoundingMode -> Double -> String
showSMTDouble rm d
| isNaN d = as "NaN"
| isInfinite d, d < 0 = as "minusInfinity"
| isInfinite d = as "plusInfinity"
| isNegativeZero d = "(- ((_ asFloat 11 53) " ++ smtRoundingMode rm ++ " (/ 0 1)))"
| True = "((_ asFloat 11 53) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational d) ++ ")"
where as s = "(as " ++ s ++ " (_ FP 11 53))"
-- | Show a rational in SMTLib format
toSMTLibRational :: Rational -> String
toSMTLibRational r
| n < 0
= "(- (/ " ++ show (abs n) ++ " " ++ show d ++ "))"
| True
= "(/ " ++ show n ++ " " ++ show d ++ ")"
where n = numerator r
d = denominator r
-- | Convert a rounding mode to the format SMT-Lib2 understands.
smtRoundingMode :: RoundingMode -> String
smtRoundingMode RoundNearestTiesToEven = "roundNearestTiesToEven"
smtRoundingMode RoundNearestTiesToAway = "roundNearestTiesToAway"
smtRoundingMode RoundTowardPositive = "roundTowardPositive"
smtRoundingMode RoundTowardNegative = "roundTowardNegative"
smtRoundingMode RoundTowardZero = "roundTowardZero"

75
sbv/Data/SBV/BitVectors/STree.hs
View File

@ -1,75 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.BitVectors.STree
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Implementation of full-binary symbolic trees, providing logarithmic
-- time access to elements. Both reads and writes are supported.
-----------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Data.SBV.BitVectors.STree (STree, readSTree, writeSTree, mkSTree) where
import Data.Bits (Bits(..))
import Data.SBV.BitVectors.Data
import Data.SBV.BitVectors.Model
-- | A symbolic tree containing values of type e, indexed by
-- elements of type i. Note that these are full-trees, and their
-- their shapes remain constant. There is no API provided that
-- can change the shape of the tree. These structures are useful
-- when dealing with data-structures that are indexed with symbolic
-- values where access time is important. 'STree' structures provide
-- logarithmic time reads and writes.
type STree i e = STreeInternal (SBV i) (SBV e)
-- Internal representation, not exposed to the user
data STreeInternal i e = SLeaf e -- NB. parameter 'i' is phantom
| SBin (STreeInternal i e) (STreeInternal i e)
deriving Show
instance (SymWord e, Mergeable (SBV e)) => Mergeable (STree i e) where
symbolicMerge f b (SLeaf i) (SLeaf j) = SLeaf (symbolicMerge f b i j)
symbolicMerge f b (SBin l r) (SBin l' r') = SBin (symbolicMerge f b l l') (symbolicMerge f b r r')
symbolicMerge _ _ _ _ = error "SBV.STree.symbolicMerge: Impossible happened while merging states"
-- | Reading a value. We bit-blast the index and descend down the full tree
-- according to bit-values.
readSTree :: (Num i, Bits i, SymWord i, SymWord e) => STree i e -> SBV i -> SBV e
readSTree s i = walk (blastBE i) s
where walk [] (SLeaf v) = v
walk (b:bs) (SBin l r) = ite b (walk bs r) (walk bs l)
walk _ _ = error $ "SBV.STree.readSTree: Impossible happened while reading: " ++ show i
-- | Writing a value, similar to how reads are done. The important thing is that the tree
-- representation keeps updates to a minimum.
writeSTree :: (Mergeable (SBV e), Num i, Bits i, SymWord i, SymWord e) => STree i e -> SBV i -> SBV e -> STree i e
writeSTree s i j = walk (blastBE i) s
where walk [] _ = SLeaf j
walk (b:bs) (SBin l r) = SBin (ite b l (walk bs l)) (ite b (walk bs r) r)
walk _ _ = error $ "SBV.STree.writeSTree: Impossible happened while reading: " ++ show i
-- | Construct the fully balanced initial tree using the given values.
mkSTree :: forall i e. HasKind i => [SBV e] -> STree i e
mkSTree ivals
| isReal (undefined :: i)
= error "SBV.STree.mkSTree: Cannot build a real-valued sized tree"
| not (isBounded (undefined :: i))
= error "SBV.STree.mkSTree: Cannot build an infinitely large tree"
| reqd /= given
= error $ "SBV.STree.mkSTree: Required " ++ show reqd ++ " elements, received: " ++ show given
| True
= go ivals
where reqd = 2 ^ intSizeOf (undefined :: i)
given = length ivals
go [] = error "SBV.STree.mkSTree: Impossible happened, ran out of elements"
go [l] = SLeaf l
go ns = let (l, r) = splitAt (length ns `div` 2) ns in SBin (go l) (go r)

127
sbv/Data/SBV/BitVectors/SignCast.hs
View File

@ -1,127 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.BitVectors.SignCast
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Implementation of casting between signed/unsigned variants of the
-- same type.
-----------------------------------------------------------------------------
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE FlexibleInstances #-}
module Data.SBV.BitVectors.SignCast (SignCast(..)) where
import Data.Word (Word8, Word16, Word32, Word64)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.SBV.BitVectors.Data
import Data.SBV.BitVectors.Model() -- instances only
-- | Sign casting a value into another. This essentially
-- means forgetting the sign bit and reinterpreting the bits
-- accordingly when converting a signed value to an unsigned
-- one. Similarly, when an unsigned quantity is converted to
-- a signed one, the most significant bit is interpreted
-- as the sign. We only define instances when the source
-- and target types are precisely the same size.
-- The idea is that 'signCast' and 'unsignCast' must form
-- an isomorphism pair between the types @a@ and @b@, i.e., we
-- expect the following two properties to hold:
--
-- @
-- signCast . unsignCast = id
-- unsingCast . signCast = id
-- @
--
-- Note that one naive way to implement both these operations
-- is simply to compute @fromBitsLE . blastLE@, i.e., first
-- get all the bits of the word and then reconstruct in the target
-- type. While this is semantically correct, it generates a lot
-- of code (both during proofs via SMT-Lib, and when compiled to C).
-- The goal of this class is to avoid that cost, so these operations
-- can be compiled very efficiently, they will essentially become no-op's.
--
-- Minimal complete definition: All, no defaults.
class SignCast a b | a -> b, b -> a where
-- | Interpret as a signed word
signCast :: a -> b
-- | Interpret as an unsigned word
unsignCast :: b -> a
-- concrete instances
instance SignCast Word64 Int64 where
signCast = fromIntegral
unsignCast = fromIntegral
instance SignCast Word32 Int32 where
signCast = fromIntegral
unsignCast = fromIntegral
instance SignCast Word16 Int16 where
signCast = fromIntegral
unsignCast = fromIntegral
instance SignCast Word8 Int8 where
signCast = fromIntegral
unsignCast = fromIntegral
-- A generic implementation can be along the following lines:
-- fromBitsLE . blastLE
-- However, we prefer this version as the above will generate
-- a ton more code during compilation to SMT-Lib and C
genericSign :: (Integral a, SymWord a, Num b, SymWord b) => SBV a -> SBV b
genericSign x
| Just c <- unliteral x = literal $ fromIntegral c
| True = SBV k (Right (cache y))
where k = case kindOf x of
KBool -> error "Data.SBV.SignCast.genericSign: Called on boolean value"
KBounded False n -> KBounded True n
KBounded True _ -> error "Data.SBV.SignCast.genericSign: Called on signed value"
KUnbounded -> error "Data.SBV.SignCast.genericSign: Called on unbounded value"
KReal -> error "Data.SBV.SignCast.genericSign: Called on real value"
KFloat -> error "Data.SBV.SignCast.genericSign: Called on float value"
KDouble -> error "Data.SBV.SignCast.genericSign: Called on double value"
KUninterpreted s -> error $ "Data.SBV.SignCast.genericSign: Called on unintepreted sort " ++ s
y st = do xsw <- sbvToSW st x
newExpr st k (SBVApp (Extract (intSizeOf x-1) 0) [xsw])
-- Same comments as above, regarding the implementation.
genericUnsign :: (Integral a, SymWord a, Num b, SymWord b) => SBV a -> SBV b
genericUnsign x
| Just c <- unliteral x = literal $ fromIntegral c
| True = SBV k (Right (cache y))
where k = case kindOf x of
KBool -> error "Data.SBV.SignCast.genericUnSign: Called on boolean value"
KBounded True n -> KBounded False n
KBounded False _ -> error "Data.SBV.SignCast.genericUnSign: Called on unsigned value"
KUnbounded -> error "Data.SBV.SignCast.genericUnSign: Called on unbounded value"
KReal -> error "Data.SBV.SignCast.genericUnSign: Called on real value"
KFloat -> error "Data.SBV.SignCast.genericUnSign: Called on float value"
KDouble -> error "Data.SBV.SignCast.genericUnSign: Called on double value"
KUninterpreted s -> error $ "Data.SBV.SignCast.genericUnSign: Called on unintepreted sort " ++ s
y st = do xsw <- sbvToSW st x
newExpr st k (SBVApp (Extract (intSizeOf x-1) 0) [xsw])
-- symbolic instances
instance SignCast SWord8 SInt8 where
signCast = genericSign
unsignCast = genericUnsign
instance SignCast SWord16 SInt16 where
signCast = genericSign
unsignCast = genericUnsign
instance SignCast SWord32 SInt32 where
signCast = genericSign
unsignCast = genericUnsign
instance SignCast SWord64 SInt64 where
signCast = genericSign
unsignCast = genericUnsign

154
sbv/Data/SBV/BitVectors/Splittable.hs
View File

@ -1,154 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.BitVectors.Splittable
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Implementation of bit-vector concatanetation and splits
-----------------------------------------------------------------------------
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE BangPatterns #-}
module Data.SBV.BitVectors.Splittable (Splittable(..), FromBits(..)) where
import Data.Bits (Bits(..))
import Data.Word (Word8, Word16, Word32, Word64)
import Data.SBV.BitVectors.Data
import Data.SBV.BitVectors.Model
infixr 5 #
-- | Splitting an @a@ into two @b@'s and joining back.
-- Intuitively, @a@ is a larger bit-size word than @b@, typically double.
-- The 'extend' operation captures embedding of a @b@ value into an @a@
-- without changing its semantic value.
--
-- Minimal complete definition: All, no defaults.
class Splittable a b | b -> a where
split :: a -> (b, b)
(#) :: b -> b -> a
extend :: b -> a
genSplit :: (Integral a, Num b) => Int -> a -> (b, b)
genSplit ss x = (fromIntegral ((ix `shiftR` ss) .&. mask), fromIntegral (ix .&. mask))
where ix = toInteger x
mask = 2 ^ ss - 1
genJoin :: (Integral b, Num a) => Int -> b -> b -> a
genJoin ss x y = fromIntegral ((ix `shiftL` ss) .|. iy)
where ix = toInteger x
iy = toInteger y
-- concrete instances
instance Splittable Word64 Word32 where
split = genSplit 32
(#) = genJoin 32
extend b = 0 # b
instance Splittable Word32 Word16 where
split = genSplit 16
(#) = genJoin 16
extend b = 0 # b
instance Splittable Word16 Word8 where
split = genSplit 8
(#) = genJoin 8
extend b = 0 # b
cwSplit :: (SymWord a, Num a) => CW -> (SBV a, SBV a)
cwSplit z@(CW _ (CWInteger v)) = (literal x, literal y)
where (x, y) = genSplit (intSizeOf z `div` 2) v
cwSplit z = error $ "SBV.cwSplit: Unsupported CW value: " ++ show z
cwJoin :: (SymWord a, Num a) => CW -> CW -> SBV a
cwJoin x@(CW _ (CWInteger a)) (CW _ (CWInteger b)) = literal (genJoin (intSizeOf x) a b)
cwJoin x y = error $ "SBV.cwJoin: Unsupported arguments: " ++ show (x, y)
-- symbolic instances
instance Splittable SWord64 SWord32 where
split (SBV _ (Left z)) = cwSplit z
split z = (SBV (KBounded False 32) (Right (cache x)), SBV (KBounded False 32) (Right (cache y)))
where x st = do zsw <- sbvToSW st z
newExpr st (KBounded False 32) (SBVApp (Extract 63 32) [zsw])
y st = do zsw <- sbvToSW st z
newExpr st (KBounded False 32) (SBVApp (Extract 31 0) [zsw])
(SBV _ (Left a)) # (SBV _ (Left b)) = cwJoin a b
a # b = SBV (KBounded False 64) (Right (cache c))
where c st = do asw <- sbvToSW st a
bsw <- sbvToSW st b
newExpr st (KBounded False 64) (SBVApp Join [asw, bsw])
extend b = 0 # b
instance Splittable SWord32 SWord16 where
split (SBV _ (Left z)) = cwSplit z
split z = (SBV (KBounded False 16) (Right (cache x)), SBV (KBounded False 16) (Right (cache y)))
where x st = do zsw <- sbvToSW st z
newExpr st (KBounded False 16) (SBVApp (Extract 31 16) [zsw])
y st = do zsw <- sbvToSW st z
newExpr st (KBounded False 16) (SBVApp (Extract 15 0) [zsw])
(SBV _ (Left a)) # (SBV _ (Left b)) = cwJoin a b
a # b = SBV (KBounded False 32) (Right (cache c))
where c st = do asw <- sbvToSW st a
bsw <- sbvToSW st b
newExpr st (KBounded False 32) (SBVApp Join [asw, bsw])
extend b = 0 # b
instance Splittable SWord16 SWord8 where
split (SBV _ (Left z)) = cwSplit z
split z = (SBV (KBounded False 8) (Right (cache x)), SBV (KBounded False 8) (Right (cache y)))
where x st = do zsw <- sbvToSW st z
newExpr st (KBounded False 8) (SBVApp (Extract 15 8) [zsw])
y st = do zsw <- sbvToSW st z
newExpr st (KBounded False 8) (SBVApp (Extract 7 0) [zsw])
(SBV _ (Left a)) # (SBV _ (Left b)) = cwJoin a b
a # b = SBV (KBounded False 16) (Right (cache c))
where c st = do asw <- sbvToSW st a
bsw <- sbvToSW st b
newExpr st (KBounded False 16) (SBVApp Join [asw, bsw])
extend b = 0 # b
-- | Unblasting a value from symbolic-bits. The bits can be given little-endian
-- or big-endian. For a signed number in little-endian, we assume the very last bit
-- is the sign digit. This is a bit awkward, but it is more consistent with the "reverse" view of
-- little-big-endian representations
--
-- Minimal complete definition: 'fromBitsLE'
class FromBits a where
fromBitsLE, fromBitsBE :: [SBool] -> a
fromBitsBE = fromBitsLE . reverse
-- | Construct a symbolic word from its bits given in little-endian
fromBinLE :: (Num a, Bits a, SymWord a) => [SBool] -> SBV a
fromBinLE = go 0 0
where go !acc _ [] = acc
go !acc !i (x:xs) = go (ite x (setBit acc i) acc) (i+1) xs
-- | Perform a sanity check that we should receive precisely the same
-- number of bits as required by the resulting type. The input is little-endian
checkAndConvert :: (Num a, Bits a, SymWord a) => Int -> [SBool] -> SBV a
checkAndConvert sz xs
| sz /= l
= error $ "SBV.fromBits.SWord" ++ ssz ++ ": Expected " ++ ssz ++ " elements, got: " ++ show l
| True
= fromBinLE xs
where l = length xs
ssz = show sz
instance FromBits SBool where
fromBitsLE [x] = x
fromBitsLE xs = error $ "SBV.fromBits.SBool: Expected 1 element, got: " ++ show (length xs)
instance FromBits SWord8 where fromBitsLE = checkAndConvert 8
instance FromBits SInt8 where fromBitsLE = checkAndConvert 8
instance FromBits SWord16 where fromBitsLE = checkAndConvert 16
instance FromBits SInt16 where fromBitsLE = checkAndConvert 16
instance FromBits SWord32 where fromBitsLE = checkAndConvert 32
instance FromBits SInt32 where fromBitsLE = checkAndConvert 32
instance FromBits SWord64 where fromBitsLE = checkAndConvert 64
instance FromBits SInt64 where fromBitsLE = checkAndConvert 64

107
sbv/Data/SBV/Bridge/Boolector.hs
View File

@ -1,107 +0,0 @@
---------------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Bridge.Boolector
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Interface to the Boolector SMT solver. Import this module if you want to use the
-- Boolector SMT prover as your backend solver. Also see:
--
-- - "Data.SBV.Bridge.Yices"
--
-- - "Data.SBV.Bridge.Z3"
--
-- - "Data.SBV.Bridge.CVC4"
--
-- - "Data.SBV.Bridge.MathSAT"
---------------------------------------------------------------------------------
module Data.SBV.Bridge.Boolector (
-- * Boolector specific interface
sbvCurrentSolver
-- ** Proving and checking satisfiability
, prove, sat, allSat, isVacuous, isTheorem, isSatisfiable
-- ** Optimization routines
, optimize, minimize, maximize
-- * Non-Boolector specific SBV interface
-- $moduleExportIntro
, module Data.SBV
) where
import Data.SBV hiding (prove, sat, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver)
-- | Current solver instance, pointing to cvc4.
sbvCurrentSolver :: SMTConfig
sbvCurrentSolver = boolector
-- | Prove theorems, using the CVC4 SMT solver
prove :: Provable a
=> a -- ^ Property to check
-> IO ThmResult -- ^ Response from the SMT solver, containing the counter-example if found
prove = proveWith sbvCurrentSolver
-- | Find satisfying solutions, using the CVC4 SMT solver
sat :: Provable a
=> a -- ^ Property to check
-> IO SatResult -- ^ Response of the SMT Solver, containing the model if found
sat = satWith sbvCurrentSolver
-- | Find all satisfying solutions, using the CVC4 SMT solver
allSat :: Provable a
=> a -- ^ Property to check
-> IO AllSatResult -- ^ List of all satisfying models
allSat = allSatWith sbvCurrentSolver
-- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the CVC4 SMT solver
isVacuous :: Provable a
=> a -- ^ Property to check
-> IO Bool -- ^ True if the constraints are unsatisifiable
isVacuous = isVacuousWith sbvCurrentSolver
-- | Check if the statement is a theorem, with an optional time-out in seconds, using the CVC4 SMT solver
isTheorem :: Provable a
=> Maybe Int -- ^ Optional time-out, specify in seconds
-> a -- ^ Property to check
-> IO (Maybe Bool) -- ^ Returns Nothing if time-out expires
isTheorem = isTheoremWith sbvCurrentSolver
-- | Check if the statement is satisfiable, with an optional time-out in seconds, using the CVC4 SMT solver
isSatisfiable :: Provable a
=> Maybe Int -- ^ Optional time-out, specify in seconds
-> a -- ^ Property to check
-> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers
isSatisfiable = isSatisfiableWith sbvCurrentSolver
-- | Optimize cost functions, using the CVC4 SMT solver
optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> (SBV c -> SBV c -> SBool) -- ^ Betterness check: This is the comparison predicate for optimization
-> ([SBV a] -> SBV c) -- ^ Cost function
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
optimize = optimizeWith sbvCurrentSolver
-- | Minimize cost functions, using the CVC4 SMT solver
minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> ([SBV a] -> SBV c) -- ^ Cost function to minimize
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
minimize = minimizeWith sbvCurrentSolver
-- | Maximize cost functions, using the CVC4 SMT solver
maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> ([SBV a] -> SBV c) -- ^ Cost function to maximize
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
maximize = maximizeWith sbvCurrentSolver
{- $moduleExportIntro
The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module.
-}

107
sbv/Data/SBV/Bridge/CVC4.hs
View File

@ -1,107 +0,0 @@
---------------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Bridge.CVC4
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Interface to the CVC4 SMT solver. Import this module if you want to use the
-- CVC4 SMT prover as your backend solver. Also see:
--
-- - "Data.SBV.Bridge.Yices"
--
-- - "Data.SBV.Bridge.Z3"
--
-- - "Data.SBV.Bridge.Boolector"
--
-- - "Data.SBV.Bridge.MathSAT"
---------------------------------------------------------------------------------
module Data.SBV.Bridge.CVC4 (
-- * CVC4 specific interface
sbvCurrentSolver
-- ** Proving and checking satisfiability
, prove, sat, allSat, isVacuous, isTheorem, isSatisfiable
-- ** Optimization routines
, optimize, minimize, maximize
-- * Non-CVC4 specific SBV interface
-- $moduleExportIntro
, module Data.SBV
) where
import Data.SBV hiding (prove, sat, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver)
-- | Current solver instance, pointing to cvc4.
sbvCurrentSolver :: SMTConfig
sbvCurrentSolver = cvc4
-- | Prove theorems, using the CVC4 SMT solver
prove :: Provable a
=> a -- ^ Property to check
-> IO ThmResult -- ^ Response from the SMT solver, containing the counter-example if found
prove = proveWith sbvCurrentSolver
-- | Find satisfying solutions, using the CVC4 SMT solver
sat :: Provable a
=> a -- ^ Property to check
-> IO SatResult -- ^ Response of the SMT Solver, containing the model if found
sat = satWith sbvCurrentSolver
-- | Find all satisfying solutions, using the CVC4 SMT solver
allSat :: Provable a
=> a -- ^ Property to check
-> IO AllSatResult -- ^ List of all satisfying models
allSat = allSatWith sbvCurrentSolver
-- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the CVC4 SMT solver
isVacuous :: Provable a
=> a -- ^ Property to check
-> IO Bool -- ^ True if the constraints are unsatisifiable
isVacuous = isVacuousWith sbvCurrentSolver
-- | Check if the statement is a theorem, with an optional time-out in seconds, using the CVC4 SMT solver
isTheorem :: Provable a
=> Maybe Int -- ^ Optional time-out, specify in seconds
-> a -- ^ Property to check
-> IO (Maybe Bool) -- ^ Returns Nothing if time-out expires
isTheorem = isTheoremWith sbvCurrentSolver
-- | Check if the statement is satisfiable, with an optional time-out in seconds, using the CVC4 SMT solver
isSatisfiable :: Provable a
=> Maybe Int -- ^ Optional time-out, specify in seconds
-> a -- ^ Property to check
-> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers
isSatisfiable = isSatisfiableWith sbvCurrentSolver
-- | Optimize cost functions, using the CVC4 SMT solver
optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> (SBV c -> SBV c -> SBool) -- ^ Betterness check: This is the comparison predicate for optimization
-> ([SBV a] -> SBV c) -- ^ Cost function
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
optimize = optimizeWith sbvCurrentSolver
-- | Minimize cost functions, using the CVC4 SMT solver
minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> ([SBV a] -> SBV c) -- ^ Cost function to minimize
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
minimize = minimizeWith sbvCurrentSolver
-- | Maximize cost functions, using the CVC4 SMT solver
maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> ([SBV a] -> SBV c) -- ^ Cost function to maximize
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
maximize = maximizeWith sbvCurrentSolver
{- $moduleExportIntro
The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module.
-}

107
sbv/Data/SBV/Bridge/MathSAT.hs
View File

@ -1,107 +0,0 @@
---------------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Bridge.MathSAT
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Interface to the MathSAT SMT solver. Import this module if you want to use the
-- MathSAT SMT prover as your backend solver. Also see:
--
-- - "Data.SBV.Bridge.Yices"
--
-- - "Data.SBV.Bridge.Z3"
--
-- - "Data.SBV.Bridge.CVC4"
--
-- - "Data.SBV.Bridge.Boolector"
---------------------------------------------------------------------------------
module Data.SBV.Bridge.MathSAT (
-- * MathSAT specific interface
sbvCurrentSolver
-- ** Proving and checking satisfiability
, prove, sat, allSat, isVacuous, isTheorem, isSatisfiable
-- ** Optimization routines
, optimize, minimize, maximize
-- * Non-MathSAT specific SBV interface
-- $moduleExportIntro
, module Data.SBV
) where
import Data.SBV hiding (prove, sat, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver)
-- | Current solver instance, pointing to cvc4.
sbvCurrentSolver :: SMTConfig
sbvCurrentSolver = mathSAT
-- | Prove theorems, using the CVC4 SMT solver
prove :: Provable a
=> a -- ^ Property to check
-> IO ThmResult -- ^ Response from the SMT solver, containing the counter-example if found
prove = proveWith sbvCurrentSolver
-- | Find satisfying solutions, using the CVC4 SMT solver
sat :: Provable a
=> a -- ^ Property to check
-> IO SatResult -- ^ Response of the SMT Solver, containing the model if found
sat = satWith sbvCurrentSolver
-- | Find all satisfying solutions, using the CVC4 SMT solver
allSat :: Provable a
=> a -- ^ Property to check
-> IO AllSatResult -- ^ List of all satisfying models
allSat = allSatWith sbvCurrentSolver
-- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the CVC4 SMT solver
isVacuous :: Provable a
=> a -- ^ Property to check
-> IO Bool -- ^ True if the constraints are unsatisifiable
isVacuous = isVacuousWith sbvCurrentSolver
-- | Check if the statement is a theorem, with an optional time-out in seconds, using the CVC4 SMT solver
isTheorem :: Provable a
=> Maybe Int -- ^ Optional time-out, specify in seconds
-> a -- ^ Property to check
-> IO (Maybe Bool) -- ^ Returns Nothing if time-out expires
isTheorem = isTheoremWith sbvCurrentSolver
-- | Check if the statement is satisfiable, with an optional time-out in seconds, using the CVC4 SMT solver
isSatisfiable :: Provable a
=> Maybe Int -- ^ Optional time-out, specify in seconds
-> a -- ^ Property to check
-> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers
isSatisfiable = isSatisfiableWith sbvCurrentSolver
-- | Optimize cost functions, using the CVC4 SMT solver
optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> (SBV c -> SBV c -> SBool) -- ^ Betterness check: This is the comparison predicate for optimization
-> ([SBV a] -> SBV c) -- ^ Cost function
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
optimize = optimizeWith sbvCurrentSolver
-- | Minimize cost functions, using the CVC4 SMT solver
minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> ([SBV a] -> SBV c) -- ^ Cost function to minimize
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
minimize = minimizeWith sbvCurrentSolver
-- | Maximize cost functions, using the CVC4 SMT solver
maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> ([SBV a] -> SBV c) -- ^ Cost function to maximize
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
maximize = maximizeWith sbvCurrentSolver
{- $moduleExportIntro
The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module.
-}

107
sbv/Data/SBV/Bridge/Yices.hs
View File

@ -1,107 +0,0 @@
---------------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Bridge.Yices
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Interface to the Yices SMT solver. Import this module if you want to use the
-- Yices SMT prover as your backend solver. Also see:
--
-- - "Data.SBV.Bridge.Boolector"
--
-- - "Data.SBV.Bridge.CVC4"
--
-- - "Data.SBV.Bridge.Z3"
--
-- - "Data.SBV.Bridge.MathSAT"
---------------------------------------------------------------------------------
module Data.SBV.Bridge.Yices (
-- * Yices specific interface
sbvCurrentSolver
-- ** Proving and checking satisfiability
, prove, sat, allSat, isVacuous, isTheorem, isSatisfiable
-- ** Optimization routines
, optimize, minimize, maximize
-- * Non-Yices specific SBV interface
-- $moduleExportIntro
, module Data.SBV
) where
import Data.SBV hiding (prove, sat, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver)
-- | Current solver instance, pointing to yices.
sbvCurrentSolver :: SMTConfig
sbvCurrentSolver = yices
-- | Prove theorems, using the Yices SMT solver
prove :: Provable a
=> a -- ^ Property to check
-> IO ThmResult -- ^ Response from the SMT solver, containing the counter-example if found
prove = proveWith sbvCurrentSolver
-- | Find satisfying solutions, using the Yices SMT solver
sat :: Provable a
=> a -- ^ Property to check
-> IO SatResult -- ^ Response of the SMT Solver, containing the model if found
sat = satWith sbvCurrentSolver
-- | Find all satisfying solutions, using the Yices SMT solver
allSat :: Provable a
=> a -- ^ Property to check
-> IO AllSatResult -- ^ List of all satisfying models
allSat = allSatWith sbvCurrentSolver
-- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the Yices SMT solver
isVacuous :: Provable a
=> a -- ^ Property to check
-> IO Bool -- ^ True if the constraints are unsatisifiable
isVacuous = isVacuousWith sbvCurrentSolver
-- | Check if the statement is a theorem, with an optional time-out in seconds, using the Yices SMT solver
isTheorem :: Provable a
=> Maybe Int -- ^ Optional time-out, specify in seconds
-> a -- ^ Property to check
-> IO (Maybe Bool) -- ^ Returns Nothing if time-out expires
isTheorem = isTheoremWith sbvCurrentSolver
-- | Check if the statement is satisfiable, with an optional time-out in seconds, using the Yices SMT solver
isSatisfiable :: Provable a
=> Maybe Int -- ^ Optional time-out, specify in seconds
-> a -- ^ Property to check
-> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers
isSatisfiable = isSatisfiableWith sbvCurrentSolver
-- | Optimize cost functions, using the Yices SMT solver
optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> (SBV c -> SBV c -> SBool) -- ^ Betterness check: This is the comparison predicate for optimization
-> ([SBV a] -> SBV c) -- ^ Cost function
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
optimize = optimizeWith sbvCurrentSolver
-- | Minimize cost functions, using the Yices SMT solver
minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> ([SBV a] -> SBV c) -- ^ Cost function to minimize
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
minimize = minimizeWith sbvCurrentSolver
-- | Maximize cost functions, using the Yices SMT solver
maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> ([SBV a] -> SBV c) -- ^ Cost function to maximize
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
maximize = maximizeWith sbvCurrentSolver
{- $moduleExportIntro
The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module.
-}

107
sbv/Data/SBV/Bridge/Z3.hs
View File

@ -1,107 +0,0 @@
---------------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Bridge.Z3
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Interface to the Z3 SMT solver. Import this module if you want to use the
-- Z3 SMT prover as your backend solver. Also see:
--
-- - "Data.SBV.Bridge.Boolector"
--
-- - "Data.SBV.Bridge.CVC4"
--
-- - "Data.SBV.Bridge.Yices"
--
-- - "Data.SBV.Bridge.MathSAT"
---------------------------------------------------------------------------------
module Data.SBV.Bridge.Z3 (
-- * Z3 specific interface
sbvCurrentSolver
-- ** Proving and checking satisfiability
, prove, sat, allSat, isVacuous, isTheorem, isSatisfiable
-- ** Optimization routines
, optimize, minimize, maximize
-- * Non-Z3 specific SBV interface
-- $moduleExportIntro
, module Data.SBV
) where
import Data.SBV hiding (prove, sat, allSat, isVacuous, isTheorem, isSatisfiable, optimize, minimize, maximize, sbvCurrentSolver)
-- | Current solver instance, pointing to z3.
sbvCurrentSolver :: SMTConfig
sbvCurrentSolver = z3
-- | Prove theorems, using the Z3 SMT solver
prove :: Provable a
=> a -- ^ Property to check
-> IO ThmResult -- ^ Response from the SMT solver, containing the counter-example if found
prove = proveWith sbvCurrentSolver
-- | Find satisfying solutions, using the Z3 SMT solver
sat :: Provable a
=> a -- ^ Property to check
-> IO SatResult -- ^ Response of the SMT Solver, containing the model if found
sat = satWith sbvCurrentSolver
-- | Find all satisfying solutions, using the Z3 SMT solver
allSat :: Provable a
=> a -- ^ Property to check
-> IO AllSatResult -- ^ List of all satisfying models
allSat = allSatWith sbvCurrentSolver
-- | Check vacuity of the explicit constraints introduced by calls to the 'constrain' function, using the Z3 SMT solver
isVacuous :: Provable a
=> a -- ^ Property to check
-> IO Bool -- ^ True if the constraints are unsatisifiable
isVacuous = isVacuousWith sbvCurrentSolver
-- | Check if the statement is a theorem, with an optional time-out in seconds, using the Z3 SMT solver
isTheorem :: Provable a
=> Maybe Int -- ^ Optional time-out, specify in seconds
-> a -- ^ Property to check
-> IO (Maybe Bool) -- ^ Returns Nothing if time-out expires
isTheorem = isTheoremWith sbvCurrentSolver
-- | Check if the statement is satisfiable, with an optional time-out in seconds, using the Z3 SMT solver
isSatisfiable :: Provable a
=> Maybe Int -- ^ Optional time-out, specify in seconds
-> a -- ^ Property to check
-> IO (Maybe Bool) -- ^ Returns Nothing if time-out expiers
isSatisfiable = isSatisfiableWith sbvCurrentSolver
-- | Optimize cost functions, using the Z3 SMT solver
optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> (SBV c -> SBV c -> SBool) -- ^ Betterness check: This is the comparison predicate for optimization
-> ([SBV a] -> SBV c) -- ^ Cost function
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
optimize = optimizeWith sbvCurrentSolver
-- | Minimize cost functions, using the Z3 SMT solver
minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> ([SBV a] -> SBV c) -- ^ Cost function to minimize
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
minimize = minimizeWith sbvCurrentSolver
-- | Maximize cost functions, using the Z3 SMT solver
maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> OptimizeOpts -- ^ Parameters to optimization (Iterative, Quantified, etc.)
-> ([SBV a] -> SBV c) -- ^ Cost function to maximize
-> Int -- ^ Number of inputs
-> ([SBV a] -> SBool) -- ^ Validity function
-> IO (Maybe [a]) -- ^ Returns Nothing if there is no valid solution, otherwise an optimal solution
maximize = maximizeWith sbvCurrentSolver
{- $moduleExportIntro
The remainder of the SBV library that is common to all back-end SMT solvers, directly coming from the "Data.SBV" module.
-}

707
sbv/Data/SBV/Compilers/C.hs
View File

@ -1,707 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Compilers.C
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Compilation of symbolic programs to C
-----------------------------------------------------------------------------
{-# LANGUAGE PatternGuards #-}
module Data.SBV.Compilers.C(compileToC, compileToCLib, compileToC', compileToCLib') where
import Control.DeepSeq (rnf)
import Data.Char (isSpace)
import Data.List (nub, intercalate)
import Data.Maybe (isJust, isNothing, fromJust)
import qualified Data.Foldable as F (toList)
import qualified Data.Set as Set (member, toList)
import System.FilePath (takeBaseName, replaceExtension)
import System.Random
import Text.PrettyPrint.HughesPJ
import Data.SBV.BitVectors.Data
import Data.SBV.BitVectors.PrettyNum (shex, showCFloat, showCDouble)
import Data.SBV.Compilers.CodeGen
---------------------------------------------------------------------------
-- * API
---------------------------------------------------------------------------
-- | Given a symbolic computation, render it as an equivalent collection of files
-- that make up a C program:
--
-- * The first argument is the directory name under which the files will be saved. To save
-- files in the current directory pass @'Just' \".\"@. Use 'Nothing' for printing to stdout.
--
-- * The second argument is the name of the C function to generate.
--
-- * The final argument is the function to be compiled.
--
-- Compilation will also generate a @Makefile@, a header file, and a driver (test) program, etc.
compileToC :: Maybe FilePath -> String -> SBVCodeGen () -> IO ()
compileToC mbDirName nm f = compileToC' nm f >>= renderCgPgmBundle mbDirName
-- | Lower level version of 'compileToC', producing a 'CgPgmBundle'
compileToC' :: String -> SBVCodeGen () -> IO CgPgmBundle
compileToC' nm f = do rands <- randoms `fmap` newStdGen
codeGen SBVToC (defaultCgConfig { cgDriverVals = rands }) nm f
-- | Create code to generate a library archive (.a) from given symbolic functions. Useful when generating code
-- from multiple functions that work together as a library.
--
-- * The first argument is the directory name under which the files will be saved. To save
-- files in the current directory pass @'Just' \".\"@. Use 'Nothing' for printing to stdout.
--
-- * The second argument is the name of the archive to generate.
--
-- * The third argument is the list of functions to include, in the form of function-name/code pairs, similar
-- to the second and third arguments of 'compileToC', except in a list.
compileToCLib :: Maybe FilePath -> String -> [(String, SBVCodeGen ())] -> IO ()
compileToCLib mbDirName libName comps = compileToCLib' libName comps >>= renderCgPgmBundle mbDirName
-- | Lower level version of 'compileToCLib', producing a 'CgPgmBundle'
compileToCLib' :: String -> [(String, SBVCodeGen ())] -> IO CgPgmBundle
compileToCLib' libName comps = mergeToLib libName `fmap` mapM (uncurry compileToC') comps
---------------------------------------------------------------------------
-- * Implementation
---------------------------------------------------------------------------
-- token for the target language
data SBVToC = SBVToC
instance CgTarget SBVToC where
targetName _ = "C"
translate _ = cgen
-- Unexpected input, or things we will probably never support
die :: String -> a
die msg = error $ "SBV->C: Unexpected: " ++ msg
-- Unsupported features, or features TBD
tbd :: String -> a
tbd msg = error $ "SBV->C: Not yet supported: " ++ msg
cgen :: CgConfig -> String -> CgState -> Result -> CgPgmBundle
cgen cfg nm st sbvProg
-- we rnf the main pg and the sig to make sure any exceptions in type conversion pop-out early enough
-- this is purely cosmetic, of course..
= rnf (render sig) `seq` rnf (render (vcat body)) `seq` result
where result = CgPgmBundle bundleKind
$ filt [ ("Makefile", (CgMakefile flags, [genMake (cgGenDriver cfg) nm nmd flags]))
, (nm ++ ".h", (CgHeader [sig], [genHeader bundleKind nm [sig] extProtos]))
, (nmd ++ ".c", (CgDriver, genDriver cfg randVals nm ins outs mbRet))
, (nm ++ ".c", (CgSource, body))
]
body = genCProg cfg nm sig sbvProg ins outs mbRet extDecls
bundleKind = (cgInteger cfg, cgReal cfg)
randVals = cgDriverVals cfg
filt xs = [c | c@(_, (k, _)) <- xs, need k]
where need k | isCgDriver k = cgGenDriver cfg
| isCgMakefile k = cgGenMakefile cfg
| True = True
nmd = nm ++ "_driver"
sig = pprCFunHeader nm ins outs mbRet
ins = cgInputs st
outs = cgOutputs st
mbRet = case cgReturns st of
[] -> Nothing
[CgAtomic o] -> Just o
[CgArray _] -> tbd "Non-atomic return values"
_ -> tbd "Multiple return values"
extProtos = case cgPrototypes st of
[] -> empty
xs -> vcat $ text "/* User given prototypes: */" : map text xs
extDecls = case cgDecls st of
[] -> empty
xs -> vcat $ text "/* User given declarations: */" : map text xs ++ [text ""]
flags = cgLDFlags st
-- | Pretty print a functions type. If there is only one output, we compile it
-- as a function that returns that value. Otherwise, we compile it as a void function
-- that takes return values as pointers to be updated.
pprCFunHeader :: String -> [(String, CgVal)] -> [(String, CgVal)] -> Maybe SW -> Doc
pprCFunHeader fn ins outs mbRet = retType <+> text fn <> parens (fsep (punctuate comma (map mkParam ins ++ map mkPParam outs)))
where retType = case mbRet of
Nothing -> text "void"
Just sw -> pprCWord False sw
mkParam, mkPParam :: (String, CgVal) -> Doc
mkParam (n, CgAtomic sw) = pprCWord True sw <+> text n
mkParam (_, CgArray []) = die "mkParam: CgArray with no elements!"
mkParam (n, CgArray (sw:_)) = pprCWord True sw <+> text "*" <> text n
mkPParam (n, CgAtomic sw) = pprCWord False sw <+> text "*" <> text n
mkPParam (_, CgArray []) = die "mPkParam: CgArray with no elements!"
mkPParam (n, CgArray (sw:_)) = pprCWord False sw <+> text "*" <> text n
-- | Renders as "const SWord8 s0", etc. the first parameter is the width of the typefield
declSW :: Int -> SW -> Doc
declSW w sw = text "const" <+> pad (showCType sw) <+> text (show sw)
where pad s = text $ s ++ replicate (w - length s) ' '
-- | Renders as "s0", etc, or the corresponding constant
showSW :: CgConfig -> [(SW, CW)] -> SW -> Doc
showSW cfg consts sw
| sw == falseSW = text "false"
| sw == trueSW = text "true"
| Just cw <- sw `lookup` consts = mkConst cfg cw
| True = text $ show sw
-- | Words as it would map to a C word
pprCWord :: HasKind a => Bool -> a -> Doc
pprCWord cnst v = (if cnst then text "const" else empty) <+> text (showCType v)
showCType :: HasKind a => a -> String
showCType = show . kindOf
-- | The printf specifier for the type
specifier :: CgConfig -> SW -> Doc
specifier cfg sw = case kindOf sw of
KBool -> spec (False, 1)
KBounded b i -> spec (b, i)
KUnbounded -> spec (True, fromJust (cgInteger cfg))
KReal -> specF (fromJust (cgReal cfg))
KFloat -> specF CgFloat
KDouble -> specF CgDouble
KUninterpreted s -> die $ "uninterpreted sort: " ++ s
where spec :: (Bool, Int) -> Doc
spec (False, 1) = text "%d"
spec (False, 8) = text "%\"PRIu8\""
spec (True, 8) = text "%\"PRId8\""
spec (False, 16) = text "0x%04\"PRIx16\"U"
spec (True, 16) = text "%\"PRId16\""
spec (False, 32) = text "0x%08\"PRIx32\"UL"
spec (True, 32) = text "%\"PRId32\"L"
spec (False, 64) = text "0x%016\"PRIx64\"ULL"
spec (True, 64) = text "%\"PRId64\"LL"
spec (s, sz) = die $ "Format specifier at type " ++ (if s then "SInt" else "SWord") ++ show sz
specF :: CgSRealType -> Doc
specF CgFloat = text "%f"
specF CgDouble = text "%f"
specF CgLongDouble = text "%Lf"
-- | Make a constant value of the given type. We don't check for out of bounds here, as it should not be needed.
-- There are many options here, using binary, decimal, etc. We simply
-- 8-bit or less constants using decimal; otherwise we use hex.
-- Note that this automatically takes care of the boolean (1-bit) value problem, since it
-- shows the result as an integer, which is OK as far as C is concerned.
mkConst :: CgConfig -> CW -> Doc
mkConst cfg (CW KReal (CWAlgReal (AlgRational _ r))) = double (fromRational r :: Double) <> sRealSuffix (fromJust (cgReal cfg))
where sRealSuffix CgFloat = text "F"
sRealSuffix CgDouble = empty
sRealSuffix CgLongDouble = text "L"
mkConst cfg (CW KUnbounded (CWInteger i)) = showSizedConst i (True, fromJust (cgInteger cfg))
mkConst _ (CW (KBounded sg sz) (CWInteger i)) = showSizedConst i (sg, sz)
mkConst _ (CW KFloat (CWFloat f)) = text $ showCFloat f
mkConst _ (CW KDouble (CWDouble d)) = text $ showCDouble d
mkConst _ cw = die $ "mkConst: " ++ show cw
showSizedConst :: Integer -> (Bool, Int) -> Doc
showSizedConst i (False, 1) = text (if i == 0 then "false" else "true")
showSizedConst i (False, 8) = integer i
showSizedConst i (True, 8) = integer i
showSizedConst i t@(False, 16) = text (shex False True t i) <> text "U"
showSizedConst i t@(True, 16) = text (shex False True t i)
showSizedConst i t@(False, 32) = text (shex False True t i) <> text "UL"
showSizedConst i t@(True, 32) = text (shex False True t i) <> text "L"
showSizedConst i t@(False, 64) = text (shex False True t i) <> text "ULL"
showSizedConst i t@(True, 64) = text (shex False True t i) <> text "LL"
showSizedConst i (True, 1) = die $ "Signed 1-bit value " ++ show i
showSizedConst i (s, sz) = die $ "Constant " ++ show i ++ " at type " ++ (if s then "SInt" else "SWord") ++ show sz
-- | Generate a makefile. The first argument is True if we have a driver.
genMake :: Bool -> String -> String -> [String] -> Doc
genMake ifdr fn dn ldFlags = foldr1 ($$) [l | (True, l) <- lns]
where ifld = not (null ldFlags)
ld | ifld = text "${LDFLAGS}"
| True = empty
lns = [ (True, text "# Makefile for" <+> nm <> text ". Automatically generated by SBV. Do not edit!")
, (True, text "")
, (True, text "# include any user-defined .mk file in the current directory.")
, (True, text "-include *.mk")
, (True, text "")
, (True, text "CC=gcc")
, (True, text "CCFLAGS?=-Wall -O3 -DNDEBUG -fomit-frame-pointer")
, (ifld, text "LDFLAGS?=" <> text (unwords ldFlags))
, (True, text "")
, (ifdr, text "all:" <+> nmd)
, (ifdr, text "")
, (True, nmo <> text (": " ++ ppSameLine (hsep [nmc, nmh])))
, (True, text "\t${CC} ${CCFLAGS}" <+> text "-c $< -o $@")
, (True, text "")
, (ifdr, nmdo <> text ":" <+> nmdc)
, (ifdr, text "\t${CC} ${CCFLAGS}" <+> text "-c $< -o $@")
, (ifdr, text "")
, (ifdr, nmd <> text (": " ++ ppSameLine (hsep [nmo, nmdo])))
, (ifdr, text "\t${CC} ${CCFLAGS}" <+> text "$^ -o $@" <+> ld)
, (ifdr, text "")
, (True, text "clean:")
, (True, text "\trm -f *.o")
, (True, text "")
, (ifdr, text "veryclean: clean")
, (ifdr, text "\trm -f" <+> nmd)
, (ifdr, text "")
]
nm = text fn
nmd = text dn
nmh = nm <> text ".h"
nmc = nm <> text ".c"
nmo = nm <> text ".o"
nmdc = nmd <> text ".c"
nmdo = nmd <> text ".o"
-- | Generate the header
genHeader :: (Maybe Int, Maybe CgSRealType) -> String -> [Doc] -> Doc -> Doc
genHeader (ik, rk) fn sigs protos =
text "/* Header file for" <+> nm <> text ". Automatically generated by SBV. Do not edit! */"
$$ text ""
$$ text "#ifndef" <+> tag
$$ text "#define" <+> tag
$$ text ""
$$ text "#include <inttypes.h>"
$$ text "#include <stdint.h>"
$$ text "#include <stdbool.h>"
$$ text "#include <math.h>"
$$ text ""
$$ text "/* The boolean type */"
$$ text "typedef bool SBool;"
$$ text ""
$$ text "/* The float type */"
$$ text "typedef float SFloat;"
$$ text ""
$$ text "/* The double type */"
$$ text "typedef double SDouble;"
$$ text ""
$$ text "/* Unsigned bit-vectors */"
$$ text "typedef uint8_t SWord8 ;"
$$ text "typedef uint16_t SWord16;"
$$ text "typedef uint32_t SWord32;"
$$ text "typedef uint64_t SWord64;"
$$ text ""
$$ text "/* Signed bit-vectors */"
$$ text "typedef int8_t SInt8 ;"
$$ text "typedef int16_t SInt16;"
$$ text "typedef int32_t SInt32;"
$$ text "typedef int64_t SInt64;"
$$ text ""
$$ imapping
$$ rmapping
$$ text ("/* Entry point prototype" ++ plu ++ ": */")
$$ vcat (map (<> semi) sigs)
$$ text ""
$$ protos
$$ text "#endif /*" <+> tag <+> text "*/"
$$ text ""
where nm = text fn
tag = text "__" <> nm <> text "__HEADER_INCLUDED__"
plu = if length sigs /= 1 then "s" else ""
imapping = case ik of
Nothing -> empty
Just i -> text "/* User requested mapping for SInteger. */"
$$ text "/* NB. Loss of precision: Target type is subject to modular arithmetic. */"
$$ text ("typedef SInt" ++ show i ++ " SInteger;")
$$ text ""
rmapping = case rk of
Nothing -> empty
Just t -> text "/* User requested mapping for SReal. */"
$$ text "/* NB. Loss of precision: Target type is subject to rounding. */"
$$ text ("typedef " ++ show t ++ " SReal;")
$$ text ""
sepIf :: Bool -> Doc
sepIf b = if b then text "" else empty
-- | Generate an example driver program
genDriver :: CgConfig -> [Integer] -> String -> [(String, CgVal)] -> [(String, CgVal)] -> Maybe SW -> [Doc]
genDriver cfg randVals fn inps outs mbRet = [pre, header, body, post]
where pre = text "/* Example driver program for" <+> nm <> text ". */"
$$ text "/* Automatically generated by SBV. Edit as you see fit! */"
$$ text ""
$$ text "#include <inttypes.h>"
$$ text "#include <stdint.h>"
$$ text "#include <stdbool.h>"
$$ text "#include <math.h>"
$$ text "#include <stdio.h>"
header = text "#include" <+> doubleQuotes (nm <> text ".h")
$$ text ""
$$ text "int main(void)"
$$ text "{"
body = text ""
$$ nest 2 ( vcat (map mkInp pairedInputs)
$$ vcat (map mkOut outs)
$$ sepIf (not (null [() | (_, _, CgArray{}) <- pairedInputs]) || not (null outs))
$$ call
$$ text ""
$$ (case mbRet of
Just sw -> text "printf" <> parens (printQuotes (fcall <+> text "=" <+> specifier cfg sw <> text "\\n")
<> comma <+> resultVar) <> semi
Nothing -> text "printf" <> parens (printQuotes (fcall <+> text "->\\n")) <> semi)
$$ vcat (map display outs)
)
post = text ""
$+$ nest 2 (text "return 0" <> semi)
$$ text "}"
$$ text ""
nm = text fn
pairedInputs = matchRands (map abs randVals) inps
matchRands _ [] = []
matchRands [] _ = die "Run out of driver values!"
matchRands (r:rs) ((n, CgAtomic sw) : cs) = ([mkRVal sw r], n, CgAtomic sw) : matchRands rs cs
matchRands _ ((n, CgArray []) : _ ) = die $ "Unsupported empty array input " ++ show n
matchRands rs ((n, a@(CgArray sws@(sw:_))) : cs)
| length frs /= l = die "Run out of driver values!"
| True = (map (mkRVal sw) frs, n, a) : matchRands srs cs
where l = length sws
(frs, srs) = splitAt l rs
mkRVal sw r = mkConst cfg $ mkConstCW (kindOf sw) r
mkInp (_, _, CgAtomic{}) = empty -- constant, no need to declare
mkInp (_, n, CgArray []) = die $ "Unsupported empty array value for " ++ show n
mkInp (vs, n, CgArray sws@(sw:_)) = pprCWord True sw <+> text n <> brackets (int (length sws)) <+> text "= {"
$$ nest 4 (fsep (punctuate comma (align vs)))
$$ text "};"
$$ text ""
$$ text "printf" <> parens (printQuotes (text "Contents of input array" <+> text n <> text ":\\n")) <> semi
$$ display (n, CgArray sws)
$$ text ""
mkOut (v, CgAtomic sw) = pprCWord False sw <+> text v <> semi
mkOut (v, CgArray []) = die $ "Unsupported empty array value for " ++ show v
mkOut (v, CgArray sws@(sw:_)) = pprCWord False sw <+> text v <> brackets (int (length sws)) <> semi
resultVar = text "__result"
call = case mbRet of
Nothing -> fcall <> semi
Just sw -> pprCWord True sw <+> resultVar <+> text "=" <+> fcall <> semi
fcall = nm <> parens (fsep (punctuate comma (map mkCVal pairedInputs ++ map mkOVal outs)))
mkCVal ([v], _, CgAtomic{}) = v
mkCVal (vs, n, CgAtomic{}) = die $ "Unexpected driver value computed for " ++ show n ++ render (hcat vs)
mkCVal (_, n, CgArray{}) = text n
mkOVal (n, CgAtomic{}) = text "&" <> text n
mkOVal (n, CgArray{}) = text n
display (n, CgAtomic sw) = text "printf" <> parens (printQuotes (text " " <+> text n <+> text "=" <+> specifier cfg sw
<> text "\\n") <> comma <+> text n) <> semi
display (n, CgArray []) = die $ "Unsupported empty array value for " ++ show n
display (n, CgArray sws@(sw:_)) = text "int" <+> nctr <> semi
$$ text "for(" <> nctr <+> text "= 0;" <+> nctr <+> text "<" <+> int (length sws) <+> text "; ++" <> nctr <> text ")"
$$ nest 2 (text "printf" <> parens (printQuotes (text " " <+> entrySpec <+> text "=" <+> spec <> text "\\n")
<> comma <+> nctr <+> comma <> entry) <> semi)
where nctr = text n <> text "_ctr"
entry = text n <> text "[" <> nctr <> text "]"
entrySpec = text n <> text "[%d]"
spec = specifier cfg sw
-- | Generate the C program
genCProg :: CgConfig -> String -> Doc -> Result -> [(String, CgVal)] -> [(String, CgVal)] -> Maybe SW -> Doc -> [Doc]
genCProg cfg fn proto (Result kindInfo _tvals cgs ins preConsts tbls arrs _ _ (SBVPgm asgns) cstrs _) inVars outVars mbRet extDecls
| isNothing (cgInteger cfg) && KUnbounded `Set.member` kindInfo
= error $ "SBV->C: Unbounded integers are not supported by the C compiler."
++ "\nUse 'cgIntegerSize' to specify a fixed size for SInteger representation."
| isNothing (cgReal cfg) && KReal `Set.member` kindInfo
= error $ "SBV->C: SReal values are not supported by the C compiler."
++ "\nUse 'cgSRealType' to specify a custom type for SReal representation."
| not (null usorts)
= error $ "SBV->C: Cannot compile functions with uninterpreted sorts: " ++ intercalate ", " usorts
| not (null cstrs)
= tbd "Explicit constraints"
| not (null arrs)
= tbd "User specified arrays"
| needsExistentials (map fst ins)
= error "SBV->C: Cannot compile functions with existentially quantified variables."
| True
= [pre, header, post]
where usorts = [s | KUninterpreted s <- Set.toList kindInfo]
pre = text "/* File:" <+> doubleQuotes (nm <> text ".c") <> text ". Automatically generated by SBV. Do not edit! */"
$$ text ""
$$ text "#include <inttypes.h>"
$$ text "#include <stdint.h>"
$$ text "#include <stdbool.h>"
$$ text "#include <math.h>"
header = text "#include" <+> doubleQuotes (nm <> text ".h")
post = text ""
$$ vcat (map codeSeg cgs)
$$ extDecls
$$ proto
$$ text "{"
$$ text ""
$$ nest 2 ( vcat (concatMap (genIO True) inVars)
$$ vcat (merge (map genTbl tbls) (map genAsgn assignments))
$$ sepIf (not (null assignments) || not (null tbls))
$$ vcat (concatMap (genIO False) outVars)
$$ maybe empty mkRet mbRet
)
$$ text "}"
$$ text ""
nm = text fn
assignments = F.toList asgns
codeSeg (fnm, ls) = text "/* User specified custom code for" <+> doubleQuotes (text fnm) <+> text "*/"
$$ vcat (map text ls)
$$ text ""
typeWidth = getMax 0 [len (kindOf s) | (s, _) <- assignments]
where len (KReal{}) = 5
len (KFloat{}) = 6 -- SFloat
len (KDouble{}) = 7 -- SDouble
len (KUnbounded{}) = 8
len KBool = 5 -- SBool
len (KBounded False n) = 5 + length (show n) -- SWordN
len (KBounded True n) = 4 + length (show n) -- SIntN
len (KUninterpreted s) = die $ "Uninterpreted sort: " ++ s
getMax 8 _ = 8 -- 8 is the max we can get with SInteger, so don't bother looking any further
getMax m [] = m
getMax m (x:xs) = getMax (m `max` x) xs
consts = (falseSW, falseCW) : (trueSW, trueCW) : preConsts
isConst s = isJust (lookup s consts)
genIO :: Bool -> (String, CgVal) -> [Doc]
genIO True (cNm, CgAtomic sw) = [declSW typeWidth sw <+> text "=" <+> text cNm <> semi]
genIO False (cNm, CgAtomic sw) = [text "*" <> text cNm <+> text "=" <+> showSW cfg consts sw <> semi]
genIO isInp (cNm, CgArray sws) = zipWith genElt sws [(0::Int)..]
where genElt sw i
| isInp = declSW typeWidth sw <+> text "=" <+> text entry <> semi
| True = text entry <+> text "=" <+> showSW cfg consts sw <> semi
where entry = cNm ++ "[" ++ show i ++ "]"
mkRet sw = text "return" <+> showSW cfg consts sw <> semi
genTbl :: ((Int, Kind, Kind), [SW]) -> (Int, Doc)
genTbl ((i, _, k), elts) = (location, static <+> text "const" <+> text (show k) <+> text ("table" ++ show i) <> text "[] = {"
$$ nest 4 (fsep (punctuate comma (align (map (showSW cfg consts) elts))))
$$ text "};")
where static = if location == -1 then text "static" else empty
location = maximum (-1 : map getNodeId elts)
getNodeId s@(SW _ (NodeId n)) | isConst s = -1
| True = n
genAsgn :: (SW, SBVExpr) -> (Int, Doc)
genAsgn (sw, n) = (getNodeId sw, declSW typeWidth sw <+> text "=" <+> ppExpr cfg consts n <> semi)
-- merge tables intermixed with assignments, paying attention to putting tables as
-- early as possible.. Note that the assignment list (second argument) is sorted on its order
merge :: [(Int, Doc)] -> [(Int, Doc)] -> [Doc]
merge [] as = map snd as
merge ts [] = map snd ts
merge ts@((i, t):trest) as@((i', a):arest)
| i < i' = t : merge trest as
| True = a : merge ts arest
ppExpr :: CgConfig -> [(SW, CW)] -> SBVExpr -> Doc
ppExpr cfg consts (SBVApp op opArgs) = p op (map (showSW cfg consts) opArgs)
where rtc = cgRTC cfg
cBinOps = [ (Plus, "+"), (Times, "*"), (Minus, "-")
, (Equal, "=="), (NotEqual, "!="), (LessThan, "<"), (GreaterThan, ">"), (LessEq, "<="), (GreaterEq, ">=")
, (And, "&"), (Or, "|"), (XOr, "^")
]
p (ArrRead _) _ = tbd "User specified arrays (ArrRead)"
p (ArrEq _ _) _ = tbd "User specified arrays (ArrEq)"
p (Uninterpreted s) [] = text "/* Uninterpreted constant */" <+> text s
p (Uninterpreted s) as = text "/* Uninterpreted function */" <+> text s <> parens (fsep (punctuate comma as))
p (Extract i j) [a] = extract i j (head opArgs) a
p Join [a, b] = join (let (s1 : s2 : _) = opArgs in (s1, s2, a, b))
p (Rol i) [a] = rotate True i a (head opArgs)
p (Ror i) [a] = rotate False i a (head opArgs)
p (Shl i) [a] = shift True i a (head opArgs)
p (Shr i) [a] = shift False i a (head opArgs)
p Not [a] = case kindOf (head opArgs) of
-- be careful about booleans, bitwise complement is not correct for them!
KBool -> text "!" <> a
_ -> text "~" <> a
p Ite [a, b, c] = a <+> text "?" <+> b <+> text ":" <+> c
p (LkUp (t, k, _, len) ind def) []
| not rtc = lkUp -- ignore run-time-checks per user request
| needsCheckL && needsCheckR = cndLkUp checkBoth
| needsCheckL = cndLkUp checkLeft
| needsCheckR = cndLkUp checkRight
| True = lkUp
where [index, defVal] = map (showSW cfg consts) [ind, def]
lkUp = text "table" <> int t <> brackets (showSW cfg consts ind)
cndLkUp cnd = cnd <+> text "?" <+> defVal <+> text ":" <+> lkUp
checkLeft = index <+> text "< 0"
checkRight = index <+> text ">=" <+> int len
checkBoth = parens (checkLeft <+> text "||" <+> checkRight)
canOverflow True sz = (2::Integer)^(sz-1)-1 >= fromIntegral len
canOverflow False sz = (2::Integer)^sz -1 >= fromIntegral len
(needsCheckL, needsCheckR) = case k of
KBool -> (False, canOverflow False (1::Int))
KBounded sg sz -> (sg, canOverflow sg sz)
KReal -> die "array index with real value"
KFloat -> die "array index with float value"
KDouble -> die "array index with double value"
KUnbounded -> case cgInteger cfg of
Nothing -> (True, True) -- won't matter, it'll be rejected later
Just i -> (True, canOverflow True i)
KUninterpreted s -> die $ "Uninterpreted sort: " ++ s
-- Div/Rem should be careful on 0, in the SBV world x `div` 0 is 0, x `rem` 0 is x
-- NB: Quot is supposed to truncate toward 0; Not clear to me if C guarantees this behavior.
-- Brief googling suggests C99 does indeed truncate toward 0, but other C compilers might differ.
p Quot [a, b] = parens (b <+> text "== 0") <+> text "?" <+> text "0" <+> text ":" <+> parens (a <+> text "/" <+> b)
p Rem [a, b] = parens (b <+> text "== 0") <+> text "?" <+> a <+> text ":" <+> parens (a <+> text "%" <+> b)
p o [a, b]
| Just co <- lookup o cBinOps
= a <+> text co <+> b
p o args = die $ "Received operator " ++ show o ++ " applied to " ++ show args
shift toLeft i a s
| i < 0 = shift (not toLeft) (-i) a s
| i == 0 = a
| True = case kindOf s of
KBounded _ sz | i >= sz -> mkConst cfg $ mkConstCW (kindOf s) (0::Integer)
KReal -> tbd $ "Shift for real quantity: " ++ show (toLeft, i, s)
_ -> a <+> text cop <+> int i
where cop | toLeft = "<<"
| True = ">>"
rotate toLeft i a s
| i < 0 = rotate (not toLeft) (-i) a s
| i == 0 = a
| True = case kindOf s of
KBounded True _ -> tbd $ "Rotation of signed quantities: " ++ show (toLeft, i, s)
KBounded False sz | i >= sz -> rotate toLeft (i `mod` sz) a s
KBounded False sz -> parens (a <+> text cop <+> int i)
<+> text "|"
<+> parens (a <+> text cop' <+> int (sz - i))
KUnbounded -> shift toLeft i a s -- For SInteger, rotate is the same as shift in Haskell
_ -> tbd $ "Rotation for unbounded quantity: " ++ show (toLeft, i, s)
where (cop, cop') | toLeft = ("<<", ">>")
| True = (">>", "<<")
-- TBD: below we only support the values that SBV actually currently generates.
-- we would need to add new ones if we generate others. (Check instances in Data/SBV/BitVectors/Splittable.hs).
extract hi lo i a = case (hi, lo, kindOf i) of
( 0, 0, KUnbounded) -> text "(SReal)" <+> a -- special SInteger -> SReal conversion
(63, 32, KBounded False 64) -> text "(SWord32)" <+> parens (a <+> text ">> 32")
(31, 0, KBounded False 64) -> text "(SWord32)" <+> a
(31, 16, KBounded False 32) -> text "(SWord16)" <+> parens (a <+> text ">> 16")
(15, 0, KBounded False 32) -> text "(SWord16)" <+> a
(15, 8, KBounded False 16) -> text "(SWord8)" <+> parens (a <+> text ">> 8")
( 7, 0, KBounded False 16) -> text "(SWord8)" <+> a
-- the followings are used by sign-conversions. (Check instances in Data/SBV/BitVectors/SignCast.hs).
(63, 0, KBounded False 64) -> text "(SInt64)" <+> a
(63, 0, KBounded True 64) -> text "(SWord64)" <+> a
(31, 0, KBounded False 32) -> text "(SInt32)" <+> a
(31, 0, KBounded True 32) -> text "(SWord32)" <+> a
(15, 0, KBounded False 16) -> text "(SInt16)" <+> a
(15, 0, KBounded True 16) -> text "(SWord16)" <+> a
( 7, 0, KBounded False 8) -> text "(SInt8)" <+> a
( 7, 0, KBounded True 8) -> text "(SWord8)" <+> a
( _, _, k ) -> tbd $ "extract with " ++ show (hi, lo, k, i)
-- TBD: ditto here for join, just like extract above
join (i, j, a, b) = case (kindOf i, kindOf j) of
(KBounded False 8, KBounded False 8) -> parens (parens (text "(SWord16)" <+> a) <+> text "<< 8") <+> text "|" <+> parens (text "(SWord16)" <+> b)
(KBounded False 16, KBounded False 16) -> parens (parens (text "(SWord32)" <+> a) <+> text "<< 16") <+> text "|" <+> parens (text "(SWord32)" <+> b)
(KBounded False 32, KBounded False 32) -> parens (parens (text "(SWord64)" <+> a) <+> text "<< 32") <+> text "|" <+> parens (text "(SWord64)" <+> b)
(k1, k2) -> tbd $ "join with " ++ show ((k1, i), (k2, j))
-- same as doubleQuotes, except we have to make sure there are no line breaks..
-- Otherwise breaks the generated code.. sigh
printQuotes :: Doc -> Doc
printQuotes d = text $ '"' : ppSameLine d ++ "\""
-- Remove newlines.. Useful when generating Makefile and such
ppSameLine :: Doc -> String
ppSameLine = trim . render
where trim "" = ""
trim ('\n':cs) = ' ' : trim (dropWhile isSpace cs)
trim (c:cs) = c : trim cs
-- Align a bunch of docs to occupy the exact same length by padding in the left by space
-- this is ugly and inefficient, but easy to code..
align :: [Doc] -> [Doc]
align ds = map (text . pad) ss
where ss = map render ds
l = maximum (0 : map length ss)
pad s = replicate (l - length s) ' ' ++ s
-- | Merge a bunch of bundles to generate code for a library
mergeToLib :: String -> [CgPgmBundle] -> CgPgmBundle
mergeToLib libName bundles
| length nubKinds /= 1
= error $ "Cannot merge programs with differing SInteger/SReal mappings. Received the following kinds:\n"
++ unlines (map show nubKinds)
| True
= CgPgmBundle bundleKind $ sources ++ libHeader : [libDriver | anyDriver] ++ [libMake | anyMake]
where kinds = [k | CgPgmBundle k _ <- bundles]
nubKinds = nub kinds
bundleKind = head nubKinds
files = concat [fs | CgPgmBundle _ fs <- bundles]
sigs = concat [ss | (_, (CgHeader ss, _)) <- files]
anyMake = not (null [() | (_, (CgMakefile{}, _)) <- files])
drivers = [ds | (_, (CgDriver, ds)) <- files]
anyDriver = not (null drivers)
mkFlags = nub (concat [xs | (_, (CgMakefile xs, _)) <- files])
sources = [(f, (CgSource, [pre, libHInclude, post])) | (f, (CgSource, [pre, _, post])) <- files]
sourceNms = map fst sources
libHeader = (libName ++ ".h", (CgHeader sigs, [genHeader bundleKind libName sigs empty]))
libHInclude = text "#include" <+> text (show (libName ++ ".h"))
libMake = ("Makefile", (CgMakefile mkFlags, [genLibMake anyDriver libName sourceNms mkFlags]))
libDriver = (libName ++ "_driver.c", (CgDriver, mergeDrivers libName libHInclude (zip (map takeBaseName sourceNms) drivers)))
-- | Create a Makefile for the library
genLibMake :: Bool -> String -> [String] -> [String] -> Doc
genLibMake ifdr libName fs ldFlags = foldr1 ($$) [l | (True, l) <- lns]
where ifld = not (null ldFlags)
ld | ifld = text "${LDFLAGS}"
| True = empty
lns = [ (True, text "# Makefile for" <+> nm <> text ". Automatically generated by SBV. Do not edit!")
, (True, text "")
, (True, text "# include any user-defined .mk file in the current directory.")
, (True, text "-include *.mk")
, (True, text "")
, (True, text "CC=gcc")
, (True, text "CCFLAGS?=-Wall -O3 -DNDEBUG -fomit-frame-pointer")
, (ifld, text "LDFLAGS?=" <> text (unwords ldFlags))
, (True, text "AR=ar")
, (True, text "ARFLAGS=cr")
, (True, text "")
, (not ifdr, text ("all: " ++ liba))
, (ifdr, text ("all: " ++ unwords [liba, libd]))
, (True, text "")
, (True, text liba <> text (": " ++ unwords os))
, (True, text "\t${AR} ${ARFLAGS} $@ $^")
, (True, text "")
, (ifdr, text libd <> text (": " ++ unwords [libd ++ ".c", libh]))
, (ifdr, text ("\t${CC} ${CCFLAGS} $< -o $@ " ++ liba) <+> ld)
, (ifdr, text "")
, (True, vcat (zipWith mkObj os fs))
, (True, text "clean:")
, (True, text "\trm -f *.o")
, (True, text "")
, (True, text "veryclean: clean")
, (not ifdr, text "\trm -f" <+> text liba)
, (ifdr, text "\trm -f" <+> text (unwords [liba, libd]))
, (True, text "")
]
nm = text libName
liba = libName ++ ".a"
libh = libName ++ ".h"
libd = libName ++ "_driver"
os = map (`replaceExtension` ".o") fs
mkObj o f = text o <> text (": " ++ unwords [f, libh])
$$ text "\t${CC} ${CCFLAGS} -c $< -o $@"
$$ text ""
-- | Create a driver for a library
mergeDrivers :: String -> Doc -> [(FilePath, [Doc])] -> [Doc]
mergeDrivers libName inc ds = pre : concatMap mkDFun ds ++ [callDrivers (map fst ds)]
where pre = text "/* Example driver program for" <+> text libName <> text ". */"
$$ text "/* Automatically generated by SBV. Edit as you see fit! */"
$$ text ""
$$ text "#include <inttypes.h>"
$$ text "#include <stdint.h>"
$$ text "#include <stdbool.h>"
$$ text "#include <math.h>"
$$ text "#include <stdio.h>"
$$ inc
mkDFun (f, [_pre, _header, body, _post]) = [header, body, post]
where header = text ""
$$ text ("void " ++ f ++ "_driver(void)")
$$ text "{"
post = text "}"
mkDFun (f, _) = die $ "mergeDrivers: non-conforming driver program for " ++ show f
callDrivers fs = text ""
$$ text "int main(void)"
$$ text "{"
$+$ nest 2 (vcat (map call fs))
$$ nest 2 (text "return 0;")
$$ text "}"
call f = text psep
$$ text ptag
$$ text psep
$$ text (f ++ "_driver();")
$$ text ""
where tag = "** Driver run for " ++ f ++ ":"
ptag = "printf(\"" ++ tag ++ "\\n\");"
lsep = replicate (length tag) '='
psep = "printf(\"" ++ lsep ++ "\\n\");"

270
sbv/Data/SBV/Compilers/CodeGen.hs
View File

@ -1,270 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Compilers.CodeGen
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Code generation utilities
-----------------------------------------------------------------------------
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.SBV.Compilers.CodeGen where
import Control.Monad.Trans
import Control.Monad.State.Lazy
import Control.Applicative (Applicative)
import Data.Char (toLower, isSpace)
import Data.List (nub, isPrefixOf, intercalate, (\\))
import System.Directory (createDirectory, doesDirectoryExist, doesFileExist)
import System.FilePath ((</>))
import Text.PrettyPrint.HughesPJ (Doc, vcat)
import qualified Text.PrettyPrint.HughesPJ as P (render)
import Data.SBV.BitVectors.Data
-- | Abstract over code generation for different languages
class CgTarget a where
targetName :: a -> String
translate :: a -> CgConfig -> String -> CgState -> Result -> CgPgmBundle
-- | Options for code-generation.
data CgConfig = CgConfig {
cgRTC :: Bool -- ^ If 'True', perform run-time-checks for index-out-of-bounds or shifting-by-large values etc.
, cgInteger :: Maybe Int -- ^ Bit-size to use for representing SInteger (if any)
, cgReal :: Maybe CgSRealType -- ^ Type to use for representing SReal (if any)
, cgDriverVals :: [Integer] -- ^ Values to use for the driver program generated, useful for generating non-random drivers.
, cgGenDriver :: Bool -- ^ If 'True', will generate a driver program
, cgGenMakefile :: Bool -- ^ If 'True', will generate a makefile
}
-- | Default options for code generation. The run-time checks are turned-off, and the driver values are completely random.
defaultCgConfig :: CgConfig
defaultCgConfig = CgConfig { cgRTC = False, cgInteger = Nothing, cgReal = Nothing, cgDriverVals = [], cgGenDriver = True, cgGenMakefile = True }
-- | Abstraction of target language values
data CgVal = CgAtomic SW
| CgArray [SW]
-- | Code-generation state
data CgState = CgState {
cgInputs :: [(String, CgVal)]
, cgOutputs :: [(String, CgVal)]
, cgReturns :: [CgVal]
, cgPrototypes :: [String] -- extra stuff that goes into the header
, cgDecls :: [String] -- extra stuff that goes into the top of the file
, cgLDFlags :: [String] -- extra options that go to the linker
, cgFinalConfig :: CgConfig
}
-- | Initial configuration for code-generation
initCgState :: CgState
initCgState = CgState {
cgInputs = []
, cgOutputs = []
, cgReturns = []
, cgPrototypes = []
, cgDecls = []
, cgLDFlags = []
, cgFinalConfig = defaultCgConfig
}
-- | The code-generation monad. Allows for precise layout of input values
-- reference parameters (for returning composite values in languages such as C),
-- and return values.
newtype SBVCodeGen a = SBVCodeGen (StateT CgState Symbolic a)
deriving (Applicative, Functor, Monad, MonadIO, MonadState CgState)
-- | Reach into symbolic monad from code-generation
liftSymbolic :: Symbolic a -> SBVCodeGen a
liftSymbolic = SBVCodeGen . lift
-- | Reach into symbolic monad and output a value. Returns the corresponding SW
cgSBVToSW :: SBV a -> SBVCodeGen SW
cgSBVToSW = liftSymbolic . sbvToSymSW
-- | Sets RTC (run-time-checks) for index-out-of-bounds, shift-with-large value etc. on/off. Default: 'False'.
cgPerformRTCs :: Bool -> SBVCodeGen ()
cgPerformRTCs b = modify (\s -> s { cgFinalConfig = (cgFinalConfig s) { cgRTC = b } })
-- | Sets number of bits to be used for representing the 'SInteger' type in the generated C code.
-- The argument must be one of @8@, @16@, @32@, or @64@. Note that this is essentially unsafe as
-- the semantics of unbounded Haskell integers becomes reduced to the corresponding bit size, as
-- typical in most C implementations.
cgIntegerSize :: Int -> SBVCodeGen ()
cgIntegerSize i
| i `notElem` [8, 16, 32, 64]
= error $ "SBV.cgIntegerSize: Argument must be one of 8, 16, 32, or 64. Received: " ++ show i
| True
= modify (\s -> s { cgFinalConfig = (cgFinalConfig s) { cgInteger = Just i }})
-- | Possible mappings for the 'SReal' type when translated to C. Used in conjunction
-- with the function 'cgSRealType'. Note that the particular characteristics of the
-- mapped types depend on the platform and the compiler used for compiling the generated
-- C program. See <http://en.wikipedia.org/wiki/C_data_types> for details.
data CgSRealType = CgFloat -- ^ @float@
| CgDouble -- ^ @double@
| CgLongDouble -- ^ @long double@
deriving Eq
-- | 'Show' instance for 'cgSRealType' displays values as they would be used in a C program
instance Show CgSRealType where
show CgFloat = "float"
show CgDouble = "double"
show CgLongDouble = "long double"
-- | Sets the C type to be used for representing the 'SReal' type in the generated C code.
-- The setting can be one of C's @"float"@, @"double"@, or @"long double"@, types, depending
-- on the precision needed. Note that this is essentially unsafe as the semantics of
-- infinite precision SReal values becomes reduced to the corresponding floating point type in
-- C, and hence it is subject to rounding errors.
cgSRealType :: CgSRealType -> SBVCodeGen ()
cgSRealType rt = modify (\s -> s {cgFinalConfig = (cgFinalConfig s) { cgReal = Just rt }})
-- | Should we generate a driver program? Default: 'True'. When a library is generated, it will have
-- a driver if any of the contituent functions has a driver. (See 'compileToCLib'.)
cgGenerateDriver :: Bool -> SBVCodeGen ()
cgGenerateDriver b = modify (\s -> s { cgFinalConfig = (cgFinalConfig s) { cgGenDriver = b } })
-- | Should we generate a Makefile? Default: 'True'.
cgGenerateMakefile :: Bool -> SBVCodeGen ()
cgGenerateMakefile b = modify (\s -> s { cgFinalConfig = (cgFinalConfig s) { cgGenMakefile = b } })
-- | Sets driver program run time values, useful for generating programs with fixed drivers for testing. Default: None, i.e., use random values.
cgSetDriverValues :: [Integer] -> SBVCodeGen ()
cgSetDriverValues vs = modify (\s -> s { cgFinalConfig = (cgFinalConfig s) { cgDriverVals = vs } })
-- | Adds the given lines to the header file generated, useful for generating programs with uninterpreted functions.
cgAddPrototype :: [String] -> SBVCodeGen ()
cgAddPrototype ss = modify (\s -> let old = cgPrototypes s
new = if null old then ss else old ++ [""] ++ ss
in s { cgPrototypes = new })
-- | Adds the given lines to the program file generated, useful for generating programs with uninterpreted functions.
cgAddDecl :: [String] -> SBVCodeGen ()
cgAddDecl ss = modify (\s -> let old = cgDecls s
new = if null old then ss else old ++ [""] ++ ss
in s { cgDecls = new })
-- | Adds the given words to the compiler options in the generated Makefile, useful for linking extra stuff in.
cgAddLDFlags :: [String] -> SBVCodeGen ()
cgAddLDFlags ss = modify (\s -> s { cgLDFlags = cgLDFlags s ++ ss })
-- | Creates an atomic input in the generated code.
cgInput :: SymWord a => String -> SBVCodeGen (SBV a)
cgInput nm = do r <- liftSymbolic forall_
sw <- cgSBVToSW r
modify (\s -> s { cgInputs = (nm, CgAtomic sw) : cgInputs s })
return r
-- | Creates an array input in the generated code.
cgInputArr :: SymWord a => Int -> String -> SBVCodeGen [SBV a]
cgInputArr sz nm
| sz < 1 = error $ "SBV.cgInputArr: Array inputs must have at least one element, given " ++ show sz ++ " for " ++ show nm
| True = do rs <- liftSymbolic $ mapM (const forall_) [1..sz]
sws <- mapM cgSBVToSW rs
modify (\s -> s { cgInputs = (nm, CgArray sws) : cgInputs s })
return rs
-- | Creates an atomic output in the generated code.
cgOutput :: SymWord a => String -> SBV a -> SBVCodeGen ()
cgOutput nm v = do _ <- liftSymbolic (output v)
sw <- cgSBVToSW v
modify (\s -> s { cgOutputs = (nm, CgAtomic sw) : cgOutputs s })
-- | Creates an array output in the generated code.
cgOutputArr :: SymWord a => String -> [SBV a] -> SBVCodeGen ()
cgOutputArr nm vs
| sz < 1 = error $ "SBV.cgOutputArr: Array outputs must have at least one element, received " ++ show sz ++ " for " ++ show nm
| True = do _ <- liftSymbolic (mapM output vs)
sws <- mapM cgSBVToSW vs
modify (\s -> s { cgOutputs = (nm, CgArray sws) : cgOutputs s })
where sz = length vs
-- | Creates a returned (unnamed) value in the generated code.
cgReturn :: SymWord a => SBV a -> SBVCodeGen ()
cgReturn v = do _ <- liftSymbolic (output v)
sw <- cgSBVToSW v
modify (\s -> s { cgReturns = CgAtomic sw : cgReturns s })
-- | Creates a returned (unnamed) array value in the generated code.
cgReturnArr :: SymWord a => [SBV a] -> SBVCodeGen ()
cgReturnArr vs
| sz < 1 = error $ "SBV.cgReturnArr: Array returns must have at least one element, received " ++ show sz
| True = do _ <- liftSymbolic (mapM output vs)
sws <- mapM cgSBVToSW vs
modify (\s -> s { cgReturns = CgArray sws : cgReturns s })
where sz = length vs
-- | Representation of a collection of generated programs.
data CgPgmBundle = CgPgmBundle (Maybe Int, Maybe CgSRealType) [(FilePath, (CgPgmKind, [Doc]))]
-- | Different kinds of "files" we can produce. Currently this is quite "C" specific.
data CgPgmKind = CgMakefile [String]
| CgHeader [Doc]
| CgSource
| CgDriver
-- | Is this a driver program?
isCgDriver :: CgPgmKind -> Bool
isCgDriver CgDriver = True
isCgDriver _ = False
-- | Is this a make file?
isCgMakefile :: CgPgmKind -> Bool
isCgMakefile CgMakefile{} = True
isCgMakefile _ = False
-- | A simple way to print bundles, mostly for debugging purposes.
instance Show CgPgmBundle where
show (CgPgmBundle _ fs) = intercalate "\n" $ map showFile fs
where showFile :: (FilePath, (CgPgmKind, [Doc])) -> String
showFile (f, (_, ds)) = "== BEGIN: " ++ show f ++ " ================\n"
++ render' (vcat ds)
++ "== END: " ++ show f ++ " =================="
-- | Generate code for a symbolic program, returning a Code-gen bundle, i.e., collection
-- of makefiles, source code, headers, etc.
codeGen :: CgTarget l => l -> CgConfig -> String -> SBVCodeGen () -> IO CgPgmBundle
codeGen l cgConfig nm (SBVCodeGen comp) = do
(((), st'), res) <- runSymbolic' CodeGen $ runStateT comp initCgState { cgFinalConfig = cgConfig }
let st = st' { cgInputs = reverse (cgInputs st')
, cgOutputs = reverse (cgOutputs st')
}
allNamedVars = map fst (cgInputs st ++ cgOutputs st)
dupNames = allNamedVars \\ nub allNamedVars
unless (null dupNames) $
error $ "SBV.codeGen: " ++ show nm ++ " has following argument names duplicated: " ++ unwords dupNames
return $ translate l (cgFinalConfig st) nm st res
-- | Render a code-gen bundle to a directory or to stdout
renderCgPgmBundle :: Maybe FilePath -> CgPgmBundle -> IO ()
renderCgPgmBundle Nothing bundle = print bundle
renderCgPgmBundle (Just dirName) (CgPgmBundle _ files) = do
b <- doesDirectoryExist dirName
unless b $ do putStrLn $ "Creating directory " ++ show dirName ++ ".."
createDirectory dirName
dups <- filterM (\fn -> doesFileExist (dirName </> fn)) (map fst files)
goOn <- case dups of
[] -> return True
_ -> do putStrLn $ "Code generation would override the following " ++ (if length dups == 1 then "file:" else "files:")
mapM_ (\fn -> putStrLn ('\t' : fn)) dups
putStr "Continue? [yn] "
resp <- getLine
return $ map toLower resp `isPrefixOf` "yes"
if goOn then do mapM_ renderFile files
putStrLn "Done."
else putStrLn "Aborting."
where renderFile (f, (_, ds)) = do let fn = dirName </> f
putStrLn $ "Generating: " ++ show fn ++ ".."
writeFile fn (render' (vcat ds))
-- | An alternative to Pretty's 'render', which might have "leading" white-space in empty lines. This version
-- eliminates such whitespace.
render' :: Doc -> String
render' = unlines . map clean . lines . P.render
where clean x | all isSpace x = ""
| True = x

27
sbv/Data/SBV/Internals.hs
View File

@ -1,27 +0,0 @@
---------------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Internals
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Low level functions to access the SBV infrastructure, for developers who
-- want to build further tools on top of SBV. End-users of the library
-- should not need to use this module.
---------------------------------------------------------------------------------
module Data.SBV.Internals (
-- * Running symbolic programs /manually/
Result, SBVRunMode(..), runSymbolic, runSymbolic'
-- * Other internal structures useful for low-level programming
, SBV(..), slet, CW(..), Kind(..), CWVal(..), AlgReal(..), mkConstCW, genVar, genVar_
, liftQRem, liftDMod
-- * Compilation to C
, mkUninterpreted, compileToC', compileToCLib', CgPgmBundle(..), CgPgmKind(..)
) where
import Data.SBV.BitVectors.Data (Result, SBVRunMode(..), runSymbolic, runSymbolic', SBV(..), CW(..), Kind(..), CWVal(..), AlgReal(..), mkConstCW)
import Data.SBV.BitVectors.Model (genVar, genVar_, slet, liftQRem, liftDMod, mkUninterpreted)
import Data.SBV.Compilers.C (compileToC', compileToCLib')
import Data.SBV.Compilers.CodeGen (CgPgmBundle(..), CgPgmKind(..))

85
sbv/Data/SBV/Provers/Boolector.hs
View File

@ -1,85 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Provers.Boolector
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- The connection to the Boolector SMT solver
-----------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
module Data.SBV.Provers.Boolector(boolector) where
import qualified Control.Exception as C
import Data.Function (on)
import Data.List (sortBy)
import System.Environment (getEnv)
import System.Exit (ExitCode(..))
import Data.SBV.BitVectors.Data
import Data.SBV.SMT.SMT
import Data.SBV.SMT.SMTLib
-- | The description of the Boolector SMT solver
-- The default executable is @\"boolector\"@, which must be in your path. You can use the @SBV_BOOLECTOR@ environment variable to point to the executable on your system.
-- The default options are @\"-m --smt2\"@. You can use the @SBV_BOOLECTOR_OPTIONS@ environment variable to override the options.
boolector :: SMTSolver
boolector = SMTSolver {
name = Boolector
, executable = "boolector"
, options = ["-m", "--smt2"]
, engine = \cfg _isSat qinps modelMap _skolemMap pgm -> do
execName <- getEnv "SBV_BOOLECTOR" `C.catch` (\(_ :: C.SomeException) -> return (executable (solver cfg)))
execOpts <- (words `fmap` getEnv "SBV_BOOLECTOR_OPTIONS") `C.catch` (\(_ :: C.SomeException) -> return (options (solver cfg)))
let cfg' = cfg { solver = (solver cfg) {executable = execName, options = addTimeOut (timeOut cfg) execOpts}
, satCmd = satCmd cfg ++ "\n(exit)" -- boolector requires a final exit line
}
tweaks = case solverTweaks cfg' of
[] -> ""
ts -> unlines $ "; --- user given solver tweaks ---" : ts ++ ["; --- end of user given tweaks ---"]
-- boolector complains if we don't have "exit" at the end
script = SMTScript {scriptBody = tweaks ++ pgm, scriptModel = Nothing}
standardSolver cfg' script id (ProofError cfg') (interpretSolverOutput cfg' (extractMap (map snd qinps) modelMap))
, xformExitCode = boolectorExitCode
, capabilities = SolverCapabilities {
capSolverName = "Boolector"
, mbDefaultLogic = Nothing
, supportsMacros = False
, supportsProduceModels = False
, supportsQuantifiers = False
, supportsUninterpretedSorts = False
, supportsUnboundedInts = False
, supportsReals = False
, supportsFloats = False
, supportsDoubles = False
}
}
where addTimeOut Nothing o = o
addTimeOut (Just i) o
| i < 0 = error $ "Boolector: Timeout value must be non-negative, received: " ++ show i
| True = o ++ ["-t=" ++ show i]
-- | Similar to CVC4, Boolector uses different exit codes to indicate its status.
boolectorExitCode :: ExitCode -> ExitCode
boolectorExitCode (ExitFailure n) | n `elem` [10, 20, 0] = ExitSuccess
boolectorExitCode ec = ec
extractMap :: [NamedSymVar] -> [(String, UnintKind)] -> [String] -> SMTModel
extractMap inps _modelMap solverLines =
SMTModel { modelAssocs = map snd $ sortByNodeId $ concatMap (interpretSolverModelLine inps . cvt) solverLines
, modelUninterps = []
, modelArrays = []
}
where sortByNodeId :: [(Int, a)] -> [(Int, a)]
sortByNodeId = sortBy (compare `on` fst)
-- Boolector outputs in a non-parenthesized way; and also puts x's for don't care bits:
cvt :: String -> String
cvt s = case words s of
[var, val] -> "((" ++ var ++ " #b" ++ map tr val ++ "))"
_ -> s -- good-luck..
where tr 'x' = '0'
tr x = x

102
sbv/Data/SBV/Provers/CVC4.hs
View File

@ -1,102 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Provers.CVC4
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- The connection to the CVC4 SMT solver
-----------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
module Data.SBV.Provers.CVC4(cvc4) where
import qualified Control.Exception as C
import Data.Char (isSpace)
import Data.Function (on)
import Data.List (sortBy, intercalate)
import System.Environment (getEnv)
import System.Exit (ExitCode(..))
import Data.SBV.BitVectors.Data
import Data.SBV.SMT.SMT
import Data.SBV.SMT.SMTLib
-- | The description of the CVC4 SMT solver
-- The default executable is @\"cvc4\"@, which must be in your path. You can use the @SBV_CVC4@ environment variable to point to the executable on your system.
-- The default options are @\"--lang smt\"@. You can use the @SBV_CVC4_OPTIONS@ environment variable to override the options.
cvc4 :: SMTSolver
cvc4 = SMTSolver {
name = CVC4
, executable = "cvc4"
, options = ["--lang", "smt"]
, engine = \cfg isSat qinps modelMap skolemMap pgm -> do
execName <- getEnv "SBV_CVC4" `C.catch` (\(_ :: C.SomeException) -> return (executable (solver cfg)))
execOpts <- (words `fmap` getEnv "SBV_CVC4_OPTIONS") `C.catch` (\(_ :: C.SomeException) -> return (options (solver cfg)))
let cfg' = cfg { solver = (solver cfg) {executable = execName, options = addTimeOut (timeOut cfg) execOpts} }
tweaks = case solverTweaks cfg' of
[] -> ""
ts -> unlines $ "; --- user given solver tweaks ---" : ts ++ ["; --- end of user given tweaks ---"]
script = SMTScript {scriptBody = tweaks ++ pgm, scriptModel = Just (cont skolemMap)}
standardSolver cfg' script id (ProofError cfg') (interpretSolverOutput cfg' (extractMap isSat qinps modelMap))
, xformExitCode = cvc4ExitCode
, capabilities = SolverCapabilities {
capSolverName = "CVC4"
, mbDefaultLogic = Just "ALL_SUPPORTED" -- CVC4 is not happy if we don't set the logic, so fall-back to this if necessary
, supportsMacros = True
, supportsProduceModels = True
, supportsQuantifiers = True
, supportsUninterpretedSorts = True
, supportsUnboundedInts = True
, supportsReals = True -- Not quite the same capability as Z3; but works more or less..
, supportsFloats = False
, supportsDoubles = False
}
}
where zero :: Kind -> String
zero KBool = "false"
zero (KBounded _ sz) = "#x" ++ replicate (sz `div` 4) '0'
zero KUnbounded = "0"
zero KReal = "0.0"
zero KFloat = error "SBV.CVC4.zero: Unexpected float value"
zero KDouble = error "SBV.CVC4.zero: Unexpected double value"
zero (KUninterpreted s) = error $ "SBV.CVC4.zero: Unexpected uninterpreted sort: " ++ s
cont skolemMap = intercalate "\n" $ map extract skolemMap
where extract (Left s) = "(echo \"((" ++ show s ++ " " ++ zero (kindOf s) ++ "))\")"
extract (Right (s, [])) = "(get-value (" ++ show s ++ "))"
extract (Right (s, ss)) = "(get-value (" ++ show s ++ concat [' ' : zero (kindOf a) | a <- ss] ++ "))"
addTimeOut Nothing o = o
addTimeOut (Just i) o
| i < 0 = error $ "CVC4: Timeout value must be non-negative, received: " ++ show i
| True = o ++ ["--tlimit=" ++ show i ++ "000"] -- SBV takes seconds, CVC4 wants milli-seconds
-- | CVC4 uses different exit codes to indicate its status, rather than the
-- standard 0 being success and non-0 being failure. Make it palatable to SBV.
-- See <http://cvc4.cs.nyu.edu/wiki/User_Manual#Exit_status> for details.
cvc4ExitCode :: ExitCode -> ExitCode
cvc4ExitCode (ExitFailure n) | n `elem` [10, 20, 0] = ExitSuccess
cvc4ExitCode ec = ec
extractMap :: Bool -> [(Quantifier, NamedSymVar)] -> [(String, UnintKind)] -> [String] -> SMTModel
extractMap isSat qinps _modelMap solverLines =
SMTModel { modelAssocs = map snd $ sortByNodeId $ concatMap (interpretSolverModelLine inps . unstring) solverLines
, modelUninterps = []
, modelArrays = []
}
where sortByNodeId :: [(Int, a)] -> [(Int, a)]
sortByNodeId = sortBy (compare `on` fst)
inps -- for "sat", display the prefix existentials. For completeness, we will drop
-- only the trailing foralls. Exception: Don't drop anything if it's all a sequence of foralls
| isSat = map snd $ if all (== ALL) (map fst qinps)
then qinps
else reverse $ dropWhile ((== ALL) . fst) $ reverse qinps
-- for "proof", just display the prefix universals
| True = map snd $ takeWhile ((== ALL) . fst) qinps
-- CVC4 puts quotes around echo's, go figure. strip them here
unstring s' = case (s, head s, last s) of
(_:tl@(_:_), '"', '"') -> init tl
_ -> s'
where s = reverse . dropWhile isSpace . reverse . dropWhile isSpace $ s'

92
sbv/Data/SBV/Provers/MathSAT.hs
View File

@ -1,92 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Provers.MathSAT
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- The connection to the MathSAT SMT solver
-----------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
module Data.SBV.Provers.MathSAT(mathSAT) where
import qualified Control.Exception as C
import Data.Function (on)
import Data.List (sortBy, intercalate)
import System.Environment (getEnv)
import Data.SBV.BitVectors.Data
import Data.SBV.SMT.SMT
import Data.SBV.SMT.SMTLib
-- | The description of the MathSAT SMT solver
-- The default executable is @\"mathsat\"@, which must be in your path. You can use the @SBV_MATHSAT@ environment variable to point to the executable on your system.
-- The default options are @\"-input=smt2\"@. You can use the @SBV_MATHSAT_OPTIONS@ environment variable to override the options.
mathSAT :: SMTSolver
mathSAT = SMTSolver {
name = MathSAT
, executable = "mathsat"
, options = ["-input=smt2"]
, engine = \cfg _isSat qinps modelMap skolemMap pgm -> do
execName <- getEnv "SBV_MATHSAT" `C.catch` (\(_ :: C.SomeException) -> return (executable (solver cfg)))
execOpts <- (words `fmap` getEnv "SBV_MATHSAT_OPTIONS") `C.catch` (\(_ :: C.SomeException) -> return (options (solver cfg)))
let cfg' = cfg { solver = (solver cfg) {executable = execName, options = addTimeOut (timeOut cfg) execOpts}
}
tweaks = case solverTweaks cfg' of
[] -> ""
ts -> unlines $ "; --- user given solver tweaks ---" : ts ++ ["; --- end of user given tweaks ---"]
script = SMTScript {scriptBody = tweaks ++ pgm, scriptModel = Just (cont skolemMap)}
standardSolver cfg' script id (ProofError cfg') (interpretSolverOutput cfg' (extractMap (map snd qinps) modelMap))
, xformExitCode = id
, capabilities = SolverCapabilities {
capSolverName = "MathSAT"
, mbDefaultLogic = Nothing
, supportsMacros = False
, supportsProduceModels = True
, supportsQuantifiers = True
, supportsUninterpretedSorts = True
, supportsUnboundedInts = True
, supportsReals = True
, supportsFloats = False
, supportsDoubles = False
}
}
where zero :: Kind -> String
zero KBool = "false"
zero (KBounded _ sz) = "#x" ++ replicate (sz `div` 4) '0'
zero KUnbounded = "0"
zero KReal = "0.0"
zero KFloat = error "SBV.MathSAT.zero: Unexpected sort SFloat"
zero KDouble = error "SBV.MathSAT.zero: Unexpected sort SDouble"
zero (KUninterpreted s) = error $ "SBV.MathSAT.zero: Unexpected uninterpreted sort: " ++ s
cont skolemMap = intercalate "\n" $ concatMap extract skolemMap
where -- In the skolemMap:
-- * Left's are universals: i.e., the model should be true for
-- any of these. So, we simply "echo 0" for these values.
-- * Right's are existentials. If there are no dependencies (empty list), then we can
-- simply use get-value to extract it's value. Otherwise, we have to apply it to
-- an appropriate number of 0's to get the final value.
extract (Left s) = ["(echo \"((" ++ show s ++ " " ++ zero (kindOf s) ++ "))\")"]
extract (Right (s, [])) = ["(get-value (" ++ show s ++ "))"]
extract (Right (s, ss)) = let g = "(get-value ((" ++ show s ++ concat [' ' : zero (kindOf a) | a <- ss] ++ ")))" in [g]
addTimeOut Nothing o = o
addTimeOut (Just _) _ = error "MathSAT: Timeout values are not supported by MathSat"
extractMap :: [NamedSymVar] -> [(String, UnintKind)] -> [String] -> SMTModel
extractMap inps _modelMap solverLines =
SMTModel { modelAssocs = map snd $ sortByNodeId $ concatMap (interpretSolverModelLine inps . cvt) solverLines
, modelUninterps = []
, modelArrays = []
}
where sortByNodeId :: [(Int, a)] -> [(Int, a)]
sortByNodeId = sortBy (compare `on` fst)
cvt :: String -> String
cvt s = case words s of
[var, val] -> "((" ++ var ++ " #b" ++ map tr val ++ "))"
_ -> s -- good-luck..
where tr 'x' = '0'
tr x = x

459
sbv/Data/SBV/Provers/Prover.hs
View File

@ -1,459 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Provers.Prover
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Provable abstraction and the connection to SMT solvers
-----------------------------------------------------------------------------
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE BangPatterns #-}
module Data.SBV.Provers.Prover (
SMTSolver(..), SMTConfig(..), Predicate, Provable(..)
, ThmResult(..), SatResult(..), AllSatResult(..), SMTResult(..)
, isSatisfiable, isSatisfiableWith, isTheorem, isTheoremWith
, prove, proveWith
, sat, satWith
, allSat, allSatWith
, isVacuous, isVacuousWith
, SatModel(..), Modelable(..), displayModels, extractModels
, getModelDictionaries, getModelValues, getModelUninterpretedValues
, boolector, cvc4, yices, z3, mathSAT, defaultSMTCfg
, compileToSMTLib, generateSMTBenchmarks
, isSBranchFeasibleInState
) where
import Control.Monad (when, unless)
import Control.Monad.Trans (liftIO)
import Data.List (intercalate)
import Data.Maybe (mapMaybe, fromMaybe)
import System.FilePath (addExtension, splitExtension)
import System.Time (getClockTime)
import System.IO.Unsafe (unsafeInterleaveIO)
import qualified Data.Set as Set (Set, toList)
import Data.SBV.BitVectors.Data
import Data.SBV.SMT.SMT
import Data.SBV.SMT.SMTLib
import qualified Data.SBV.Provers.Boolector as Boolector
import qualified Data.SBV.Provers.CVC4 as CVC4
import qualified Data.SBV.Provers.Yices as Yices
import qualified Data.SBV.Provers.Z3 as Z3
import qualified Data.SBV.Provers.MathSAT as MathSAT
import Data.SBV.Utils.TDiff
mkConfig :: SMTSolver -> Bool -> [String] -> SMTConfig
mkConfig s isSMTLib2 tweaks = SMTConfig { verbose = False
, timing = False
, sBranchTimeOut = Nothing
, timeOut = Nothing
, printBase = 10
, printRealPrec = 16
, smtFile = Nothing
, solver = s
, solverTweaks = tweaks
, useSMTLib2 = isSMTLib2
, satCmd = "(check-sat)"
, roundingMode = RoundNearestTiesToEven
, useLogic = Nothing
}
-- | Default configuration for the Boolector SMT solver
boolector :: SMTConfig
boolector = mkConfig Boolector.boolector True []
-- | Default configuration for the CVC4 SMT Solver.
cvc4 :: SMTConfig
cvc4 = mkConfig CVC4.cvc4 True []
-- | Default configuration for the Yices SMT Solver.
yices :: SMTConfig
yices = mkConfig Yices.yices False []
-- | Default configuration for the Z3 SMT solver
z3 :: SMTConfig
z3 = mkConfig Z3.z3 True ["(set-option :smt.mbqi true) ; use model based quantifier instantiation"]
-- | Default configuration for the MathSAT SMT solver
mathSAT :: SMTConfig
mathSAT = mkConfig MathSAT.mathSAT True []
-- | The default solver used by SBV. This is currently set to z3.
defaultSMTCfg :: SMTConfig
defaultSMTCfg = z3
-- | A predicate is a symbolic program that returns a (symbolic) boolean value. For all intents and
-- purposes, it can be treated as an n-ary function from symbolic-values to a boolean. The 'Symbolic'
-- monad captures the underlying representation, and can/should be ignored by the users of the library,
-- unless you are building further utilities on top of SBV itself. Instead, simply use the 'Predicate'
-- type when necessary.
type Predicate = Symbolic SBool
-- | A type @a@ is provable if we can turn it into a predicate.
-- Note that a predicate can be made from a curried function of arbitrary arity, where
-- each element is either a symbolic type or up-to a 7-tuple of symbolic-types. So
-- predicates can be constructed from almost arbitrary Haskell functions that have arbitrary
-- shapes. (See the instance declarations below.)
class Provable a where
-- | Turns a value into a universally quantified predicate, internally naming the inputs.
-- In this case the sbv library will use names of the form @s1, s2@, etc. to name these variables
-- Example:
--
-- > forAll_ $ \(x::SWord8) y -> x `shiftL` 2 .== y
--
-- is a predicate with two arguments, captured using an ordinary Haskell function. Internally,
-- @x@ will be named @s0@ and @y@ will be named @s1@.
forAll_ :: a -> Predicate
-- | Turns a value into a predicate, allowing users to provide names for the inputs.
-- If the user does not provide enough number of names for the variables, the remaining ones
-- will be internally generated. Note that the names are only used for printing models and has no
-- other significance; in particular, we do not check that they are unique. Example:
--
-- > forAll ["x", "y"] $ \(x::SWord8) y -> x `shiftL` 2 .== y
--
-- This is the same as above, except the variables will be named @x@ and @y@ respectively,
-- simplifying the counter-examples when they are printed.
forAll :: [String] -> a -> Predicate
-- | Turns a value into an existentially quantified predicate. (Indeed, 'exists' would have been
-- a better choice here for the name, but alas it's already taken.)
forSome_ :: a -> Predicate
-- | Version of 'forSome' that allows user defined names
forSome :: [String] -> a -> Predicate
instance Provable Predicate where
forAll_ = id
forAll [] = id
forAll xs = error $ "SBV.forAll: Extra unmapped name(s) in predicate construction: " ++ intercalate ", " xs
forSome_ = id
forSome [] = id
forSome xs = error $ "SBV.forSome: Extra unmapped name(s) in predicate construction: " ++ intercalate ", " xs
instance Provable SBool where
forAll_ = return
forAll _ = return
forSome_ = return
forSome _ = return
{-
-- The following works, but it lets us write properties that
-- are not useful.. Such as: prove $ \x y -> (x::SInt8) == y
-- Running that will throw an exception since Haskell's equality
-- is not be supported by symbolic things. (Needs .==).
instance Provable Bool where
forAll_ x = forAll_ (if x then true else false :: SBool)
forAll s x = forAll s (if x then true else false :: SBool)
forSome_ x = forSome_ (if x then true else false :: SBool)
forSome s x = forSome s (if x then true else false :: SBool)
-}
-- Functions
instance (SymWord a, Provable p) => Provable (SBV a -> p) where
forAll_ k = forall_ >>= \a -> forAll_ $ k a
forAll (s:ss) k = forall s >>= \a -> forAll ss $ k a
forAll [] k = forAll_ k
forSome_ k = exists_ >>= \a -> forSome_ $ k a
forSome (s:ss) k = exists s >>= \a -> forSome ss $ k a
forSome [] k = forSome_ k
-- Arrays (memory), only supported universally for the time being
instance (HasKind a, HasKind b, SymArray array, Provable p) => Provable (array a b -> p) where
forAll_ k = newArray_ Nothing >>= \a -> forAll_ $ k a
forAll (s:ss) k = newArray s Nothing >>= \a -> forAll ss $ k a
forAll [] k = forAll_ k
forSome_ _ = error "SBV.forSome: Existential arrays are not currently supported."
forSome _ _ = error "SBV.forSome: Existential arrays are not currently supported."
-- 2 Tuple
instance (SymWord a, SymWord b, Provable p) => Provable ((SBV a, SBV b) -> p) where
forAll_ k = forall_ >>= \a -> forAll_ $ \b -> k (a, b)
forAll (s:ss) k = forall s >>= \a -> forAll ss $ \b -> k (a, b)
forAll [] k = forAll_ k
forSome_ k = exists_ >>= \a -> forSome_ $ \b -> k (a, b)
forSome (s:ss) k = exists s >>= \a -> forSome ss $ \b -> k (a, b)
forSome [] k = forSome_ k
-- 3 Tuple
instance (SymWord a, SymWord b, SymWord c, Provable p) => Provable ((SBV a, SBV b, SBV c) -> p) where
forAll_ k = forall_ >>= \a -> forAll_ $ \b c -> k (a, b, c)
forAll (s:ss) k = forall s >>= \a -> forAll ss $ \b c -> k (a, b, c)
forAll [] k = forAll_ k
forSome_ k = exists_ >>= \a -> forSome_ $ \b c -> k (a, b, c)
forSome (s:ss) k = exists s >>= \a -> forSome ss $ \b c -> k (a, b, c)
forSome [] k = forSome_ k
-- 4 Tuple
instance (SymWord a, SymWord b, SymWord c, SymWord d, Provable p) => Provable ((SBV a, SBV b, SBV c, SBV d) -> p) where
forAll_ k = forall_ >>= \a -> forAll_ $ \b c d -> k (a, b, c, d)
forAll (s:ss) k = forall s >>= \a -> forAll ss $ \b c d -> k (a, b, c, d)
forAll [] k = forAll_ k
forSome_ k = exists_ >>= \a -> forSome_ $ \b c d -> k (a, b, c, d)
forSome (s:ss) k = exists s >>= \a -> forSome ss $ \b c d -> k (a, b, c, d)
forSome [] k = forSome_ k
-- 5 Tuple
instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, Provable p) => Provable ((SBV a, SBV b, SBV c, SBV d, SBV e) -> p) where
forAll_ k = forall_ >>= \a -> forAll_ $ \b c d e -> k (a, b, c, d, e)
forAll (s:ss) k = forall s >>= \a -> forAll ss $ \b c d e -> k (a, b, c, d, e)
forAll [] k = forAll_ k
forSome_ k = exists_ >>= \a -> forSome_ $ \b c d e -> k (a, b, c, d, e)
forSome (s:ss) k = exists s >>= \a -> forSome ss $ \b c d e -> k (a, b, c, d, e)
forSome [] k = forSome_ k
-- 6 Tuple
instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, Provable p) => Provable ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f) -> p) where
forAll_ k = forall_ >>= \a -> forAll_ $ \b c d e f -> k (a, b, c, d, e, f)
forAll (s:ss) k = forall s >>= \a -> forAll ss $ \b c d e f -> k (a, b, c, d, e, f)
forAll [] k = forAll_ k
forSome_ k = exists_ >>= \a -> forSome_ $ \b c d e f -> k (a, b, c, d, e, f)
forSome (s:ss) k = exists s >>= \a -> forSome ss $ \b c d e f -> k (a, b, c, d, e, f)
forSome [] k = forSome_ k
-- 7 Tuple
instance (SymWord a, SymWord b, SymWord c, SymWord d, SymWord e, SymWord f, SymWord g, Provable p) => Provable ((SBV a, SBV b, SBV c, SBV d, SBV e, SBV f, SBV g) -> p) where
forAll_ k = forall_ >>= \a -> forAll_ $ \b c d e f g -> k (a, b, c, d, e, f, g)
forAll (s:ss) k = forall s >>= \a -> forAll ss $ \b c d e f g -> k (a, b, c, d, e, f, g)
forAll [] k = forAll_ k
forSome_ k = exists_ >>= \a -> forSome_ $ \b c d e f g -> k (a, b, c, d, e, f, g)
forSome (s:ss) k = exists s >>= \a -> forSome ss $ \b c d e f g -> k (a, b, c, d, e, f, g)
forSome [] k = forSome_ k
-- | Prove a predicate, equivalent to @'proveWith' 'defaultSMTCfg'@
prove :: Provable a => a -> IO ThmResult
prove = proveWith defaultSMTCfg
-- | Find a satisfying assignment for a predicate, equivalent to @'satWith' 'defaultSMTCfg'@
sat :: Provable a => a -> IO SatResult
sat = satWith defaultSMTCfg
-- | Return all satisfying assignments for a predicate, equivalent to @'allSatWith' 'defaultSMTCfg'@.
-- Satisfying assignments are constructed lazily, so they will be available as returned by the solver
-- and on demand.
--
-- NB. Uninterpreted constant/function values and counter-examples for array values are ignored for
-- the purposes of @'allSat'@. That is, only the satisfying assignments modulo uninterpreted functions and
-- array inputs will be returned. This is due to the limitation of not having a robust means of getting a
-- function counter-example back from the SMT solver.
allSat :: Provable a => a -> IO AllSatResult
allSat = allSatWith defaultSMTCfg
-- | Check if the given constraints are satisfiable, equivalent to @'isVacuousWith' 'defaultSMTCfg'@.
-- See the function 'constrain' for an example use of 'isVacuous'.
isVacuous :: Provable a => a -> IO Bool
isVacuous = isVacuousWith defaultSMTCfg
-- Decision procedures (with optional timeout)
-- | Check whether a given property is a theorem, with an optional time out and the given solver.
-- Returns @Nothing@ if times out, or the result wrapped in a @Just@ otherwise.
isTheoremWith :: Provable a => SMTConfig -> Maybe Int -> a -> IO (Maybe Bool)
isTheoremWith cfg mbTo p = do r <- proveWith cfg{timeOut = mbTo} p
case r of
ThmResult (Unsatisfiable _) -> return $ Just True
ThmResult (Satisfiable _ _) -> return $ Just False
ThmResult (TimeOut _) -> return Nothing
_ -> error $ "SBV.isTheorem: Received:\n" ++ show r
-- | Check whether a given property is satisfiable, with an optional time out and the given solver.
-- Returns @Nothing@ if times out, or the result wrapped in a @Just@ otherwise.
isSatisfiableWith :: Provable a => SMTConfig -> Maybe Int -> a -> IO (Maybe Bool)
isSatisfiableWith cfg mbTo p = do r <- satWith cfg{timeOut = mbTo} p
case r of
SatResult (Satisfiable _ _) -> return $ Just True
SatResult (Unsatisfiable _) -> return $ Just False
SatResult (TimeOut _) -> return Nothing
_ -> error $ "SBV.isSatisfiable: Received: " ++ show r
-- | Checks theoremhood within the given optional time limit of @i@ seconds.
-- Returns @Nothing@ if times out, or the result wrapped in a @Just@ otherwise.
isTheorem :: Provable a => Maybe Int -> a -> IO (Maybe Bool)
isTheorem = isTheoremWith defaultSMTCfg
-- | Checks satisfiability within the given optional time limit of @i@ seconds.
-- Returns @Nothing@ if times out, or the result wrapped in a @Just@ otherwise.
isSatisfiable :: Provable a => Maybe Int -> a -> IO (Maybe Bool)
isSatisfiable = isSatisfiableWith defaultSMTCfg
-- | Compiles to SMT-Lib and returns the resulting program as a string. Useful for saving
-- the result to a file for off-line analysis, for instance if you have an SMT solver that's not natively
-- supported out-of-the box by the SBV library. It takes two booleans:
--
-- * smtLib2: If 'True', will generate SMT-Lib2 output, otherwise SMT-Lib1 output
--
-- * isSat : If 'True', will translate it as a SAT query, i.e., in the positive. If 'False', will
-- translate as a PROVE query, i.e., it will negate the result. (In this case, the check-sat
-- call to the SMT solver will produce UNSAT if the input is a theorem, as usual.)
compileToSMTLib :: Provable a => Bool -- ^ If True, output SMT-Lib2, otherwise SMT-Lib1
-> Bool -- ^ If True, translate directly, otherwise negate the goal. (Use True for SAT queries, False for PROVE queries.)
-> a
-> IO String
compileToSMTLib smtLib2 isSat a = do
t <- getClockTime
let comments = ["Created on " ++ show t]
cvt = if smtLib2 then toSMTLib2 else toSMTLib1
(_, _, _, _, smtLibPgm) <- simulate cvt defaultSMTCfg isSat comments a
let out = show smtLibPgm
return $ out ++ if smtLib2 -- append check-sat in case of smtLib2
then "\n(check-sat)\n"
else "\n"
-- | Create both SMT-Lib1 and SMT-Lib2 benchmarks. The first argument is the basename of the file,
-- SMT-Lib1 version will be written with suffix ".smt1" and SMT-Lib2 version will be written with
-- suffix ".smt2". The 'Bool' argument controls whether this is a SAT instance, i.e., translate the query
-- directly, or a PROVE instance, i.e., translate the negated query. (See the second boolean argument to
-- 'compileToSMTLib' for details.)
generateSMTBenchmarks :: Provable a => Bool -> FilePath -> a -> IO ()
generateSMTBenchmarks isSat f a = gen False smt1 >> gen True smt2
where smt1 = addExtension f "smt1"
smt2 = addExtension f "smt2"
gen b fn = do s <- compileToSMTLib b isSat a
writeFile fn s
putStrLn $ "Generated SMT benchmark " ++ show fn ++ "."
-- | Proves the predicate using the given SMT-solver
proveWith :: Provable a => SMTConfig -> a -> IO ThmResult
proveWith config a = simulate cvt config False [] a >>= callSolver False "Checking Theoremhood.." ThmResult config
where cvt = if useSMTLib2 config then toSMTLib2 else toSMTLib1
-- | Find a satisfying assignment using the given SMT-solver
satWith :: Provable a => SMTConfig -> a -> IO SatResult
satWith config a = simulate cvt config True [] a >>= callSolver True "Checking Satisfiability.." SatResult config
where cvt = if useSMTLib2 config then toSMTLib2 else toSMTLib1
-- | Determine if the constraints are vacuous using the given SMT-solver
isVacuousWith :: Provable a => SMTConfig -> a -> IO Bool
isVacuousWith config a = do
Result ki tr uic is cs ts as uis ax asgn cstr _ <- runSymbolic (True, Just config) $ forAll_ a >>= output
case cstr of
[] -> return False -- no constraints, no need to check
_ -> do let is' = [(EX, i) | (_, i) <- is] -- map all quantifiers to "exists" for the constraint check
res' = Result ki tr uic is' cs ts as uis ax asgn cstr [trueSW]
cvt = if useSMTLib2 config then toSMTLib2 else toSMTLib1
SatResult result <- runProofOn cvt config True [] res' >>= callSolver True "Checking Satisfiability.." SatResult config
case result of
Unsatisfiable{} -> return True -- constraints are unsatisfiable!
Satisfiable{} -> return False -- constraints are satisfiable!
Unknown{} -> error "SBV: isVacuous: Solver returned unknown!"
ProofError _ ls -> error $ "SBV: isVacuous: error encountered:\n" ++ unlines ls
TimeOut _ -> error "SBV: isVacuous: time-out."
-- | Find all satisfying assignments using the given SMT-solver
allSatWith :: Provable a => SMTConfig -> a -> IO AllSatResult
allSatWith config p = do
let converter = if useSMTLib2 config then toSMTLib2 else toSMTLib1
msg "Checking Satisfiability, all solutions.."
sbvPgm@(qinps, _, _, ki, _) <- simulate converter config True [] p
let usorts = [s | KUninterpreted s <- Set.toList ki]
unless (null usorts) $ msg $ "SBV.allSat: Uninterpreted sorts present: " ++ unwords usorts
++ "\n SBV will use equivalence classes to generate all-satisfying instances."
results <- unsafeInterleaveIO $ go sbvPgm (1::Int) []
-- See if there are any existentials below any universals
-- If such is the case, then the solutions are unique upto prefix existentials
let w = ALL `elem` map fst qinps
return $ AllSatResult (w, results)
where msg = when (verbose config) . putStrLn . ("** " ++)
go sbvPgm = loop
where loop !n nonEqConsts = do
curResult <- invoke nonEqConsts n sbvPgm
case curResult of
Nothing -> return []
Just (SatResult r) -> let cont model = do rest <- unsafeInterleaveIO $ loop (n+1) (modelAssocs model : nonEqConsts)
return (r : rest)
in case r of
Satisfiable _ (SMTModel [] _ _) -> return [r]
Unknown _ (SMTModel [] _ _) -> return [r]
ProofError _ _ -> return [r]
TimeOut _ -> return []
Unsatisfiable _ -> return []
Satisfiable _ model -> cont model
Unknown _ model -> cont model
invoke nonEqConsts n (qinps, modelMap, skolemMap, _, smtLibPgm) = do
msg $ "Looking for solution " ++ show n
case addNonEqConstraints (roundingMode config) qinps nonEqConsts smtLibPgm of
Nothing -> -- no new constraints added, stop
return Nothing
Just finalPgm -> do msg $ "Generated SMTLib program:\n" ++ finalPgm
smtAnswer <- engine (solver config) (updateName (n-1) config) True qinps modelMap skolemMap finalPgm
msg "Done.."
return $ Just $ SatResult smtAnswer
updateName i cfg = cfg{smtFile = upd `fmap` smtFile cfg}
where upd nm = let (b, e) = splitExtension nm in b ++ "_allSat_" ++ show i ++ e
type SMTProblem = ( [(Quantifier, NamedSymVar)] -- inputs
, [(String, UnintKind)] -- model-map
, [Either SW (SW, [SW])] -- skolem-map
, Set.Set Kind -- kinds used
, SMTLibPgm -- SMTLib representation
)
callSolver :: Bool -> String -> (SMTResult -> b) -> SMTConfig -> SMTProblem -> IO b
callSolver isSat checkMsg wrap config (qinps, modelMap, skolemMap, _, smtLibPgm) = do
let msg = when (verbose config) . putStrLn . ("** " ++)
msg checkMsg
let finalPgm = intercalate "\n" (pre ++ post) where SMTLibPgm _ (_, pre, post) = smtLibPgm
msg $ "Generated SMTLib program:\n" ++ finalPgm
smtAnswer <- engine (solver config) config isSat qinps modelMap skolemMap finalPgm
msg "Done.."
return $ wrap smtAnswer
simulate :: Provable a => SMTLibConverter -> SMTConfig -> Bool -> [String] -> a -> IO SMTProblem
simulate converter config isSat comments predicate = do
let msg = when (verbose config) . putStrLn . ("** " ++)
isTiming = timing config
msg "Starting symbolic simulation.."
res <- timeIf isTiming "problem construction" $ runSymbolic (isSat, Just config) $ (if isSat then forSome_ else forAll_) predicate >>= output
msg $ "Generated symbolic trace:\n" ++ show res
msg "Translating to SMT-Lib.."
runProofOn converter config isSat comments res
runProofOn :: SMTLibConverter -> SMTConfig -> Bool -> [String] -> Result -> IO SMTProblem
runProofOn converter config isSat comments res =
let isTiming = timing config
solverCaps = capabilities (solver config)
in case res of
Result ki _qcInfo _codeSegs is consts tbls arrs uis axs pgm cstrs [o@(SW KBool _)] ->
timeIf isTiming "translation"
$ let uiMap = mapMaybe arrayUIKind arrs ++ map unintFnUIKind uis
skolemMap = skolemize (if isSat then is else map flipQ is)
where flipQ (ALL, x) = (EX, x)
flipQ (EX, x) = (ALL, x)
skolemize :: [(Quantifier, NamedSymVar)] -> [Either SW (SW, [SW])]
skolemize qinps = go qinps ([], [])
where go [] (_, sofar) = reverse sofar
go ((ALL, (v, _)):rest) (us, sofar) = go rest (v:us, Left v : sofar)
go ((EX, (v, _)):rest) (us, sofar) = go rest (us, Right (v, reverse us) : sofar)
in return (is, uiMap, skolemMap, ki, converter (roundingMode config) (useLogic config) solverCaps ki isSat comments is skolemMap consts tbls arrs uis axs pgm cstrs o)
Result _kindInfo _qcInfo _codeSegs _is _consts _tbls _arrs _uis _axs _pgm _cstrs os -> case length os of
0 -> error $ "Impossible happened, unexpected non-outputting result\n" ++ show res
1 -> error $ "Impossible happened, non-boolean output in " ++ show os
++ "\nDetected while generating the trace:\n" ++ show res
_ -> error $ "User error: Multiple output values detected: " ++ show os
++ "\nDetected while generating the trace:\n" ++ show res
++ "\n*** Check calls to \"output\", they are typically not needed!"
-- | Check if a branch condition is feasible in the current state
isSBranchFeasibleInState :: State -> String -> SBool -> IO Bool
isSBranchFeasibleInState st branch cond = do
let cfg = let pickedConfig = fromMaybe defaultSMTCfg (getSBranchRunConfig st)
in pickedConfig { timeOut = sBranchTimeOut pickedConfig }
msg = when (verbose cfg) . putStrLn . ("** " ++)
sw <- sbvToSW st cond
() <- forceSWArg sw
Result ki tr uic is cs ts as uis ax asgn cstr _ <- liftIO $ extractSymbolicSimulationState st
let -- Construct the corresponding sat-checker for the branch. Note that we need to
-- forget about the quantifiers and just use an "exist", as we're looking for a
-- point-satisfiability check here; whatever the original program was.
pgm = Result ki tr uic [(EX, n) | (_, n) <- is] cs ts as uis ax asgn cstr [sw]
cvt = if useSMTLib2 cfg then toSMTLib2 else toSMTLib1
check <- runProofOn cvt cfg True [] pgm >>= callSolver True ("sBranch: Checking " ++ show branch ++ " feasibility") SatResult cfg
res <- case check of
SatResult (Unsatisfiable _) -> return False
_ -> return True -- No risks, even if it timed-our or anything else, we say it's feasible
msg $ "sBranch: Conclusion: " ++ if res then "Feasible" else "Unfeasible"
return res

121
sbv/Data/SBV/Provers/SExpr.hs
View File

@ -1,121 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Provers.SExpr
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Parsing of S-expressions (mainly used for parsing SMT-Lib get-value output)
-----------------------------------------------------------------------------
module Data.SBV.Provers.SExpr where
import Data.Char (isDigit, ord)
import Data.List (isPrefixOf)
import Numeric (readInt, readDec, readHex, fromRat)
import Data.SBV.BitVectors.AlgReals
import Data.SBV.BitVectors.Data (nan, infinity)
-- | ADT S-Expression format, suitable for representing get-model output of SMT-Lib
data SExpr = ECon String
| ENum Integer
| EReal AlgReal
| EFloat Float
| EDouble Double
| EApp [SExpr]
deriving Show
-- | Parse a string into an SExpr, potentially failing with an error message
parseSExpr :: String -> Either String SExpr
parseSExpr inp = do (sexp, extras) <- parse inpToks
if null extras
then return sexp
else die "Extra tokens after valid input"
where inpToks = let cln "" sofar = sofar
cln ('(':r) sofar = cln r (" ( " ++ sofar)
cln (')':r) sofar = cln r (" ) " ++ sofar)
cln (':':':':r) sofar = cln r (" :: " ++ sofar)
cln (c:r) sofar = cln r (c:sofar)
in reverse (map reverse (words (cln inp "")))
die w = fail $ "SBV.Provers.SExpr: Failed to parse S-Expr: " ++ w
++ "\n*** Input : <" ++ inp ++ ">"
parse [] = die "ran out of tokens"
parse ("(":toks) = do (f, r) <- parseApp toks []
f' <- cvt (EApp f)
return (f', r)
parse (")":_) = die "extra tokens after close paren"
parse [tok] = do t <- pTok tok
return (t, [])
parse _ = die "ill-formed s-expr"
parseApp [] _ = die "failed to grab s-expr application"
parseApp (")":toks) sofar = return (reverse sofar, toks)
parseApp ("(":toks) sofar = do (f, r) <- parse ("(":toks)
parseApp r (f : sofar)
parseApp (tok:toks) sofar = do t <- pTok tok
parseApp toks (t : sofar)
pTok "false" = return $ ENum 0
pTok "true" = return $ ENum 1
pTok ('0':'b':r) = mkNum $ readInt 2 (`elem` "01") (\c -> ord c - ord '0') r
pTok ('b':'v':r) = mkNum $ readDec (takeWhile (/= '[') r)
pTok ('#':'b':r) = mkNum $ readInt 2 (`elem` "01") (\c -> ord c - ord '0') r
pTok ('#':'x':r) = mkNum $ readHex r
pTok n
| not (null n) && isDigit (head n)
= if '.' `elem` n then getReal n
else mkNum $ readDec n
pTok n = return $ ECon n
mkNum [(n, "")] = return $ ENum n
mkNum _ = die "cannot read number"
getReal n = return $ EReal $ mkPolyReal (Left (exact, n'))
where exact = not ("?" `isPrefixOf` reverse n)
n' | exact = n
| True = init n
-- simplify numbers and root-obj values
cvt (EApp [ECon "/", EReal a, EReal b]) = return $ EReal (a / b)
cvt (EApp [ECon "/", EReal a, ENum b]) = return $ EReal (a / fromInteger b)
cvt (EApp [ECon "/", ENum a, EReal b]) = return $ EReal (fromInteger a / b)
cvt (EApp [ECon "/", ENum a, ENum b]) = return $ EReal (fromInteger a / fromInteger b)
cvt (EApp [ECon "-", EReal a]) = return $ EReal (-a)
cvt (EApp [ECon "-", ENum a]) = return $ ENum (-a)
-- bit-vector value as CVC4 prints: (_ bv0 16) for instance
cvt (EApp [ECon "_", ENum a, ENum _b]) = return $ ENum a
cvt (EApp [ECon "root-obj", EApp (ECon "+":trms), ENum k]) = do ts <- mapM getCoeff trms
return $ EReal $ mkPolyReal (Right (k, ts))
cvt (EApp [ECon "as", n, EApp [ECon "_", ECon "FP", ENum 11, ENum 53]]) = getDouble n
cvt (EApp [ECon "as", n, EApp [ECon "_", ECon "FP", ENum 8, ENum 24]]) = getFloat n
cvt x = return x
getCoeff (EApp [ECon "*", ENum k, EApp [ECon "^", ECon "x", ENum p]]) = return (k, p) -- kx^p
getCoeff (EApp [ECon "*", ENum k, ECon "x" ] ) = return (k, 1) -- kx
getCoeff ( EApp [ECon "^", ECon "x", ENum p] ) = return (1, p) -- x^p
getCoeff ( ECon "x" ) = return (1, 1) -- x
getCoeff ( ENum k ) = return (k, 0) -- k
getCoeff x = die $ "Cannot parse a root-obj,\nProcessing term: " ++ show x
getDouble (ECon s) = case (s, rdFP (dropWhile (== '+') s)) of
("plusInfinity", _ ) -> return $ EDouble infinity
("minusInfinity", _ ) -> return $ EDouble (-infinity)
("NaN", _ ) -> return $ EDouble nan
(_, Just v) -> return $ EDouble v
_ -> die $ "Cannot parse a double value from: " ++ s
getDouble (EReal r) = return $ EDouble $ fromRat $ toRational r
getDouble x = die $ "Cannot parse a double value from: " ++ show x
getFloat (ECon s) = case (s, rdFP (dropWhile (== '+') s)) of
("plusInfinity", _ ) -> return $ EFloat infinity
("minusInfinity", _ ) -> return $ EFloat (-infinity)
("NaN", _ ) -> return $ EFloat nan
(_, Just v) -> return $ EFloat v
_ -> die $ "Cannot parse a float value from: " ++ s
getFloat (EReal r) = return $ EFloat $ fromRat $ toRational r
getFloat x = die $ "Cannot parse a float value from: " ++ show x
-- | Parses the Z3 floating point formatted numbers like so: 1.321p5/1.2123e9 etc.
rdFP :: (Read a, RealFloat a) => String -> Maybe a
rdFP s = case break (`elem` "pe") s of
(m, 'p':e) -> rd m >>= \m' -> rd e >>= \e' -> return $ m' * ( 2 ** e')
(m, 'e':e) -> rd m >>= \m' -> rd e >>= \e' -> return $ m' * (10 ** e')
(m, "") -> rd m
_ -> Nothing
where rd v = case reads v of
[(n, "")] -> Just n
_ -> Nothing

159
sbv/Data/SBV/Provers/Yices.hs
View File

@ -1,159 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Provers.Yices
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- The connection to the Yices SMT solver
-----------------------------------------------------------------------------
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.SBV.Provers.Yices(yices) where
import qualified Control.Exception as C
import Data.Char (isDigit)
import Data.List (sortBy, isPrefixOf, intercalate, transpose, partition)
import Data.Maybe (mapMaybe, isNothing, fromJust)
import System.Environment (getEnv)
import Data.SBV.BitVectors.Data
import Data.SBV.Provers.SExpr
import Data.SBV.SMT.SMT
import Data.SBV.SMT.SMTLib
-- | The description of the Yices SMT solver
-- The default executable is @\"yices-smt\"@, which must be in your path. You can use the @SBV_YICES@ environment variable to point to the executable on your system.
-- The default options are @\"-m -f\"@, which is valid for Yices 2.1 series. You can use the @SBV_YICES_OPTIONS@ environment variable to override the options.
yices :: SMTSolver
yices = SMTSolver {
name = Yices
, executable = "yices-smt"
-- , options = ["-tc", "-smt", "-e"] -- For Yices1
, options = ["-m", "-f"] -- For Yices2
, engine = \cfg _isSat qinps modelMap _skolemMap pgm -> do
execName <- getEnv "SBV_YICES" `C.catch` (\(_ :: C.SomeException) -> return (executable (solver cfg)))
execOpts <- (words `fmap` getEnv "SBV_YICES_OPTIONS") `C.catch` (\(_ :: C.SomeException) -> return (options (solver cfg)))
let cfg' = cfg {solver = (solver cfg) {executable = execName, options = addTimeOut (timeOut cfg) execOpts}}
script = SMTScript {scriptBody = unlines (solverTweaks cfg') ++ pgm, scriptModel = Nothing}
standardSolver cfg' script id (ProofError cfg') (interpretSolverOutput cfg' (extractMap (map snd qinps) modelMap))
, xformExitCode = id
, capabilities = SolverCapabilities {
capSolverName = "Yices"
, mbDefaultLogic = Nothing
, supportsMacros = False
, supportsProduceModels = False
, supportsQuantifiers = False
, supportsUninterpretedSorts = False
, supportsUnboundedInts = False
, supportsReals = False
, supportsFloats = False
, supportsDoubles = False
}
}
where addTimeOut Nothing o = o
addTimeOut (Just i) o
| i < 0 = error $ "Yices: Timeout value must be non-negative, received: " ++ show i
| True = o ++ ["-t", show i]
sortByNodeId :: [(Int, a)] -> [(Int, a)]
sortByNodeId = sortBy (\(x, _) (y, _) -> compare x y)
extractMap :: [NamedSymVar] -> [(String, UnintKind)] -> [String] -> SMTModel
extractMap inps modelMap solverLines =
SMTModel { modelAssocs = map snd $ sortByNodeId $ concatMap (getCounterExample inps) modelLines
, modelUninterps = [(n, ls) | (UFun _ n, ls) <- uis]
, modelArrays = [(n, ls) | (UArr _ n, ls) <- uis]
}
where (modelLines, unintLines) = moveConstUIs $ break ("--- " `isPrefixOf`) solverLines
uis = extractUnints modelMap unintLines
-- another crude hack
moveConstUIs :: ([String], [String]) -> ([String], [String])
moveConstUIs (pre, post) = (pre', concatMap mkDecl extras ++ post)
where (extras, pre') = partition ("(= uninterpreted_" `isPrefixOf`) pre
mkDecl s = ["--- " ++ takeWhile (/= ' ') (drop 3 s) ++ " ---", s]
getCounterExample :: [NamedSymVar] -> String -> [(Int, (String, CW))]
getCounterExample inps line = either err extract (parseSExpr line)
where err r = error $ "*** Failed to parse Yices model output from: "
++ "*** " ++ show line ++ "\n"
++ "*** Reason: " ++ r ++ "\n"
isInput ('s':v)
| all isDigit v = let inpId :: Int
inpId = read v
in case [(s, nm) | (s@(SW _ (NodeId n)), nm) <- inps, n == inpId] of
[] -> Nothing
[(s, nm)] -> Just (inpId, s, nm)
matches -> error $ "SBV.Yices: Cannot uniquely identify value for "
++ 's':v ++ " in " ++ show matches
isInput _ = Nothing
extract (EApp [ECon "=", ECon v, ENum i]) | Just (n, s, nm) <- isInput v = [(n, (nm, mkConstCW (kindOf s) i))]
extract (EApp [ECon "=", ENum i, ECon v]) | Just (n, s, nm) <- isInput v = [(n, (nm, mkConstCW (kindOf s) i))]
extract _ = []
extractUnints :: [(String, UnintKind)] -> [String] -> [(UnintKind, [String])]
extractUnints modelMap = mapMaybe (extractUnint modelMap) . chunks
where chunks [] = []
chunks (x:xs) = let (f, r) = break ("---" `isPrefixOf`) xs in (x:f) : chunks r
-- Parsing the Yices output is done extremely crudely and designed
-- mostly by observation of Yices output. Likely to have bugs and
-- brittle as Yices evolves. We really need an SMT-Lib2 like interface.
extractUnint :: [(String, UnintKind)] -> [String] -> Maybe (UnintKind, [String])
extractUnint _ [] = Nothing
extractUnint mmap (tag : rest)
| null tag' = Nothing
| isNothing mbKnd = Nothing
| True = mapM (getUIVal knd) rest >>= \xs -> return (knd, format knd xs)
where mbKnd | "--- uninterpreted_" `isPrefixOf` tag = uf `lookup` mmap
| True = af `lookup` mmap
knd = fromJust mbKnd
tag' = dropWhile (/= '_') tag
f = takeWhile (/= ' ') (tail tag')
uf = f
af = "array_" ++ f
getUIVal :: UnintKind -> String -> Maybe (String, [String], String)
getUIVal knd s
| "default: " `isPrefixOf` s
= getDefaultVal knd (dropWhile (/= ' ') s)
| True
= case parseSExpr s of
Right (EApp [ECon "=", EApp (ECon _ : args), ENum i]) -> getCallVal knd args i
Right (EApp [ECon "=", ECon _, ENum i]) -> getCallVal knd [] i
_ -> Nothing
getDefaultVal :: UnintKind -> String -> Maybe (String, [String], String)
getDefaultVal knd n = case parseSExpr n of
Right (ENum i) -> Just $ showDefault knd (show i)
_ -> Nothing
getCallVal :: UnintKind -> [SExpr] -> Integer -> Maybe (String, [String], String)
getCallVal knd args res = mapM getArg args >>= \as -> return (showCall knd as (show res))
getArg :: SExpr -> Maybe String
getArg (ENum i) = Just (show i)
getArg _ = Nothing
showDefault :: UnintKind -> String -> (String, [String], String)
showDefault (UFun cnt f) res = (f, replicate cnt "_", res)
showDefault (UArr cnt f) res = (f, replicate cnt "_", res)
showCall :: UnintKind -> [String] -> String -> (String, [String], String)
showCall (UFun _ f) as res = (f, as, res)
showCall (UArr _ f) as res = (f, as, res)
format :: UnintKind -> [(String, [String], String)] -> [String]
format (UFun{}) eqns = fmtFun eqns
format (UArr{}) eqns = let fmt (f, as, r) = f ++ "[" ++ intercalate ", " as ++ "] = " ++ r in map fmt eqns
fmtFun :: [(String, [String], String)] -> [String]
fmtFun ls = map fmt ls
where fmt (f, as, r) = f ++ " " ++ unwords (zipWith align as (lens ++ repeat 0)) ++ " = " ++ r
lens = map (maximum . (0:) . map length) $ transpose [as | (_, as, _) <- ls]
align s i = take (i `max` length s) (s ++ repeat ' ')

121
sbv/Data/SBV/Provers/Z3.hs
View File

@ -1,121 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Provers.Z3
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- The connection to the Z3 SMT solver
-----------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
module Data.SBV.Provers.Z3(z3) where
import qualified Control.Exception as C
import Data.Char (toLower)
import Data.Function (on)
import Data.List (sortBy, intercalate, isPrefixOf, groupBy)
import System.Environment (getEnv)
import qualified System.Info as S(os)
import Data.SBV.BitVectors.AlgReals
import Data.SBV.BitVectors.Data
import Data.SBV.BitVectors.PrettyNum
import Data.SBV.SMT.SMT
import Data.SBV.SMT.SMTLib
-- Choose the correct prefix character for passing options
-- TBD: Is there a more foolproof way of determining this?
optionPrefix :: Char
optionPrefix
| map toLower S.os `elem` ["linux", "darwin"] = '-'
| True = '/' -- windows
-- | The description of the Z3 SMT solver
-- The default executable is @\"z3\"@, which must be in your path. You can use the @SBV_Z3@ environment variable to point to the executable on your system.
-- The default options are @\"-in -smt2\"@, which is valid for Z3 4.1. You can use the @SBV_Z3_OPTIONS@ environment variable to override the options.
z3 :: SMTSolver
z3 = SMTSolver {
name = Z3
, executable = "z3"
, options = map (optionPrefix:) ["in", "smt2"]
, engine = \cfg isSat qinps modelMap skolemMap pgm -> do
execName <- getEnv "SBV_Z3" `C.catch` (\(_ :: C.SomeException) -> return (executable (solver cfg)))
execOpts <- (words `fmap` getEnv "SBV_Z3_OPTIONS") `C.catch` (\(_ :: C.SomeException) -> return (options (solver cfg)))
let cfg' = cfg { solver = (solver cfg) {executable = execName, options = addTimeOut (timeOut cfg) execOpts} }
tweaks = case solverTweaks cfg' of
[] -> ""
ts -> unlines $ "; --- user given solver tweaks ---" : ts ++ ["; --- end of user given tweaks ---"]
dlim = printRealPrec cfg'
ppDecLim = "(set-option :pp.decimal_precision " ++ show dlim ++ ")\n"
script = SMTScript {scriptBody = tweaks ++ ppDecLim ++ pgm, scriptModel = Just (cont (roundingMode cfg) skolemMap)}
if dlim < 1
then error $ "SBV.Z3: printRealPrec value should be at least 1, invalid value received: " ++ show dlim
else standardSolver cfg' script cleanErrs (ProofError cfg') (interpretSolverOutput cfg' (extractMap isSat qinps modelMap))
, xformExitCode = id
, capabilities = SolverCapabilities {
capSolverName = "Z3"
, mbDefaultLogic = Nothing
, supportsMacros = True
, supportsProduceModels = True
, supportsQuantifiers = True
, supportsUninterpretedSorts = True
, supportsUnboundedInts = True
, supportsReals = True
, supportsFloats = True
, supportsDoubles = True
}
}
where cleanErrs = intercalate "\n" . filter (not . junk) . lines
junk = ("WARNING:" `isPrefixOf`)
zero :: RoundingMode -> Kind -> String
zero _ KBool = "false"
zero _ (KBounded _ sz) = "#x" ++ replicate (sz `div` 4) '0'
zero _ KUnbounded = "0"
zero _ KReal = "0.0"
zero rm KFloat = showSMTFloat rm 0
zero rm KDouble = showSMTDouble rm 0
zero _ (KUninterpreted s) = error $ "SBV.Z3.zero: Unexpected uninterpreted sort: " ++ s
cont rm skolemMap = intercalate "\n" $ concatMap extract skolemMap
where -- In the skolemMap:
-- * Left's are universals: i.e., the model should be true for
-- any of these. So, we simply "echo 0" for these values.
-- * Right's are existentials. If there are no dependencies (empty list), then we can
-- simply use get-value to extract it's value. Otherwise, we have to apply it to
-- an appropriate number of 0's to get the final value.
extract (Left s) = ["(echo \"((" ++ show s ++ " " ++ zero rm (kindOf s) ++ "))\")"]
extract (Right (s, [])) = let g = "(get-value (" ++ show s ++ "))" in getVal (kindOf s) g
extract (Right (s, ss)) = let g = "(get-value ((" ++ show s ++ concat [' ' : zero rm (kindOf a) | a <- ss] ++ ")))" in getVal (kindOf s) g
getVal KReal g = ["(set-option :pp.decimal false) " ++ g, "(set-option :pp.decimal true) " ++ g]
getVal _ g = [g]
addTimeOut Nothing o = o
addTimeOut (Just i) o
| i < 0 = error $ "Z3: Timeout value must be non-negative, received: " ++ show i
| True = o ++ [optionPrefix : "T:" ++ show i]
extractMap :: Bool -> [(Quantifier, NamedSymVar)] -> [(String, UnintKind)] -> [String] -> SMTModel
extractMap isSat qinps _modelMap solverLines =
SMTModel { modelAssocs = map snd $ squashReals $ sortByNodeId $ concatMap (interpretSolverModelLine inps) solverLines
, modelUninterps = []
, modelArrays = []
}
where sortByNodeId :: [(Int, a)] -> [(Int, a)]
sortByNodeId = sortBy (compare `on` fst)
inps -- for "sat", display the prefix existentials. For completeness, we will drop
-- only the trailing foralls. Exception: Don't drop anything if it's all a sequence of foralls
| isSat = map snd $ if all (== ALL) (map fst qinps)
then qinps
else reverse $ dropWhile ((== ALL) . fst) $ reverse qinps
-- for "proof", just display the prefix universals
| True = map snd $ takeWhile ((== ALL) . fst) qinps
squashReals :: [(Int, (String, CW))] -> [(Int, (String, CW))]
squashReals = concatMap squash . groupBy ((==) `on` fst)
where squash [(i, (n, cw1)), (_, (_, cw2))] = [(i, (n, mergeReals n cw1 cw2))]
squash xs = xs
mergeReals :: String -> CW -> CW -> CW
mergeReals n (CW KReal (CWAlgReal a)) (CW KReal (CWAlgReal b)) = CW KReal (CWAlgReal (mergeAlgReals (bad n a b) a b))
mergeReals n a b = bad n a b
bad n a b = error $ "SBV.Z3: Cannot merge reals for variable: " ++ n ++ " received: " ++ show (a, b)

466
sbv/Data/SBV/SMT/SMT.hs
View File

@ -1,466 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.SMT.SMT
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Abstraction of SMT solvers
-----------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
module Data.SBV.SMT.SMT where
import qualified Control.Exception as C
import Control.Concurrent (newEmptyMVar, takeMVar, putMVar, forkIO)
import Control.Monad (when, zipWithM)
import Data.Char (isSpace)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.List (intercalate, isPrefixOf, isInfixOf)
import Data.Word (Word8, Word16, Word32, Word64)
import System.Directory (findExecutable)
import System.Process (runInteractiveProcess, waitForProcess, terminateProcess)
import System.Exit (ExitCode(..))
import System.IO (hClose, hFlush, hPutStr, hGetContents, hGetLine)
import qualified Data.Map as M
import Data.SBV.BitVectors.AlgReals
import Data.SBV.BitVectors.Data
import Data.SBV.BitVectors.PrettyNum
import Data.SBV.Utils.TDiff
-- | Extract the final configuration from a result
resultConfig :: SMTResult -> SMTConfig
resultConfig (Unsatisfiable c) = c
resultConfig (Satisfiable c _) = c
resultConfig (Unknown c _) = c
resultConfig (ProofError c _) = c
resultConfig (TimeOut c) = c
-- | A 'prove' call results in a 'ThmResult'
newtype ThmResult = ThmResult SMTResult
-- | A 'sat' call results in a 'SatResult'
-- The reason for having a separate 'SatResult' is to have a more meaningful 'Show' instance.
newtype SatResult = SatResult SMTResult
-- | An 'allSat' call results in a 'AllSatResult'. The boolean says whether
-- we should warn the user about prefix-existentials.
newtype AllSatResult = AllSatResult (Bool, [SMTResult])
-- | User friendly way of printing theorem results
instance Show ThmResult where
show (ThmResult r) = showSMTResult "Q.E.D."
"Unknown" "Unknown. Potential counter-example:\n"
"Falsifiable" "Falsifiable. Counter-example:\n" r
-- | User friendly way of printing satisfiablity results
instance Show SatResult where
show (SatResult r) = showSMTResult "Unsatisfiable"
"Unknown" "Unknown. Potential model:\n"
"Satisfiable" "Satisfiable. Model:\n" r
-- | The Show instance of AllSatResults. Note that we have to be careful in being lazy enough
-- as the typical use case is to pull results out as they become available.
instance Show AllSatResult where
show (AllSatResult (e, xs)) = go (0::Int) xs
where uniqueWarn | e = " (Unique up to prefix existentials.)"
| True = ""
go c (s:ss) = let c' = c+1
(ok, o) = sh c' s
in c' `seq` if ok then o ++ "\n" ++ go c' ss else o
go c [] = case c of
0 -> "No solutions found."
1 -> "This is the only solution." ++ uniqueWarn
_ -> "Found " ++ show c ++ " different solutions." ++ uniqueWarn
sh i c = (ok, showSMTResult "Unsatisfiable"
"Unknown" "Unknown. Potential model:\n"
("Solution #" ++ show i ++ ":\n[Backend solver returned no assignment to variables.]") ("Solution #" ++ show i ++ ":\n") c)
where ok = case c of
Satisfiable{} -> True
_ -> False
-- | Instances of 'SatModel' can be automatically extracted from models returned by the
-- solvers. The idea is that the sbv infrastructure provides a stream of 'CW''s (constant-words)
-- coming from the solver, and the type @a@ is interpreted based on these constants. Many typical
-- instances are already provided, so new instances can be declared with relative ease.
--
-- Minimum complete definition: 'parseCWs'
class SatModel a where
-- | Given a sequence of constant-words, extract one instance of the type @a@, returning
-- the remaining elements untouched. If the next element is not what's expected for this
-- type you should return 'Nothing'
parseCWs :: [CW] -> Maybe (a, [CW])
-- | Given a parsed model instance, transform it using @f@, and return the result.
-- The default definition for this method should be sufficient in most use cases.
cvtModel :: (a -> Maybe b) -> Maybe (a, [CW]) -> Maybe (b, [CW])
cvtModel f x = x >>= \(a, r) -> f a >>= \b -> return (b, r)
-- | Parse a signed/sized value from a sequence of CWs
genParse :: Integral a => Kind -> [CW] -> Maybe (a, [CW])
genParse k (x@(CW _ (CWInteger i)):r) | kindOf x == k = Just (fromIntegral i, r)
genParse _ _ = Nothing
-- | Base case for 'SatModel' at unit type. Comes in handy if there are no real variables.
instance SatModel () where
parseCWs xs = return ((), xs)
-- | 'Bool' as extracted from a model
instance SatModel Bool where
parseCWs xs = do (x, r) <- genParse KBool xs
return ((x :: Integer) /= 0, r)
-- | 'Word8' as extracted from a model
instance SatModel Word8 where
parseCWs = genParse (KBounded False 8)
-- | 'Int8' as extracted from a model
instance SatModel Int8 where
parseCWs = genParse (KBounded True 8)
-- | 'Word16' as extracted from a model
instance SatModel Word16 where
parseCWs = genParse (KBounded False 16)
-- | 'Int16' as extracted from a model
instance SatModel Int16 where
parseCWs = genParse (KBounded True 16)
-- | 'Word32' as extracted from a model
instance SatModel Word32 where
parseCWs = genParse (KBounded False 32)
-- | 'Int32' as extracted from a model
instance SatModel Int32 where
parseCWs = genParse (KBounded True 32)
-- | 'Word64' as extracted from a model
instance SatModel Word64 where
parseCWs = genParse (KBounded False 64)
-- | 'Int64' as extracted from a model
instance SatModel Int64 where
parseCWs = genParse (KBounded True 64)
-- | 'Integer' as extracted from a model
instance SatModel Integer where
parseCWs = genParse KUnbounded
-- | 'AlgReal' as extracted from a model
instance SatModel AlgReal where
parseCWs (CW KReal (CWAlgReal i) : r) = Just (i, r)
parseCWs _ = Nothing
-- | 'Float' as extracted from a model
instance SatModel Float where
parseCWs (CW KFloat (CWFloat i) : r) = Just (i, r)
parseCWs _ = Nothing
-- | 'Double' as extracted from a model
instance SatModel Double where
parseCWs (CW KDouble (CWDouble i) : r) = Just (i, r)
parseCWs _ = Nothing
instance SatModel CW where
parseCWs (cw : r) = Just (cw, r)
parseCWs [] = Nothing
-- | A list of values as extracted from a model. When reading a list, we
-- go as long as we can (maximal-munch). Note that this never fails, as
-- we can always return the empty list!
instance SatModel a => SatModel [a] where
parseCWs [] = Just ([], [])
parseCWs xs = case parseCWs xs of
Just (a, ys) -> case parseCWs ys of
Just (as, zs) -> Just (a:as, zs)
Nothing -> Just ([], ys)
Nothing -> Just ([], xs)
-- | Tuples extracted from a model
instance (SatModel a, SatModel b) => SatModel (a, b) where
parseCWs as = do (a, bs) <- parseCWs as
(b, cs) <- parseCWs bs
return ((a, b), cs)
-- | 3-Tuples extracted from a model
instance (SatModel a, SatModel b, SatModel c) => SatModel (a, b, c) where
parseCWs as = do (a, bs) <- parseCWs as
((b, c), ds) <- parseCWs bs
return ((a, b, c), ds)
-- | 4-Tuples extracted from a model
instance (SatModel a, SatModel b, SatModel c, SatModel d) => SatModel (a, b, c, d) where
parseCWs as = do (a, bs) <- parseCWs as
((b, c, d), es) <- parseCWs bs
return ((a, b, c, d), es)
-- | 5-Tuples extracted from a model
instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e) => SatModel (a, b, c, d, e) where
parseCWs as = do (a, bs) <- parseCWs as
((b, c, d, e), fs) <- parseCWs bs
return ((a, b, c, d, e), fs)
-- | 6-Tuples extracted from a model
instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e, SatModel f) => SatModel (a, b, c, d, e, f) where
parseCWs as = do (a, bs) <- parseCWs as
((b, c, d, e, f), gs) <- parseCWs bs
return ((a, b, c, d, e, f), gs)
-- | 7-Tuples extracted from a model
instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e, SatModel f, SatModel g) => SatModel (a, b, c, d, e, f, g) where
parseCWs as = do (a, bs) <- parseCWs as
((b, c, d, e, f, g), hs) <- parseCWs bs
return ((a, b, c, d, e, f, g), hs)
-- | Various SMT results that we can extract models out of.
class Modelable a where
-- | Is there a model?
modelExists :: a -> Bool
-- | Extract a model, the result is a tuple where the first argument (if True)
-- indicates whether the model was "probable". (i.e., if the solver returned unknown.)
getModel :: SatModel b => a -> Either String (Bool, b)
-- | Extract a model dictionary. Extract a dictionary mapping the variables to
-- their respective values as returned by the SMT solver. Also see `getModelDictionaries`.
getModelDictionary :: a -> M.Map String CW
-- | Extract a model value for a given element. Also see `getModelValues`.
getModelValue :: SymWord b => String -> a -> Maybe b
getModelValue v r = fromCW `fmap` (v `M.lookup` getModelDictionary r)
-- | Extract a representative name for the model value of an uninterpreted kind.
-- This is supposed to correspond to the value as computed internally by the
-- SMT solver; and is unportable from solver to solver. Also see `getModelUninterpretedValues`.
getModelUninterpretedValue :: String -> a -> Maybe String
getModelUninterpretedValue v r = case v `M.lookup` getModelDictionary r of
Just (CW _ (CWUninterpreted s)) -> Just s
_ -> Nothing
-- | A simpler variant of 'getModel' to get a model out without the fuss.
extractModel :: SatModel b => a -> Maybe b
extractModel a = case getModel a of
Right (_, b) -> Just b
_ -> Nothing
-- | Return all the models from an 'allSat' call, similar to 'extractModel' but
-- is suitable for the case of multiple results.
extractModels :: SatModel a => AllSatResult -> [a]
extractModels (AllSatResult (_, xs)) = [ms | Right (_, ms) <- map getModel xs]
-- | Get dictionaries from an all-sat call. Similar to `getModelDictionary`.
getModelDictionaries :: AllSatResult -> [M.Map String CW]
getModelDictionaries (AllSatResult (_, xs)) = map getModelDictionary xs
-- | Extract value of a variable from an all-sat call. Similar to `getModelValue`.
getModelValues :: SymWord b => String -> AllSatResult -> [Maybe b]
getModelValues s (AllSatResult (_, xs)) = map (s `getModelValue`) xs
-- | Extract value of an uninterpreted variable from an all-sat call. Similar to `getModelUninterpretedValue`.
getModelUninterpretedValues :: String -> AllSatResult -> [Maybe String]
getModelUninterpretedValues s (AllSatResult (_, xs)) = map (s `getModelUninterpretedValue`) xs
-- | 'ThmResult' as a generic model provider
instance Modelable ThmResult where
getModel (ThmResult r) = getModel r
modelExists (ThmResult r) = modelExists r
getModelDictionary (ThmResult r) = getModelDictionary r
-- | 'SatResult' as a generic model provider
instance Modelable SatResult where
getModel (SatResult r) = getModel r
modelExists (SatResult r) = modelExists r
getModelDictionary (SatResult r) = getModelDictionary r
-- | 'SMTResult' as a generic model provider
instance Modelable SMTResult where
getModel (Unsatisfiable _) = Left "SBV.getModel: Unsatisfiable result"
getModel (Unknown _ m) = Right (True, parseModelOut m)
getModel (ProofError _ s) = error $ unlines $ "Backend solver complains: " : s
getModel (TimeOut _) = Left "Timeout"
getModel (Satisfiable _ m) = Right (False, parseModelOut m)
modelExists (Satisfiable{}) = True
modelExists (Unknown{}) = False -- don't risk it
modelExists _ = False
getModelDictionary (Unsatisfiable _) = M.empty
getModelDictionary (Unknown _ m) = M.fromList (modelAssocs m)
getModelDictionary (ProofError _ _) = M.empty
getModelDictionary (TimeOut _) = M.empty
getModelDictionary (Satisfiable _ m) = M.fromList (modelAssocs m)
-- | Extract a model out, will throw error if parsing is unsuccessful
parseModelOut :: SatModel a => SMTModel -> a
parseModelOut m = case parseCWs [c | (_, c) <- modelAssocs m] of
Just (x, []) -> x
Just (_, ys) -> error $ "SBV.getModel: Partially constructed model; remaining elements: " ++ show ys
Nothing -> error $ "SBV.getModel: Cannot construct a model from: " ++ show m
-- | Given an 'allSat' call, we typically want to iterate over it and print the results in sequence. The
-- 'displayModels' function automates this task by calling 'disp' on each result, consecutively. The first
-- 'Int' argument to 'disp' 'is the current model number. The second argument is a tuple, where the first
-- element indicates whether the model is alleged (i.e., if the solver is not sure, returing Unknown)
displayModels :: SatModel a => (Int -> (Bool, a) -> IO ()) -> AllSatResult -> IO Int
displayModels disp (AllSatResult (_, ms)) = do
inds <- zipWithM display [a | Right a <- map (getModel . SatResult) ms] [(1::Int)..]
return $ last (0:inds)
where display r i = disp i r >> return i
-- | Show an SMTResult; generic version
showSMTResult :: String -> String -> String -> String -> String -> SMTResult -> String
showSMTResult unsatMsg unkMsg unkMsgModel satMsg satMsgModel result = case result of
Unsatisfiable _ -> unsatMsg
Satisfiable _ (SMTModel [] [] []) -> satMsg
Satisfiable _ m -> satMsgModel ++ showModel cfg m
Unknown _ (SMTModel [] [] []) -> unkMsg
Unknown _ m -> unkMsgModel ++ showModel cfg m
ProofError _ [] -> "*** An error occurred. No additional information available. Try running in verbose mode"
ProofError _ ls -> "*** An error occurred.\n" ++ intercalate "\n" (map ("*** " ++) ls)
TimeOut _ -> "*** Timeout"
where cfg = resultConfig result
-- | Show a model in human readable form
showModel :: SMTConfig -> SMTModel -> String
showModel cfg m = intercalate "\n" (map shM assocs ++ concatMap shUI uninterps ++ concatMap shUA arrs)
where assocs = modelAssocs m
uninterps = modelUninterps m
arrs = modelArrays m
shM (s, v) = " " ++ s ++ " = " ++ shCW cfg v
-- | Show a constant value, in the user-specified base
shCW :: SMTConfig -> CW -> String
shCW = sh . printBase
where sh 2 = binS
sh 10 = show
sh 16 = hexS
sh n = \w -> show w ++ " -- Ignoring unsupported printBase " ++ show n ++ ", use 2, 10, or 16."
-- | Print uninterpreted function values from models. Very, very crude..
shUI :: (String, [String]) -> [String]
shUI (flong, cases) = (" -- uninterpreted: " ++ f) : map shC cases
where tf = dropWhile (/= '_') flong
f = if null tf then flong else tail tf
shC s = " " ++ s
-- | Print uninterpreted array values from models. Very, very crude..
shUA :: (String, [String]) -> [String]
shUA (f, cases) = (" -- array: " ++ f) : map shC cases
where shC s = " " ++ s
-- | Helper function to spin off to an SMT solver.
pipeProcess :: SMTConfig -> String -> [String] -> SMTScript -> (String -> String) -> IO (Either String [String])
pipeProcess cfg execName opts script cleanErrs = do
let nm = show (name (solver cfg))
mbExecPath <- findExecutable execName
case mbExecPath of
Nothing -> return $ Left $ "Unable to locate executable for " ++ nm
++ "\nExecutable specified: " ++ show execName
Just execPath -> do (ec, contents, allErrors) <- runSolver cfg execPath opts script
let errors = dropWhile isSpace (cleanErrs allErrors)
case (null errors, xformExitCode (solver cfg) ec) of
(True, ExitSuccess) -> return $ Right $ map clean (filter (not . null) (lines contents))
(_, ec') -> let errors' = if null errors
then (if null (dropWhile isSpace contents)
then "(No error message printed on stderr by the executable.)"
else contents)
else errors
finalEC = case (ec', ec) of
(ExitFailure n, _) -> n
(_, ExitFailure n) -> n
_ -> 0 -- can happen if ExitSuccess but there is output on stderr
in return $ Left $ "Failed to complete the call to " ++ nm
++ "\nExecutable : " ++ show execPath
++ "\nOptions : " ++ unwords opts
++ "\nExit code : " ++ show finalEC
++ "\nSolver output: "
++ "\n" ++ line ++ "\n"
++ intercalate "\n" (filter (not . null) (lines errors'))
++ "\n" ++ line
++ "\nGiving up.."
where clean = reverse . dropWhile isSpace . reverse . dropWhile isSpace
line = replicate 78 '='
-- | A standard solver interface. If the solver is SMT-Lib compliant, then this function should suffice in
-- communicating with it.
standardSolver :: SMTConfig -> SMTScript -> (String -> String) -> ([String] -> a) -> ([String] -> a) -> IO a
standardSolver config script cleanErrs failure success = do
let msg = when (verbose config) . putStrLn . ("** " ++)
smtSolver= solver config
exec = executable smtSolver
opts = options smtSolver
isTiming = timing config
nmSolver = show (name smtSolver)
msg $ "Calling: " ++ show (unwords (exec:opts))
case smtFile config of
Nothing -> return ()
Just f -> do msg $ "Saving the generated script in file: " ++ show f
writeFile f (scriptBody script)
contents <- timeIf isTiming nmSolver $ pipeProcess config exec opts script cleanErrs
msg $ nmSolver ++ " output:\n" ++ either id (intercalate "\n") contents
case contents of
Left e -> return $ failure (lines e)
Right xs -> return $ success (mergeSExpr xs)
-- | A variant of 'readProcessWithExitCode'; except it knows about continuation strings
-- and can speak SMT-Lib2 (just a little).
runSolver :: SMTConfig -> FilePath -> [String] -> SMTScript -> IO (ExitCode, String, String)
runSolver cfg execPath opts script
= do (send, ask, cleanUp, pid) <- do
(inh, outh, errh, pid) <- runInteractiveProcess execPath opts Nothing Nothing
let send l = hPutStr inh (l ++ "\n") >> hFlush inh
recv = hGetLine outh
ask l = send l >> recv
cleanUp response
= do hClose inh
outMVar <- newEmptyMVar
out <- hGetContents outh
_ <- forkIO $ C.evaluate (length out) >> putMVar outMVar ()
err <- hGetContents errh
_ <- forkIO $ C.evaluate (length err) >> putMVar outMVar ()
takeMVar outMVar
takeMVar outMVar
hClose outh
hClose errh
ex <- waitForProcess pid
return $ case response of
Nothing -> (ex, out, err)
Just (r, vals) -> -- if the status is unknown, prepare for the possibility of not having a model
-- TBD: This is rather crude and potentially Z3 specific
let finalOut = intercalate "\n" (r : vals)
in if "unknown" `isPrefixOf` r && "error" `isInfixOf` (out ++ err)
then (ExitSuccess, finalOut , "")
else (ex, finalOut ++ "\n" ++ out, err)
return (send, ask, cleanUp, pid)
let executeSolver = do mapM_ send (lines (scriptBody script))
response <- case scriptModel script of
Nothing -> do send $ satCmd cfg
return Nothing
Just ls -> do r <- ask $ satCmd cfg
vals <- if any (`isPrefixOf` r) ["sat", "unknown"]
then do let mls = lines ls
when (verbose cfg) $ do putStrLn "** Sending the following model extraction commands:"
mapM_ putStrLn mls
mapM ask mls
else return []
return $ Just (r, vals)
cleanUp response
executeSolver `C.onException` terminateProcess pid
-- | In case the SMT-Lib solver returns a response over multiple lines, compress them so we have
-- each S-Expression spanning only a single line. We'll ignore things line parentheses inside quotes
-- etc., as it should not be an issue
mergeSExpr :: [String] -> [String]
mergeSExpr [] = []
mergeSExpr (x:xs)
| d == 0 = x : mergeSExpr xs
| True = let (f, r) = grab d xs in unwords (x:f) : mergeSExpr r
where d = parenDiff x
parenDiff :: String -> Int
parenDiff = go 0
where go i "" = i
go i ('(':cs) = let i'= i+1 in i' `seq` go i' cs
go i (')':cs) = let i'= i-1 in i' `seq` go i' cs
go i (_ :cs) = go i cs
grab i ls
| i <= 0 = ([], ls)
grab _ [] = ([], [])
grab i (l:ls) = let (a, b) = grab (i+parenDiff l) ls in (l:a, b)

120
sbv/Data/SBV/SMT/SMTLib.hs
View File

@ -1,120 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.SMT.SMTLib
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Conversion of symbolic programs to SMTLib format
-----------------------------------------------------------------------------
module Data.SBV.SMT.SMTLib(SMTLibPgm, SMTLibConverter, toSMTLib1, toSMTLib2, addNonEqConstraints, interpretSolverOutput, interpretSolverModelLine) where
import Data.Char (isDigit)
import Data.SBV.BitVectors.Data
import Data.SBV.Provers.SExpr
import qualified Data.SBV.SMT.SMTLib1 as SMT1
import qualified Data.SBV.SMT.SMTLib2 as SMT2
import qualified Data.Set as Set (Set, member, toList)
-- | An instance of SMT-Lib converter; instantiated for SMT-Lib v1 and v2. (And potentially for newer versions in the future.)
type SMTLibConverter = RoundingMode -- ^ User selected rounding mode to be used for floating point arithmetic
-> Maybe Logic -- ^ User selected logic to use. If Nothing, pick automatically.
-> SolverCapabilities -- ^ Capabilities of the backend solver targeted
-> Set.Set Kind -- ^ Kinds used in the problem
-> Bool -- ^ is this a sat problem?
-> [String] -- ^ extra comments to place on top
-> [(Quantifier, NamedSymVar)] -- ^ inputs and aliasing names
-> [Either SW (SW, [SW])] -- ^ skolemized inputs
-> [(SW, CW)] -- ^ constants
-> [((Int, Kind, Kind), [SW])] -- ^ auto-generated tables
-> [(Int, ArrayInfo)] -- ^ user specified arrays
-> [(String, SBVType)] -- ^ uninterpreted functions/constants
-> [(String, [String])] -- ^ user given axioms
-> SBVPgm -- ^ assignments
-> [SW] -- ^ extra constraints
-> SW -- ^ output variable
-> SMTLibPgm
-- | Convert to SMTLib-1 format
toSMTLib1 :: SMTLibConverter
-- | Convert to SMTLib-2 format
toSMTLib2 :: SMTLibConverter
(toSMTLib1, toSMTLib2) = (cvt SMTLib1, cvt SMTLib2)
where cvt v roundMode smtLogic solverCaps kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out
| KUnbounded `Set.member` kindInfo && not (supportsUnboundedInts solverCaps)
= unsupported "unbounded integers"
| KReal `Set.member` kindInfo && not (supportsReals solverCaps)
= unsupported "algebraic reals"
| needsFloats && not (supportsFloats solverCaps)
= unsupported "single-precision floating-point numbers"
| needsDoubles && not (supportsDoubles solverCaps)
= unsupported "double-precision floating-point numbers"
| needsQuantifiers && not (supportsQuantifiers solverCaps)
= unsupported "quantifiers"
| not (null sorts) && not (supportsUninterpretedSorts solverCaps)
= unsupported "uninterpreted sorts"
| True
= SMTLibPgm v (aliasTable, pre, post)
where sorts = [s | KUninterpreted s <- Set.toList kindInfo]
unsupported w = error $ "SBV: Given problem needs " ++ w ++ ", which is not supported by SBV for the chosen solver: " ++ capSolverName solverCaps
aliasTable = map (\(_, (x, y)) -> (y, x)) qinps
converter = if v == SMTLib1 then SMT1.cvt else SMT2.cvt
(pre, post) = converter roundMode smtLogic solverCaps kindInfo isSat comments qinps skolemMap consts tbls arrs uis axs asgnsSeq cstrs out
needsFloats = KFloat `Set.member` kindInfo
needsDoubles = KDouble `Set.member` kindInfo
needsQuantifiers
| isSat = ALL `elem` quantifiers
| True = EX `elem` quantifiers
where quantifiers = map fst qinps
-- | Add constraints generated from older models, used for querying new models
addNonEqConstraints :: RoundingMode -> [(Quantifier, NamedSymVar)] -> [[(String, CW)]] -> SMTLibPgm -> Maybe String
addNonEqConstraints rm _qinps cs p@(SMTLibPgm SMTLib1 _) = SMT1.addNonEqConstraints rm cs p
addNonEqConstraints rm qinps cs p@(SMTLibPgm SMTLib2 _) = SMT2.addNonEqConstraints rm qinps cs p
-- | Interpret solver output based on SMT-Lib standard output responses
interpretSolverOutput :: SMTConfig -> ([String] -> SMTModel) -> [String] -> SMTResult
interpretSolverOutput cfg _ ("unsat":_) = Unsatisfiable cfg
interpretSolverOutput cfg extractMap ("unknown":rest) = Unknown cfg $ extractMap rest
interpretSolverOutput cfg extractMap ("sat":rest) = Satisfiable cfg $ extractMap rest
interpretSolverOutput cfg _ ("timeout":_) = TimeOut cfg
interpretSolverOutput cfg _ ls = ProofError cfg ls
-- | Get a counter-example from an SMT-Lib2 like model output line
-- This routing is necessarily fragile as SMT solvers tend to print output
-- in whatever form they deem convenient for them.. Currently, it's tuned to
-- work with Z3 and CVC4; if new solvers are added, we might need to rework
-- the logic here.
interpretSolverModelLine :: [NamedSymVar] -> String -> [(Int, (String, CW))]
interpretSolverModelLine inps line = either err extract (parseSExpr line)
where err r = error $ "*** Failed to parse SMT-Lib2 model output from: "
++ "*** " ++ show line ++ "\n"
++ "*** Reason: " ++ r ++ "\n"
getInput (ECon v) = isInput v
getInput (EApp (ECon v : _)) = isInput v
getInput _ = Nothing
isInput ('s':v)
| all isDigit v = let inpId :: Int
inpId = read v
in case [(s, nm) | (s@(SW _ (NodeId n)), nm) <- inps, n == inpId] of
[] -> Nothing
[(s, nm)] -> Just (inpId, s, nm)
matches -> error $ "SBV.SMTLib2: Cannot uniquely identify value for "
++ 's':v ++ " in " ++ show matches
isInput _ = Nothing
extract (EApp [EApp [v, ENum i]]) | Just (n, s, nm) <- getInput v = [(n, (nm, mkConstCW (kindOf s) i))]
extract (EApp [EApp [v, EReal i]]) | Just (n, s, nm) <- getInput v, isReal s = [(n, (nm, CW KReal (CWAlgReal i)))]
extract (EApp [EApp [v, ECon i]]) | Just (n, s, nm) <- getInput v, isUninterpreted s = [(n, (nm, CW (kindOf s) (CWUninterpreted i)))]
extract (EApp [EApp [v, EDouble i]]) | Just (n, s, nm) <- getInput v, isDouble s = [(n, (nm, CW KDouble (CWDouble i)))]
extract (EApp [EApp [v, EFloat i]]) | Just (n, s, nm) <- getInput v, isFloat s = [(n, (nm, CW KFloat (CWFloat i)))]
-- weird lambda app that CVC4 seems to throw out.. logic below derived from what I saw CVC4 print, hopefully sufficient
extract (EApp (EApp (v : EApp (ECon "LAMBDA" : xs) : _) : _)) | Just{} <- getInput v, not (null xs) = extract (EApp [EApp [v, last xs]])
extract (EApp [EApp (v : r)]) | Just (_, _, nm) <- getInput v = error $ "SBV.SMTLib2: Cannot extract value for " ++ show nm
++ "\n\tInput: " ++ show line
++ "\n\tParse: " ++ show r
extract _ = []

272
sbv/Data/SBV/SMT/SMTLib1.hs
View File

@ -1,272 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.SMT.SMTLib1
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Conversion of symbolic programs to SMTLib format, Using v1 of the standard
-----------------------------------------------------------------------------
{-# LANGUAGE PatternGuards #-}
module Data.SBV.SMT.SMTLib1(cvt, addNonEqConstraints) where
import qualified Data.Foldable as F (toList)
import qualified Data.Set as Set
import Data.List (intercalate)
import Data.SBV.BitVectors.Data
-- | Add constraints to generate /new/ models. This function is used to query the SMT-solver, while
-- disallowing a previous model.
addNonEqConstraints :: RoundingMode -> [[(String, CW)]] -> SMTLibPgm -> Maybe String
addNonEqConstraints _rm nonEqConstraints (SMTLibPgm _ (aliasTable, pre, post)) = Just $ intercalate "\n" $
pre
++ [ " ; --- refuted-models ---" ]
++ concatMap nonEqs (map (map intName) nonEqConstraints)
++ post
where intName (s, c)
| Just sw <- s `lookup` aliasTable = (show sw, c)
| True = (s, c)
nonEqs :: [(String, CW)] -> [String]
nonEqs [] = []
nonEqs [sc] = [" :assumption " ++ nonEq sc]
nonEqs (sc:r) = [" :assumption (or " ++ nonEq sc]
++ map ((" " ++) . nonEq) r
++ [" )"]
nonEq :: (String, CW) -> String
nonEq (s, c) = "(not (= " ++ s ++ " " ++ cvtCW c ++ "))"
-- | Translate a problem into an SMTLib1 script
cvt :: RoundingMode -- ^ User selected rounding mode to be used for floating point arithmetic
-> Maybe Logic -- ^ SMT-Lib logic, if requested by the user
-> SolverCapabilities -- ^ capabilities of the current solver
-> Set.Set Kind -- ^ kinds used
-> Bool -- ^ is this a sat problem?
-> [String] -- ^ extra comments to place on top
-> [(Quantifier, NamedSymVar)] -- ^ inputs
-> [Either SW (SW, [SW])] -- ^ skolemized version of the inputs
-> [(SW, CW)] -- ^ constants
-> [((Int, Kind, Kind), [SW])] -- ^ auto-generated tables
-> [(Int, ArrayInfo)] -- ^ user specified arrays
-> [(String, SBVType)] -- ^ uninterpreted functions/constants
-> [(String, [String])] -- ^ user given axioms
-> SBVPgm -- ^ assignments
-> [SW] -- ^ extra constraints
-> SW -- ^ output variable
-> ([String], [String])
cvt _roundingMode smtLogic _solverCaps _kindInfo isSat comments qinps _skolemInps consts tbls arrs uis axs asgnsSeq cstrs out = (pre, post)
where logic
| Just l <- smtLogic = show l
| null tbls && null arrs && null uis = "QF_BV"
| True = "QF_AUFBV"
inps = map (fst . snd) qinps
pre = [ "; Automatically generated by SBV. Do not edit." ]
++ map ("; " ++) comments
++ ["(benchmark sbv"
, " :logic " ++ logic
, " :status unknown"
, " ; --- inputs ---"
]
++ map decl inps
++ [ " ; --- declarations ---" ]
++ map (decl . fst) consts
++ map (decl . fst) asgns
++ [ " ; --- constants ---" ]
++ map cvtCnst consts
++ [ " ; --- tables ---" ]
++ concatMap mkTable tbls
++ [ " ; --- arrays ---" ]
++ concatMap declArray arrs
++ [ " ; --- uninterpreted constants ---" ]
++ concatMap declUI uis
++ [ " ; --- user given axioms ---" ]
++ map declAx axs
++ [ " ; --- assignments ---" ]
++ map cvtAsgn asgns
post = [ " ; --- constraints ---" ]
++ map mkCstr cstrs
++ [ " ; --- formula ---" ]
++ [mkFormula isSat out]
++ [")"]
asgns = F.toList (pgmAssignments asgnsSeq)
mkCstr s = " :assumption " ++ show s
-- TODO: Does this work for SMT-Lib when the index/element types are signed?
-- Currently we ignore the signedness of the arguments, as there appears to be no way
-- to capture that in SMT-Lib; and likely it does not matter. Would be good to check
-- explicitly though.
mkTable :: ((Int, Kind, Kind), [SW]) -> [String]
mkTable ((i, ak, rk), elts) = (" :extrafuns ((" ++ t ++ " Array[" ++ show at ++ ":" ++ show rt ++ "]))") : zipWith mkElt elts [(0::Int)..]
where t = "table" ++ show i
mkElt x k = " :assumption (= (select " ++ t ++ " bv" ++ show k ++ "[" ++ show at ++ "]) " ++ show x ++ ")"
(at, rt) = case (ak, rk) of
(KBounded _ a, KBounded _ b) -> (a, b)
_ -> die $ "mkTable: Unbounded table component: " ++ show (ak, rk)
-- Unexpected input, or things we will probably never support
die :: String -> a
die msg = error $ "SBV->SMTLib1: Unexpected: " ++ msg
declArray :: (Int, ArrayInfo) -> [String]
declArray (i, (_, (ak, rk), ctx)) = adecl : ctxInfo
where nm = "array_" ++ show i
adecl = " :extrafuns ((" ++ nm ++ " Array[" ++ show at ++ ":" ++ show rt ++ "]))"
(at, rt) = case (ak, rk) of
(KBounded _ a, KBounded _ b) -> (a, b)
_ -> die $ "declArray: Unbounded array component: " ++ show (ak, rk)
ctxInfo = case ctx of
ArrayFree Nothing -> []
ArrayFree (Just sw) -> declA sw
ArrayReset _ sw -> declA sw
ArrayMutate j a b -> [" :assumption (= " ++ nm ++ " (store array_" ++ show j ++ " " ++ show a ++ " " ++ show b ++ "))"]
ArrayMerge t j k -> [" :assumption (= " ++ nm ++ " (ite " ++ show t ++ " array_" ++ show j ++ " array_" ++ show k ++ "))"]
declA sw = let iv = nm ++ "_freeInitializer"
in [ " :extrafuns ((" ++ iv ++ " " ++ kindType ak ++ "))"
, " :assumption (= (select " ++ nm ++ " " ++ iv ++ ") " ++ show sw ++ ")"
]
declAx :: (String, [String]) -> String
declAx (nm, ls) = (" ;; -- user given axiom: " ++ nm ++ "\n ") ++ intercalate "\n " ls
declUI :: (String, SBVType) -> [String]
declUI (i, t) = [" :extrafuns ((uninterpreted_" ++ i ++ " " ++ cvtType t ++ "))"]
mkFormula :: Bool -> SW -> String
mkFormula isSat s
| isSat = " :formula " ++ show s
| True = " :formula (not " ++ show s ++ ")"
-- SMTLib represents signed/unsigned quantities with the same type
decl :: SW -> String
decl s
| isBoolean s = " :extrapreds ((" ++ show s ++ "))"
| True = " :extrafuns ((" ++ show s ++ " " ++ kindType (kindOf s) ++ "))"
cvtAsgn :: (SW, SBVExpr) -> String
cvtAsgn (s, e) = " :assumption (= " ++ show s ++ " " ++ cvtExp e ++ ")"
cvtCnst :: (SW, CW) -> String
cvtCnst (s, c) = " :assumption (= " ++ show s ++ " " ++ cvtCW c ++ ")"
-- no need to worry about Int/Real here as we don't support them with the SMTLib1 interface..
cvtCW :: CW -> String
cvtCW (CW KBool (CWInteger v)) = if v == 0 then "false" else "true"
cvtCW x@(CW _ (CWInteger v)) | not (hasSign x) = "bv" ++ show v ++ "[" ++ show (intSizeOf x) ++ "]"
-- signed numbers (with 2's complement representation) is problematic
-- since there's no way to put a bvneg over a positive number to get minBound..
-- Hence, we punt and use binary notation in that particular case
cvtCW x@(CW _ (CWInteger v)) | v == least = mkMinBound (intSizeOf x)
where least = negate (2 ^ intSizeOf x)
cvtCW x@(CW _ (CWInteger v)) = negIf (v < 0) $ "bv" ++ show (abs v) ++ "[" ++ show (intSizeOf x) ++ "]"
cvtCW x = error $ "SBV.SMTLib1.cvtCW: Unexpected CW: " ++ show x -- unbounded/real, shouldn't reach here
negIf :: Bool -> String -> String
negIf True a = "(bvneg " ++ a ++ ")"
negIf False a = a
-- anamoly at the 2's complement min value! Have to use binary notation here
-- as there is no positive value we can provide to make the bvneg work.. (see above)
mkMinBound :: Int -> String
mkMinBound i = "bv1" ++ replicate (i-1) '0' ++ "[" ++ show i ++ "]"
rot :: String -> Int -> SW -> String
rot o c x = "(" ++ o ++ "[" ++ show c ++ "] " ++ show x ++ ")"
-- only used for bounded SWs
shft :: String -> String -> Int -> SW -> String
shft oW oS c x = "(" ++ o ++ " " ++ show x ++ " " ++ cvtCW c' ++ ")"
where s = hasSign x
c' = mkConstCW (kindOf x) c
o = if s then oS else oW
cvtExp :: SBVExpr -> String
cvtExp (SBVApp Ite [a, b, c]) = "(ite " ++ show a ++ " " ++ show b ++ " " ++ show c ++ ")"
cvtExp (SBVApp (Rol i) [a]) = rot "rotate_left" i a
cvtExp (SBVApp (Ror i) [a]) = rot "rotate_right" i a
cvtExp (SBVApp (Shl i) [a]) = shft "bvshl" "bvshl" i a
cvtExp (SBVApp (Shr i) [a]) = shft "bvlshr" "bvashr" i a
cvtExp (SBVApp (LkUp (t, ak, _, l) i e) [])
| needsCheck = "(ite " ++ cond ++ show e ++ " " ++ lkUp ++ ")"
| True = lkUp
where at = case ak of
KBounded _ n -> n
_ -> die $ "cvtExp: Unbounded lookup component" ++ show ak
needsCheck = (2::Integer)^at > fromIntegral l
lkUp = "(select table" ++ show t ++ " " ++ show i ++ ")"
cond
| hasSign i = "(or " ++ le0 ++ " " ++ gtl ++ ") "
| True = gtl ++ " "
(less, leq) = if hasSign i then ("bvslt", "bvsle") else ("bvult", "bvule")
mkCnst = cvtCW . mkConstCW (kindOf i)
le0 = "(" ++ less ++ " " ++ show i ++ " " ++ mkCnst 0 ++ ")"
gtl = "(" ++ leq ++ " " ++ mkCnst l ++ " " ++ show i ++ ")"
cvtExp (SBVApp (Extract i j) [a]) = "(extract[" ++ show i ++ ":" ++ show j ++ "] " ++ show a ++ ")"
cvtExp (SBVApp (ArrEq i j) []) = "(= array_" ++ show i ++ " array_" ++ show j ++")"
cvtExp (SBVApp (ArrRead i) [a]) = "(select array_" ++ show i ++ " " ++ show a ++ ")"
cvtExp (SBVApp (Uninterpreted nm) []) = "uninterpreted_" ++ nm
cvtExp (SBVApp (Uninterpreted nm) args) = "(uninterpreted_" ++ nm ++ " " ++ unwords (map show args) ++ ")"
cvtExp inp@(SBVApp op args)
| Just f <- lookup op smtOpTable
= f (any hasSign args) (all isBoolean args) (map show args)
| True
= error $ "SBV.SMT.SMTLib1.cvtExp: impossible happened; can't translate: " ++ show inp
where lift2 o _ _ [x, y] = "(" ++ o ++ " " ++ x ++ " " ++ y ++ ")"
lift2 o _ _ sbvs = error $ "SBV.SMTLib1.cvtExp.lift2: Unexpected arguments: " ++ show (o, sbvs)
lift2S oU oS sgn isB sbvs
| sgn
= lift2 oS sgn isB sbvs
| True
= lift2 oU sgn isB sbvs
lift1 o _ _ [x] = "(" ++ o ++ " " ++ x ++ ")"
lift1 o _ _ sbvs = error $ "SBV.SMT.SMTLib1.cvtExp.lift1: Unexpected arguments: " ++ show (o, sbvs)
-- ops that distinguish 1-bit bitvectors (boolean) from others
lift2B bOp vOp sgn isB sbvs
| isB
= lift2 bOp sgn isB sbvs
| True
= lift2 vOp sgn isB sbvs
lift1B bOp vOp sgn isB sbvs
| isB
= lift1 bOp sgn isB sbvs
| True
= lift1 vOp sgn isB sbvs
eq sgn isB sbvs
| isB
= lift2 "=" sgn isB sbvs
| True
= "(= " ++ lift2 "bvcomp" sgn isB sbvs ++ " bv1[1])"
neq sgn isB sbvs = "(not " ++ eq sgn isB sbvs ++ ")"
smtOpTable = [ (Plus, lift2 "bvadd")
, (Minus, lift2 "bvsub")
, (Times, lift2 "bvmul")
, (Quot, lift2S "bvudiv" "bvsdiv")
, (Rem, lift2S "bvurem" "bvsrem")
, (Equal, eq)
, (NotEqual, neq)
, (LessThan, lift2S "bvult" "bvslt")
, (GreaterThan, lift2S "bvugt" "bvsgt")
, (LessEq, lift2S "bvule" "bvsle")
, (GreaterEq, lift2S "bvuge" "bvsge")
, (And, lift2B "and" "bvand")
, (Or, lift2B "or" "bvor")
, (Not, lift1B "not" "bvnot")
, (XOr, lift2B "xor" "bvxor")
, (Join, lift2 "concat")
]
cvtType :: SBVType -> String
cvtType (SBVType []) = error "SBV.SMT.SMTLib1.cvtType: internal: received an empty type!"
cvtType (SBVType xs) = unwords $ map kindType xs
kindType :: Kind -> String
kindType KBool = "Bool"
kindType (KBounded _ s) = "BitVec[" ++ show s ++ "]"
kindType KUnbounded = die "unbounded Integer"
kindType KReal = die "real value"
kindType KFloat = die "float value"
kindType KDouble = die "double value"
kindType (KUninterpreted s) = die $ "uninterpreted sort: " ++ s

498
sbv/Data/SBV/SMT/SMTLib2.hs
View File

@ -1,498 +0,0 @@
----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.SMT.SMTLib2
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Conversion of symbolic programs to SMTLib format, Using v2 of the standard
-----------------------------------------------------------------------------
{-# LANGUAGE PatternGuards #-}
module Data.SBV.SMT.SMTLib2(cvt, addNonEqConstraints) where
import Data.Bits (bit)
import Data.Char (intToDigit)
import Data.Function (on)
import Data.Ord (comparing)
import qualified Data.Foldable as F (toList)
import qualified Data.Map as M
import qualified Data.IntMap as IM
import qualified Data.Set as Set
import Data.List (intercalate, partition, groupBy, sortBy)
import Numeric (showIntAtBase, showHex)
import Data.SBV.BitVectors.AlgReals
import Data.SBV.BitVectors.Data
import Data.SBV.BitVectors.PrettyNum (showSMTFloat, showSMTDouble, smtRoundingMode)
-- | Add constraints to generate /new/ models. This function is used to query the SMT-solver, while
-- disallowing a previous model.
addNonEqConstraints :: RoundingMode -> [(Quantifier, NamedSymVar)] -> [[(String, CW)]] -> SMTLibPgm -> Maybe String
addNonEqConstraints rm qinps allNonEqConstraints (SMTLibPgm _ (aliasTable, pre, post))
| null allNonEqConstraints
= Just $ intercalate "\n" $ pre ++ post
| null refutedModel
= Nothing
| True
= Just $ intercalate "\n" $ pre
++ [ "; --- refuted-models ---" ]
++ refutedModel
++ post
where refutedModel = concatMap (nonEqs rm) (map (map intName) nonEqConstraints)
intName (s, c)
| Just sw <- s `lookup` aliasTable = (show sw, c)
| True = (s, c)
-- with existentials, we only add top-level existentials to the refuted-models list
nonEqConstraints = filter (not . null) $ map (filter (\(s, _) -> s `elem` topUnivs)) allNonEqConstraints
topUnivs = [s | (_, (_, s)) <- takeWhile (\p -> fst p == EX) qinps]
nonEqs :: RoundingMode -> [(String, CW)] -> [String]
nonEqs rm scs = format $ interp ps ++ disallow (map eqClass uninterpClasses)
where (ups, ps) = partition (isUninterpreted . snd) scs
format [] = []
format [m] = ["(assert " ++ m ++ ")"]
format (m:ms) = ["(assert (or " ++ m]
++ map (" " ++) ms
++ [" ))"]
-- Regular (or interpreted) sorts simply get a constraint that we disallow the current assignment
interp = map $ nonEq rm
-- Determine the equivalnce classes of uninterpreted sorts:
uninterpClasses = filter (\l -> length l > 1) -- Only need this class if it has at least two members
. map (map fst) -- throw away sorts, we only need the names
. groupBy ((==) `on` snd) -- make sure they belong to the same sort and have the same value
. sortBy (comparing snd) -- sort them according to their sorts first
$ ups -- take the uninterpreted sorts
-- Uninterpreted sorts get a constraint that says the equivalence classes as determined by the solver are disallowed:
eqClass :: [String] -> String
eqClass [] = error "SBV.allSat.nonEqs: Impossible happened, disallow received an empty list"
eqClass cs = "(= " ++ unwords cs ++ ")"
-- Now, take the conjunction of equivalence classes and assert it's negation:
disallow = map $ \ec -> "(not " ++ ec ++ ")"
nonEq :: RoundingMode -> (String, CW) -> String
nonEq rm (s, c) = "(not (= " ++ s ++ " " ++ cvtCW rm c ++ "))"
tbd :: String -> a
tbd e = error $ "SBV.SMTLib2: Not-yet-supported: " ++ e
-- | Translate a problem into an SMTLib2 script
cvt :: RoundingMode -- ^ User selected rounding mode to be used for floating point arithmetic
-> Maybe Logic -- ^ SMT-Lib logic, if requested by the user
-> SolverCapabilities -- ^ capabilities of the current solver
-> Set.Set Kind -- ^ kinds used
-> Bool -- ^ is this a sat problem?
-> [String] -- ^ extra comments to place on top
-> [(Quantifier, NamedSymVar)] -- ^ inputs
-> [Either SW (SW, [SW])] -- ^ skolemized version inputs
-> [(SW, CW)] -- ^ constants
-> [((Int, Kind, Kind), [SW])] -- ^ auto-generated tables
-> [(Int, ArrayInfo)] -- ^ user specified arrays
-> [(String, SBVType)] -- ^ uninterpreted functions/constants
-> [(String, [String])] -- ^ user given axioms
-> SBVPgm -- ^ assignments
-> [SW] -- ^ extra constraints
-> SW -- ^ output variable
-> ([String], [String])
cvt rm smtLogic solverCaps kindInfo isSat comments inputs skolemInps consts tbls arrs uis axs (SBVPgm asgnsSeq) cstrs out = (pre, [])
where -- the logic is an over-approaximation
hasInteger = KUnbounded `Set.member` kindInfo
hasReal = KReal `Set.member` kindInfo
hasFloat = KFloat `Set.member` kindInfo
hasDouble = KDouble `Set.member` kindInfo
hasBVs = not $ null [() | KBounded{} <- Set.toList kindInfo]
sorts = [s | KUninterpreted s <- Set.toList kindInfo]
logic
| Just l <- smtLogic
= ["(set-logic " ++ show l ++ ") ; NB. User specified."]
| hasDouble || hasFloat -- NB. We don't check for quantifiers here, we probably should..
= if hasBVs
then ["(set-logic QF_FPABV)"]
else ["(set-logic QF_FPA)"]
| hasInteger || hasReal || not (null sorts)
= case mbDefaultLogic solverCaps of
Nothing -> ["; Has unbounded values (Int/Real) or sorts; no logic specified."] -- combination, let the solver pick
Just l -> ["(set-logic " ++ l ++ ")"]
| True
= ["(set-logic " ++ qs ++ as ++ ufs ++ "BV)"]
where qs | null foralls && null axs = "QF_" -- axioms are likely to contain quantifiers
| True = ""
as | null arrs = ""
| True = "A"
ufs | null uis && null tbls = "" -- we represent tables as UFs
| True = "UF"
getModels
| supportsProduceModels solverCaps = ["(set-option :produce-models true)"]
| True = []
pre = ["; Automatically generated by SBV. Do not edit."]
++ map ("; " ++) comments
++ getModels
++ logic
++ [ "; --- uninterpreted sorts ---" ]
++ map declSort sorts
++ [ "; --- literal constants ---" ]
++ concatMap (declConst (supportsMacros solverCaps)) consts
++ [ "; --- skolem constants ---" ]
++ [ "(declare-fun " ++ show s ++ " " ++ swFunType ss s ++ ")" ++ userName s | Right (s, ss) <- skolemInps]
++ [ "; --- constant tables ---" ]
++ concatMap constTable constTables
++ [ "; --- skolemized tables ---" ]
++ map (skolemTable (unwords (map swType foralls))) skolemTables
++ [ "; --- arrays ---" ]
++ concat arrayConstants
++ [ "; --- uninterpreted constants ---" ]
++ concatMap declUI uis
++ [ "; --- user given axioms ---" ]
++ map declAx axs
++ [ "; --- formula ---" ]
++ [if null foralls
then "(assert ; no quantifiers"
else "(assert (forall (" ++ intercalate "\n "
["(" ++ show s ++ " " ++ swType s ++ ")" | s <- foralls] ++ ")"]
++ map (letAlign . mkLet) asgns
++ map letAlign (if null delayedEqualities then [] else ("(and " ++ deH) : map (align 5) deTs)
++ [ impAlign (letAlign assertOut) ++ replicate noOfCloseParens ')' ]
noOfCloseParens = length asgns + (if null foralls then 1 else 2) + (if null delayedEqualities then 0 else 1)
(constTables, skolemTables) = ([(t, d) | (t, Left d) <- allTables], [(t, d) | (t, Right d) <- allTables])
allTables = [(t, genTableData rm skolemMap (not (null foralls), forallArgs) (map fst consts) t) | t <- tbls]
(arrayConstants, allArrayDelayeds) = unzip $ map (declArray (not (null foralls)) (map fst consts) skolemMap) arrs
delayedEqualities@(~(deH:deTs)) = concatMap snd skolemTables ++ concat allArrayDelayeds
foralls = [s | Left s <- skolemInps]
forallArgs = concatMap ((" " ++) . show) foralls
letAlign s
| null foralls = " " ++ s
| True = " " ++ s
impAlign s
| null delayedEqualities = s
| True = " " ++ s
align n s = replicate n ' ' ++ s
-- if sat, we assert cstrs /\ out
-- if prove, we assert ~(cstrs => out) = cstrs /\ not out
assertOut
| null cstrs = o
| True = "(and " ++ unwords (map mkConj cstrs ++ [o]) ++ ")"
where mkConj = cvtSW skolemMap
o | isSat = mkConj out
| True = "(not " ++ mkConj out ++ ")"
skolemMap = M.fromList [(s, ss) | Right (s, ss) <- skolemInps, not (null ss)]
tableMap = IM.fromList $ map mkConstTable constTables ++ map mkSkTable skolemTables
where mkConstTable (((t, _, _), _), _) = (t, "table" ++ show t)
mkSkTable (((t, _, _), _), _) = (t, "table" ++ show t ++ forallArgs)
asgns = F.toList asgnsSeq
mkLet (s, e) = "(let ((" ++ show s ++ " " ++ cvtExp rm skolemMap tableMap e ++ "))"
declConst useDefFun (s, c)
| useDefFun = ["(define-fun " ++ varT ++ " " ++ cvtCW rm c ++ ")"]
| True = [ "(declare-fun " ++ varT ++ ")"
, "(assert (= " ++ show s ++ " " ++ cvtCW rm c ++ "))"
]
where varT = show s ++ " " ++ swFunType [] s
declSort s = "(declare-sort " ++ s ++ " 0)"
userName s = case s `lookup` map snd inputs of
Just u | show s /= u -> " ; tracks user variable " ++ show u
_ -> ""
declUI :: (String, SBVType) -> [String]
declUI (i, t) = ["(declare-fun " ++ i ++ " " ++ cvtType t ++ ")"]
-- NB. We perform no check to as to whether the axiom is meaningful in any way.
declAx :: (String, [String]) -> String
declAx (nm, ls) = (";; -- user given axiom: " ++ nm ++ "\n") ++ intercalate "\n" ls
constTable :: (((Int, Kind, Kind), [SW]), [String]) -> [String]
constTable (((i, ak, rk), _elts), is) = decl : map wrap is
where t = "table" ++ show i
decl = "(declare-fun " ++ t ++ " (" ++ smtType ak ++ ") " ++ smtType rk ++ ")"
wrap s = "(assert " ++ s ++ ")"
skolemTable :: String -> (((Int, Kind, Kind), [SW]), [String]) -> String
skolemTable qsIn (((i, ak, rk), _elts), _) = decl
where qs = if null qsIn then "" else qsIn ++ " "
t = "table" ++ show i
decl = "(declare-fun " ++ t ++ " (" ++ qs ++ smtType ak ++ ") " ++ smtType rk ++ ")"
-- Left if all constants, Right if otherwise
genTableData :: RoundingMode -> SkolemMap -> (Bool, String) -> [SW] -> ((Int, Kind, Kind), [SW]) -> Either [String] [String]
genTableData rm skolemMap (_quantified, args) consts ((i, aknd, _), elts)
| null post = Left (map (topLevel . snd) pre)
| True = Right (map (nested . snd) (pre ++ post))
where ssw = cvtSW skolemMap
(pre, post) = partition fst (zipWith mkElt elts [(0::Int)..])
t = "table" ++ show i
mkElt x k = (isReady, (idx, ssw x))
where idx = cvtCW rm (mkConstCW aknd k)
isReady = x `elem` consts
topLevel (idx, v) = "(= (" ++ t ++ " " ++ idx ++ ") " ++ v ++ ")"
nested (idx, v) = "(= (" ++ t ++ args ++ " " ++ idx ++ ") " ++ v ++ ")"
-- TODO: We currently do not support non-constant arrays when quantifiers are present, as
-- we might have to skolemize those. Implement this properly.
-- The difficulty is with the ArrayReset/Mutate/Merge: We have to postpone an init if
-- the components are themselves postponed, so this cannot be implemented as a simple map.
declArray :: Bool -> [SW] -> SkolemMap -> (Int, ArrayInfo) -> ([String], [String])
declArray quantified consts skolemMap (i, (_, (aKnd, bKnd), ctx)) = (adecl : map wrap pre, map snd post)
where topLevel = not quantified || case ctx of
ArrayFree Nothing -> True
ArrayFree (Just sw) -> sw `elem` consts
ArrayReset _ sw -> sw `elem` consts
ArrayMutate _ a b -> all (`elem` consts) [a, b]
ArrayMerge c _ _ -> c `elem` consts
(pre, post) = partition fst ctxInfo
nm = "array_" ++ show i
ssw sw
| topLevel || sw `elem` consts
= cvtSW skolemMap sw
| True
= tbd "Non-constant array initializer in a quantified context"
adecl = "(declare-fun " ++ nm ++ " () (Array " ++ smtType aKnd ++ " " ++ smtType bKnd ++ "))"
ctxInfo = case ctx of
ArrayFree Nothing -> []
ArrayFree (Just sw) -> declA sw
ArrayReset _ sw -> declA sw
ArrayMutate j a b -> [(all (`elem` consts) [a, b], "(= " ++ nm ++ " (store array_" ++ show j ++ " " ++ ssw a ++ " " ++ ssw b ++ "))")]
ArrayMerge t j k -> [(t `elem` consts, "(= " ++ nm ++ " (ite " ++ ssw t ++ " array_" ++ show j ++ " array_" ++ show k ++ "))")]
declA sw = let iv = nm ++ "_freeInitializer"
in [ (True, "(declare-fun " ++ iv ++ " () " ++ smtType aKnd ++ ")")
, (sw `elem` consts, "(= (select " ++ nm ++ " " ++ iv ++ ") " ++ ssw sw ++ ")")
]
wrap (False, s) = s
wrap (True, s) = "(assert " ++ s ++ ")"
swType :: SW -> String
swType s = smtType (kindOf s)
swFunType :: [SW] -> SW -> String
swFunType ss s = "(" ++ unwords (map swType ss) ++ ") " ++ swType s
smtType :: Kind -> String
smtType KBool = "Bool"
smtType (KBounded _ sz) = "(_ BitVec " ++ show sz ++ ")"
smtType KUnbounded = "Int"
smtType KReal = "Real"
smtType KFloat = "(_ FP 8 24)"
smtType KDouble = "(_ FP 11 53)"
smtType (KUninterpreted s) = s
cvtType :: SBVType -> String
cvtType (SBVType []) = error "SBV.SMT.SMTLib2.cvtType: internal: received an empty type!"
cvtType (SBVType xs) = "(" ++ unwords (map smtType body) ++ ") " ++ smtType ret
where (body, ret) = (init xs, last xs)
type SkolemMap = M.Map SW [SW]
type TableMap = IM.IntMap String
cvtSW :: SkolemMap -> SW -> String
cvtSW skolemMap s
| Just ss <- s `M.lookup` skolemMap
= "(" ++ show s ++ concatMap ((" " ++) . show) ss ++ ")"
| True
= show s
-- Carefully code hex numbers, SMTLib is picky about lengths of hex constants. For the time
-- being, SBV only supports sizes that are multiples of 4, but the below code is more robust
-- in case of future extensions to support arbitrary sizes.
hex :: Int -> Integer -> String
hex 1 v = "#b" ++ show v
hex sz v
| sz `mod` 4 == 0 = "#x" ++ pad (sz `div` 4) (showHex v "")
| True = "#b" ++ pad sz (showBin v "")
where pad n s = replicate (n - length s) '0' ++ s
showBin = showIntAtBase 2 intToDigit
cvtCW :: RoundingMode -> CW -> String
cvtCW rm x
| isBoolean x, CWInteger w <- cwVal x = if w == 0 then "false" else "true"
| isUninterpreted x, CWUninterpreted s <- cwVal x = s
| isReal x, CWAlgReal r <- cwVal x = algRealToSMTLib2 r
| isFloat x, CWFloat f <- cwVal x = showSMTFloat rm f
| isDouble x, CWDouble d <- cwVal x = showSMTDouble rm d
| not (isBounded x), CWInteger w <- cwVal x = if w >= 0 then show w else "(- " ++ show (abs w) ++ ")"
| not (hasSign x) , CWInteger w <- cwVal x = hex (intSizeOf x) w
-- signed numbers (with 2's complement representation) is problematic
-- since there's no way to put a bvneg over a positive number to get minBound..
-- Hence, we punt and use binary notation in that particular case
| hasSign x , CWInteger w <- cwVal x = if w == negate (2 ^ intSizeOf x)
then mkMinBound (intSizeOf x)
else negIf (w < 0) $ hex (intSizeOf x) (abs w)
| True = error $ "SBV.cvtCW: Impossible happened: Kind/Value disagreement on: " ++ show (kindOf x, x)
negIf :: Bool -> String -> String
negIf True a = "(bvneg " ++ a ++ ")"
negIf False a = a
-- anamoly at the 2's complement min value! Have to use binary notation here
-- as there is no positive value we can provide to make the bvneg work.. (see above)
mkMinBound :: Int -> String
mkMinBound i = "#b1" ++ replicate (i-1) '0'
getTable :: TableMap -> Int -> String
getTable m i
| Just tn <- i `IM.lookup` m = tn
| True = error $ "SBV.SMTLib2: Cannot locate table " ++ show i
cvtExp :: RoundingMode -> SkolemMap -> TableMap -> SBVExpr -> String
cvtExp rm skolemMap tableMap expr@(SBVApp _ arguments) = sh expr
where ssw = cvtSW skolemMap
bvOp = all isBounded arguments
intOp = any isInteger arguments
realOp = any isReal arguments
doubleOp = any isDouble arguments
floatOp = any isFloat arguments
boolOp = all isBoolean arguments
bad | intOp = error $ "SBV.SMTLib2: Unsupported operation on unbounded integers: " ++ show expr
| True = error $ "SBV.SMTLib2: Unsupported operation on real values: " ++ show expr
ensureBVOrBool = bvOp || boolOp || bad
ensureBV = bvOp || bad
addRM s = s ++ " " ++ smtRoundingMode rm
lift2 o _ [x, y] = "(" ++ o ++ " " ++ x ++ " " ++ y ++ ")"
lift2 o _ sbvs = error $ "SBV.SMTLib2.sh.lift2: Unexpected arguments: " ++ show (o, sbvs)
-- lift a binary operation with rounding-mode added; used for floating-point arithmetic
lift2WM o | doubleOp || floatOp = lift2 (addRM o)
| True = lift2 o
lift2B bOp vOp
| boolOp = lift2 bOp
| True = lift2 vOp
lift1B bOp vOp
| boolOp = lift1 bOp
| True = lift1 vOp
eqBV sgn sbvs
| boolOp = lift2 "=" sgn sbvs
| True = "(= " ++ lift2 "bvcomp" sgn sbvs ++ " #b1)"
neqBV sgn sbvs = "(not " ++ eqBV sgn sbvs ++ ")"
equal sgn sbvs
| doubleOp = lift2 "==" sgn sbvs
| floatOp = lift2 "==" sgn sbvs
| True = lift2 "=" sgn sbvs
notEqual sgn sbvs
| doubleOp = "(not " ++ equal sgn sbvs ++ ")"
| floatOp = "(not " ++ equal sgn sbvs ++ ")"
| True = lift2 "distinct" sgn sbvs
lift2S oU oS sgn = lift2 (if sgn then oS else oU) sgn
lift1 o _ [x] = "(" ++ o ++ " " ++ x ++ ")"
lift1 o _ sbvs = error $ "SBV.SMT.SMTLib2.sh.lift1: Unexpected arguments: " ++ show (o, sbvs)
sh (SBVApp Ite [a, b, c]) = "(ite " ++ ssw a ++ " " ++ ssw b ++ " " ++ ssw c ++ ")"
sh (SBVApp (LkUp (t, aKnd, _, l) i e) [])
| needsCheck = "(ite " ++ cond ++ ssw e ++ " " ++ lkUp ++ ")"
| True = lkUp
where needsCheck = case aKnd of
KBool -> (2::Integer) > fromIntegral l
KBounded _ n -> (2::Integer)^n > fromIntegral l
KUnbounded -> True
KReal -> error "SBV.SMT.SMTLib2.cvtExp: unexpected real valued index"
KFloat -> error "SBV.SMT.SMTLib2.cvtExp: unexpected float valued index"
KDouble -> error "SBV.SMT.SMTLib2.cvtExp: unexpected double valued index"
KUninterpreted s -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected uninterpreted valued index: " ++ s
lkUp = "(" ++ getTable tableMap t ++ " " ++ ssw i ++ ")"
cond
| hasSign i = "(or " ++ le0 ++ " " ++ gtl ++ ") "
| True = gtl ++ " "
(less, leq) = case aKnd of
KBool -> error "SBV.SMT.SMTLib2.cvtExp: unexpected boolean valued index"
KBounded{} -> if hasSign i then ("bvslt", "bvsle") else ("bvult", "bvule")
KUnbounded -> ("<", "<=")
KReal -> ("<", "<=")
KFloat -> ("<", "<=")
KDouble -> ("<", "<=")
KUninterpreted s -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected uninterpreted valued index: " ++ s
mkCnst = cvtCW rm . mkConstCW (kindOf i)
le0 = "(" ++ less ++ " " ++ ssw i ++ " " ++ mkCnst 0 ++ ")"
gtl = "(" ++ leq ++ " " ++ mkCnst l ++ " " ++ ssw i ++ ")"
sh (SBVApp (ArrEq i j) []) = "(= array_" ++ show i ++ " array_" ++ show j ++")"
sh (SBVApp (ArrRead i) [a]) = "(select array_" ++ show i ++ " " ++ ssw a ++ ")"
sh (SBVApp (Uninterpreted nm) []) = nm
sh (SBVApp (Uninterpreted nm) args) = "(" ++ nm' ++ " " ++ unwords (map ssw args) ++ ")"
where -- slight hack needed here to take advantage of custom floating-point functions.. sigh.
fpSpecials = ["squareRoot", "fusedMA"]
nm' | (floatOp || doubleOp) && (nm `elem` fpSpecials) = addRM nm
| True = nm
sh (SBVApp (Extract 0 0) [a]) -- special SInteger -> SReal conversion
| kindOf a == KUnbounded
= "(to_real " ++ ssw a ++ ")"
sh (SBVApp (Extract i j) [a]) | ensureBV = "((_ extract " ++ show i ++ " " ++ show j ++ ") " ++ ssw a ++ ")"
sh (SBVApp (Rol i) [a])
| bvOp = rot ssw "rotate_left" i a
| intOp = sh (SBVApp (Shl i) [a]) -- Haskell treats rotateL as shiftL for unbounded values
| True = bad
sh (SBVApp (Ror i) [a])
| bvOp = rot ssw "rotate_right" i a
| intOp = sh (SBVApp (Shr i) [a]) -- Haskell treats rotateR as shiftR for unbounded values
| True = bad
sh (SBVApp (Shl i) [a])
| bvOp = shft rm ssw "bvshl" "bvshl" i a
| i < 0 = sh (SBVApp (Shr (-i)) [a]) -- flip sign/direction
| intOp = "(* " ++ ssw a ++ " " ++ show (bit i :: Integer) ++ ")" -- Implement shiftL by multiplication by 2^i
| True = bad
sh (SBVApp (Shr i) [a])
| bvOp = shft rm ssw "bvlshr" "bvashr" i a
| i < 0 = sh (SBVApp (Shl (-i)) [a]) -- flip sign/direction
| intOp = "(div " ++ ssw a ++ " " ++ show (bit i :: Integer) ++ ")" -- Implement shiftR by division by 2^i
| True = bad
sh (SBVApp op args)
| Just f <- lookup op smtBVOpTable, ensureBVOrBool
= f (any hasSign args) (map ssw args)
where -- The first 4 operators below do make sense for Integer's in Haskell, but there's
-- no obvious counterpart for them in the SMTLib translation.
-- TODO: provide support for these.
smtBVOpTable = [ (And, lift2B "and" "bvand")
, (Or, lift2B "or" "bvor")
, (XOr, lift2B "xor" "bvxor")
, (Not, lift1B "not" "bvnot")
, (Join, lift2 "concat")
]
sh inp@(SBVApp op args)
| intOp, Just f <- lookup op smtOpIntTable
= f True (map ssw args)
| bvOp, Just f <- lookup op smtOpBVTable
= f (any hasSign args) (map ssw args)
| realOp, Just f <- lookup op smtOpRealTable
= f (any hasSign args) (map ssw args)
| floatOp || doubleOp, Just f <- lookup op smtOpFloatDoubleTable
= f (any hasSign args) (map ssw args)
| Just f <- lookup op uninterpretedTable
= f (map ssw args)
| True
= error $ "SBV.SMT.SMTLib2.cvtExp.sh: impossible happened; can't translate: " ++ show inp
where smtOpBVTable = [ (Plus, lift2 "bvadd")
, (Minus, lift2 "bvsub")
, (Times, lift2 "bvmul")
, (Quot, lift2S "bvudiv" "bvsdiv")
, (Rem, lift2S "bvurem" "bvsrem")
, (Equal, eqBV)
, (NotEqual, neqBV)
, (LessThan, lift2S "bvult" "bvslt")
, (GreaterThan, lift2S "bvugt" "bvsgt")
, (LessEq, lift2S "bvule" "bvsle")
, (GreaterEq, lift2S "bvuge" "bvsge")
]
smtOpRealTable = smtIntRealShared
++ [ (Quot, lift2WM "/")
]
smtOpIntTable = smtIntRealShared
++ [ (Quot, lift2 "div")
, (Rem, lift2 "mod")
]
smtOpFloatDoubleTable = smtIntRealShared
++ [(Quot, lift2WM "/")]
smtIntRealShared = [ (Plus, lift2WM "+")
, (Minus, lift2WM "-")
, (Times, lift2WM "*")
, (Equal, equal)
, (NotEqual, notEqual)
, (LessThan, lift2S "<" "<")
, (GreaterThan, lift2S ">" ">")
, (LessEq, lift2S "<=" "<=")
, (GreaterEq, lift2S ">=" ">=")
]
-- equality is the only thing that works on uninterpreted sorts
uninterpretedTable = [ (Equal, lift2S "=" "=" True)
, (NotEqual, lift2S "distinct" "distinct" True)
]
rot :: (SW -> String) -> String -> Int -> SW -> String
rot ssw o c x = "((_ " ++ o ++ " " ++ show c ++ ") " ++ ssw x ++ ")"
shft :: RoundingMode -> (SW -> String) -> String -> String -> Int -> SW -> String
shft rm ssw oW oS c x = "(" ++ o ++ " " ++ ssw x ++ " " ++ cvtCW rm c' ++ ")"
where s = hasSign x
c' = mkConstCW (kindOf x) c
o = if s then oS else oW

86
sbv/Data/SBV/Tools/ExpectedValue.hs
View File

@ -1,86 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Tools.ExpectedValue
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Computing the expected value of a symbolic variable
-----------------------------------------------------------------------------
{-# LANGUAGE PatternGuards #-}
module Data.SBV.Tools.ExpectedValue (expectedValue, expectedValueWith) where
import Control.DeepSeq (rnf)
import System.Random (newStdGen, StdGen)
import Numeric
import Data.SBV.BitVectors.Data
-- | Generalized version of 'expectedValue', allowing the user to specify the
-- warm-up count and the convergence factor. Maximum iteration count can also
-- be specified, at which point convergence won't be sought. The boolean controls verbosity.
expectedValueWith :: Outputtable a => Bool -> Int -> Maybe Int -> Double -> Symbolic a -> IO [Double]
expectedValueWith chatty warmupCount mbMaxIter epsilon m
| warmupCount < 0 || epsilon < 0
= error $ "SBV.expectedValue: warmup count and epsilon both must be non-negative, received: " ++ show (warmupCount, epsilon)
| True
= warmup warmupCount (repeat 0) >>= go warmupCount
where progress s | not chatty = return ()
| True = putStr $ "\r*** " ++ s
warmup :: Int -> [Integer] -> IO [Integer]
warmup 0 v = do progress $ "Warmup complete, performed " ++ show warmupCount ++ " rounds.\n"
return v
warmup n v = do progress $ "Performing warmup, round: " ++ show (warmupCount - n)
g <- newStdGen
t <- runOnce g
let v' = zipWith (+) v t
rnf v' `seq` warmup (n-1) v'
runOnce :: StdGen -> IO [Integer]
runOnce g = do (_, Result _ _ _ _ cs _ _ _ _ _ cstrs os) <- runSymbolic' (Concrete g) (m >>= output)
let cval o = case o `lookup` cs of
Nothing -> error "SBV.expectedValue: Cannot compute expected-values in the presence of uninterpreted constants!"
Just cw -> case (cwKind cw, cwVal cw) of
(KBool, _) -> if cwToBool cw then 1 else 0
(KBounded{}, CWInteger v) -> v
(KUnbounded, CWInteger v) -> v
(KReal, _) -> error "Cannot compute expected-values for real valued results."
_ -> error $ "SBV.expectedValueWith: Unexpected CW: " ++ show cw
if all ((== 1) . cval) cstrs
then return $ map cval os
else runOnce g -- constraint not satisfied try again with the same set of constraints
go :: Int -> [Integer] -> IO [Double]
go cases curSums
| Just n <- mbMaxIter, n < curRound
= do progress "\n"
progress "Maximum iteration count reached, stopping.\n"
return curEVs
| True
= do g <- newStdGen
t <- runOnce g
let newSums = zipWith (+) curSums t
newEVs = map ev' newSums
diffs = zipWith (\x y -> abs (x - y)) newEVs curEVs
if all (< epsilon) diffs
then do progress $ "Converges with epsilon " ++ show epsilon ++ " after " ++ show curRound ++ " rounds.\n"
return newEVs
else do progress $ "Tuning, round: " ++ show curRound ++ " (margin: " ++ showFFloat (Just 6) (maximum (0:diffs)) "" ++ ")"
go newCases newSums
where curRound = cases - warmupCount
newCases = cases + 1
ev, ev' :: Integer -> Double
ev x = fromIntegral x / fromIntegral cases
ev' x = fromIntegral x / fromIntegral newCases
curEVs = map ev curSums
-- | Given a symbolic computation that produces a value, compute the
-- expected value that value would take if this computation is run
-- with its free variables drawn from uniform distributions of its
-- respective values, satisfying the given constraints specified by
-- 'constrain' and 'pConstrain' calls. This is equivalent to calling
-- 'expectedValueWith' the following parameters: verbose, warm-up
-- round count of @10000@, no maximum iteration count, and with
-- convergence margin @0.0001@.
expectedValue :: Outputtable a => Symbolic a -> IO [Double]
expectedValue = expectedValueWith True 10000 Nothing 0.0001

302
sbv/Data/SBV/Tools/GenTest.hs
View File

@ -1,302 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Tools.GenTest
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Test generation from symbolic programs
-----------------------------------------------------------------------------
module Data.SBV.Tools.GenTest (genTest, TestVectors, getTestValues, renderTest, TestStyle(..)) where
import Data.Bits (testBit)
import Data.Char (isAlpha, toUpper)
import Data.Function (on)
import Data.List (intercalate, groupBy)
import Data.Maybe (fromMaybe)
import System.Random
import Data.SBV.BitVectors.AlgReals
import Data.SBV.BitVectors.Data
import Data.SBV.BitVectors.PrettyNum
-- | Type of test vectors (abstract)
newtype TestVectors = TV [([CW], [CW])]
-- | Retrieve the test vectors for further processing. This function
-- is useful in cases where 'renderTest' is not sufficient and custom
-- output (or further preprocessing) is needed.
getTestValues :: TestVectors -> [([CW], [CW])]
getTestValues (TV vs) = vs
-- | Generate a set of concrete test values from a symbolic program. The output
-- can be rendered as test vectors in different languages as necessary. Use the
-- function 'output' call to indicate what fields should be in the test result.
-- (Also see 'constrain' and 'pConstrain' for filtering acceptable test values.)
genTest :: Outputtable a => Int -> Symbolic a -> IO TestVectors
genTest n m = gen 0 []
where gen i sofar
| i == n = return $ TV $ reverse sofar
| True = do g <- newStdGen
t <- tc g
gen (i+1) (t:sofar)
tc g = do (_, Result _ tvals _ _ cs _ _ _ _ _ cstrs os) <- runSymbolic' (Concrete g) (m >>= output)
let cval = fromMaybe (error "Cannot generate tests in the presence of uninterpeted constants!") . (`lookup` cs)
cond = all (cwToBool . cval) cstrs
if cond
then return (map snd tvals, map cval os)
else tc g -- try again, with the same set of constraints
-- | Test output style
data TestStyle = Haskell String -- ^ As a Haskell value with given name
| C String -- ^ As a C array of structs with given name
| Forte String Bool ([Int], [Int]) -- ^ As a Forte/Verilog value with given name.
-- If the boolean is True then vectors are blasted big-endian, otherwise little-endian
-- The indices are the split points on bit-vectors for input and output values
-- | Render the test as a Haskell value with the given name @n@.
renderTest :: TestStyle -> TestVectors -> String
renderTest (Haskell n) (TV vs) = haskell n vs
renderTest (C n) (TV vs) = c n vs
renderTest (Forte n b ss) (TV vs) = forte n b ss vs
haskell :: String -> [([CW], [CW])] -> String
haskell vname vs = intercalate "\n" $ [ "-- Automatically generated by SBV. Do not edit!"
, ""
, "module " ++ modName ++ "(" ++ n ++ ") where"
, ""
]
++ imports
++ [ n ++ " :: " ++ getType vs
, n ++ " = [ " ++ intercalate ("\n" ++ pad ++ ", ") (map mkLine vs), pad ++ "]"
]
where n | null vname = "testVectors"
| not (isAlpha (head vname)) = "tv" ++ vname
| True = vname
imports
| null vs = []
| needsInt && needsWord = ["import Data.Int", "import Data.Word", ""]
| needsInt = ["import Data.Int", ""]
| needsWord = ["import Data.Word", ""]
| needsRatio = ["import Data.Ratio"]
| True = []
where ((is, os):_) = vs
params = is ++ os
needsInt = any isSW params
needsWord = any isUW params
needsRatio = any isR params
isR cw = case kindOf cw of
KReal -> True
_ -> False
isSW cw = case kindOf cw of
KBounded True _ -> True
_ -> False
isUW cw = case kindOf cw of
KBounded False sz -> sz > 1
_ -> False
modName = let (f:r) = n in toUpper f : r
pad = replicate (length n + 3) ' '
getType [] = "[a]"
getType ((i, o):_) = "[(" ++ mapType typeOf i ++ ", " ++ mapType typeOf o ++ ")]"
mkLine (i, o) = "(" ++ mapType valOf i ++ ", " ++ mapType valOf o ++ ")"
mapType f cws = mkTuple $ map f $ groupBy ((==) `on` kindOf) cws
mkTuple [x] = x
mkTuple xs = "(" ++ intercalate ", " xs ++ ")"
typeOf [] = "()"
typeOf [x] = t x
typeOf (x:_) = "[" ++ t x ++ "]"
valOf [] = "()"
valOf [x] = s x
valOf xs = "[" ++ intercalate ", " (map s xs) ++ "]"
t cw = case kindOf cw of
KBool -> "Bool"
KBounded False 8 -> "Word8"
KBounded False 16 -> "Word16"
KBounded False 32 -> "Word32"
KBounded False 64 -> "Word64"
KBounded True 8 -> "Int8"
KBounded True 16 -> "Int16"
KBounded True 32 -> "Int32"
KBounded True 64 -> "Int64"
KUnbounded -> "Integer"
KFloat -> "Float"
KDouble -> "Double"
KReal -> error $ "SBV.renderTest: Unsupported real valued test value: " ++ show cw
KUninterpreted us -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us
_ -> error $ "SBV.renderTest: Unexpected CW: " ++ show cw
s cw = case cwKind cw of
KBool -> take 5 (show (cwToBool cw) ++ repeat ' ')
KBounded sgn sz -> let CWInteger w = cwVal cw in shex False True (sgn, sz) w
KUnbounded -> let CWInteger w = cwVal cw in shexI False True w
KFloat -> let CWFloat w = cwVal cw in showHFloat w
KDouble -> let CWDouble w = cwVal cw in showHDouble w
KReal -> let CWAlgReal w = cwVal cw in algRealToHaskell w
KUninterpreted us -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us
c :: String -> [([CW], [CW])] -> String
c n vs = intercalate "\n" $
[ "/* Automatically generated by SBV. Do not edit! */"
, ""
, "#include <stdio.h>"
, "#include <inttypes.h>"
, "#include <stdint.h>"
, "#include <stdbool.h>"
, "#include <math.h>"
, ""
, "/* The boolean type */"
, "typedef bool SBool;"
, ""
, "/* The float type */"
, "typedef float SFloat;"
, ""
, "/* The double type */"
, "typedef double SDouble;"
, ""
, "/* Unsigned bit-vectors */"
, "typedef uint8_t SWord8 ;"
, "typedef uint16_t SWord16;"
, "typedef uint32_t SWord32;"
, "typedef uint64_t SWord64;"
, ""
, "/* Signed bit-vectors */"
, "typedef int8_t SInt8 ;"
, "typedef int16_t SInt16;"
, "typedef int32_t SInt32;"
, "typedef int64_t SInt64;"
, ""
, "typedef struct {"
, " struct {"
]
++ (if null vs then [] else zipWith (mkField "i") (fst (head vs)) [(0::Int)..])
++ [ " } input;"
, " struct {"
]
++ (if null vs then [] else zipWith (mkField "o") (snd (head vs)) [(0::Int)..])
++ [ " } output;"
, "} " ++ n ++ "TestVector;"
, ""
, n ++ "TestVector " ++ n ++ "[] = {"
]
++ [" " ++ intercalate "\n , " (map mkLine vs)]
++ [ "};"
, ""
, "int " ++ n ++ "Length = " ++ show (length vs) ++ ";"
, ""
, "/* Stub driver showing the test values, replace with code that uses the test vectors. */"
, "int main(void)"
, "{"
, " int i;"
, " for(i = 0; i < " ++ n ++ "Length; ++i)"
, " {"
, " " ++ outLine
, " }"
, ""
, " return 0;"
, "}"
]
where mkField p cw i = " " ++ t ++ " " ++ p ++ show i ++ ";"
where t = case cwKind cw of
KBool -> "SBool"
KBounded False 8 -> "SWord8"
KBounded False 16 -> "SWord16"
KBounded False 32 -> "SWord32"
KBounded False 64 -> "SWord64"
KBounded True 8 -> "SInt8"
KBounded True 16 -> "SInt16"
KBounded True 32 -> "SInt32"
KBounded True 64 -> "SInt64"
KFloat -> "SFloat"
KDouble -> "SDouble"
KUnbounded -> error "SBV.renderTest: Unbounded integers are not supported when generating C test-cases."
KReal -> error "SBV.renderTest: Real values are not supported when generating C test-cases."
KUninterpreted us -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us
_ -> error $ "SBV.renderTest: Unexpected CW: " ++ show cw
mkLine (is, os) = "{{" ++ intercalate ", " (map v is) ++ "}, {" ++ intercalate ", " (map v os) ++ "}}"
v cw = case cwKind cw of
KBool -> if cwToBool cw then "true " else "false"
KBounded sgn sz -> let CWInteger w = cwVal cw in shex False True (sgn, sz) w
KUnbounded -> let CWInteger w = cwVal cw in shexI False True w
KFloat -> let CWFloat w = cwVal cw in showCFloat w
KDouble -> let CWDouble w = cwVal cw in showCDouble w
KUninterpreted us -> error $ "SBV.renderTest: Unsupported uninterpreted sort: " ++ us
KReal -> error "SBV.renderTest: Real values are not supported when generating C test-cases."
outLine
| null vs = "printf(\"\");"
| True = "printf(\"%*d. " ++ fmtString ++ "\\n\", " ++ show (length (show (length vs - 1))) ++ ", i"
++ concatMap ("\n , " ++ ) (zipWith inp is [(0::Int)..] ++ zipWith out os [(0::Int)..])
++ ");"
where (is, os) = head vs
inp cw i = mkBool cw (n ++ "[i].input.i" ++ show i)
out cw i = mkBool cw (n ++ "[i].output.o" ++ show i)
mkBool cw s = case cwKind cw of
KBool -> "(" ++ s ++ " == true) ? \"true \" : \"false\""
_ -> s
fmtString = unwords (map fmt is) ++ " -> " ++ unwords (map fmt os)
fmt cw = case cwKind cw of
KBool -> "%s"
KBounded False 8 -> "0x%02\"PRIx8\""
KBounded False 16 -> "0x%04\"PRIx16\"U"
KBounded False 32 -> "0x%08\"PRIx32\"UL"
KBounded False 64 -> "0x%016\"PRIx64\"ULL"
KBounded True 8 -> "%\"PRId8\""
KBounded True 16 -> "%\"PRId16\""
KBounded True 32 -> "%\"PRId32\"L"
KBounded True 64 -> "%\"PRId64\"LL"
KFloat -> "%f"
KDouble -> "%f"
KUnbounded -> error "SBV.renderTest: Unsupported unbounded integers for C generation."
KReal -> error "SBV.renderTest: Unsupported real valued values for C generation."
_ -> error $ "SBV.renderTest: Unexpected CW: " ++ show cw
forte :: String -> Bool -> ([Int], [Int]) -> [([CW], [CW])] -> String
forte vname bigEndian ss vs = intercalate "\n" $ [ "// Automatically generated by SBV. Do not edit!"
, "let " ++ n ++ " ="
, " let c s = val [_, r] = str_split s \"'\" in " ++ blaster
]
++ [ " in [ " ++ intercalate "\n , " (map mkLine vs)
, " ];"
]
where n | null vname = "testVectors"
| not (isAlpha (head vname)) = "tv" ++ vname
| True = vname
blaster
| bigEndian = "map (\\s. s == \"1\") (explode (string_tl r))"
| True = "rev (map (\\s. s == \"1\") (explode (string_tl r)))"
toF True = '1'
toF False = '0'
blast cw = case cwKind cw of
KBool -> [toF (cwToBool cw)]
KBounded False 8 -> xlt 8 (cwVal cw)
KBounded False 16 -> xlt 16 (cwVal cw)
KBounded False 32 -> xlt 32 (cwVal cw)
KBounded False 64 -> xlt 64 (cwVal cw)
KBounded True 8 -> xlt 8 (cwVal cw)
KBounded True 16 -> xlt 16 (cwVal cw)
KBounded True 32 -> xlt 32 (cwVal cw)
KBounded True 64 -> xlt 64 (cwVal cw)
KFloat -> error "SBV.renderTest: Float values are not supported when generating Forte test-cases."
KDouble -> error "SBV.renderTest: Double values are not supported when generating Forte test-cases."
KReal -> error "SBV.renderTest: Real values are not supported when generating Forte test-cases."
KUnbounded -> error "SBV.renderTest: Unbounded integers are not supported when generating Forte test-cases."
_ -> error $ "SBV.renderTest: Unexpected CW: " ++ show cw
xlt s (CWInteger v) = [toF (testBit v i) | i <- [s-1, s-2 .. 0]]
xlt _ (CWFloat r) = error $ "SBV.renderTest.Forte: Unexpected float value: " ++ show r
xlt _ (CWDouble r) = error $ "SBV.renderTest.Forte: Unexpected double value: " ++ show r
xlt _ (CWAlgReal r) = error $ "SBV.renderTest.Forte: Unexpected real value: " ++ show r
xlt _ (CWUninterpreted r) = error $ "SBV.renderTest.Forte: Unexpected uninterpreted value: " ++ show r
mkLine (i, o) = "(" ++ mkTuple (form (fst ss) (concatMap blast i)) ++ ", " ++ mkTuple (form (snd ss) (concatMap blast o)) ++ ")"
mkTuple [] = "()"
mkTuple [x] = x
mkTuple xs = "(" ++ intercalate ", " xs ++ ")"
form [] [] = []
form [] bs = error $ "SBV.renderTest: Mismatched index in stream, extra " ++ show (length bs) ++ " bit(s) remain."
form (i:is) bs
| length bs < i = error $ "SBV.renderTest: Mismatched index in stream, was looking for " ++ show i ++ " bit(s), but only " ++ show i ++ " remains."
| i == 1 = let b:r = bs
v = if b == '1' then "T" else "F"
in v : form is r
| True = let (f, r) = splitAt i bs
v = "c \"" ++ show i ++ "'b" ++ f ++ "\""
in v : form is r

108
sbv/Data/SBV/Tools/Optimize.hs
View File

@ -1,108 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Tools.Optimize
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- SMT based optimization
-----------------------------------------------------------------------------
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Data.SBV.Tools.Optimize (OptimizeOpts(..), optimize, optimizeWith, minimize, minimizeWith, maximize, maximizeWith) where
import Data.Maybe (fromJust)
import Data.SBV.BitVectors.Data
import Data.SBV.BitVectors.Model (OrdSymbolic(..), EqSymbolic(..))
import Data.SBV.Provers.Prover (satWith, defaultSMTCfg)
import Data.SBV.SMT.SMT (SatModel, getModel)
import Data.SBV.Utils.Boolean
-- | Optimizer configuration. Note that iterative and quantified approaches are in general not interchangeable.
-- For instance, iterative solutions will loop infinitely when there is no optimal value, but quantified solutions
-- can handle such problems. Of course, quantified problems are harder for SMT solvers, naturally.
data OptimizeOpts = Iterative Bool -- ^ Iteratively search. if True, it will be reporting progress
| Quantified -- ^ Use quantifiers
-- | Symbolic optimization. Generalization on 'minimize' and 'maximize' that allows arbitrary
-- cost functions and comparisons.
optimizeWith :: (SatModel a, SymWord a, Show a, SymWord c, Show c)
=> SMTConfig -- ^ SMT configuration
-> OptimizeOpts -- ^ Optimization options
-> (SBV c -> SBV c -> SBool) -- ^ comparator
-> ([SBV a] -> SBV c) -- ^ cost function
-> Int -- ^ how many elements?
-> ([SBV a] -> SBool) -- ^ validity constraint
-> IO (Maybe [a])
optimizeWith cfg (Iterative chatty) = iterOptimize chatty cfg
optimizeWith cfg Quantified = quantOptimize cfg
-- | Variant of 'optimizeWith' using the default solver. See 'optimizeWith' for parameter descriptions.
optimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => OptimizeOpts -> (SBV c -> SBV c -> SBool) -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])
optimize = optimizeWith defaultSMTCfg
-- | Variant of 'maximize' allowing the use of a user specified solver. See 'optimizeWith' for parameter descriptions.
maximizeWith :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => SMTConfig -> OptimizeOpts -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])
maximizeWith cfg opts = optimizeWith cfg opts (.>=)
-- | Maximizes a cost function with respect to a constraint. Examples:
--
-- >>> maximize Quantified sum 3 (bAll (.< (10 :: SInteger)))
-- Just [9,9,9]
maximize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => OptimizeOpts -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])
maximize = maximizeWith defaultSMTCfg
-- | Variant of 'minimize' allowing the use of a user specified solver. See 'optimizeWith' for parameter descriptions.
minimizeWith :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => SMTConfig -> OptimizeOpts -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])
minimizeWith cfg opts = optimizeWith cfg opts (.<=)
-- | Minimizes a cost function with respect to a constraint. Examples:
--
-- >>> minimize Quantified sum 3 (bAll (.> (10 :: SInteger)))
-- Just [11,11,11]
minimize :: (SatModel a, SymWord a, Show a, SymWord c, Show c) => OptimizeOpts -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])
minimize = minimizeWith defaultSMTCfg
-- | Optimization using quantifiers
quantOptimize :: (SatModel a, SymWord a) => SMTConfig -> (SBV c -> SBV c -> SBool) -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])
quantOptimize cfg cmp cost n valid = do
m <- satWith cfg $ do xs <- mkExistVars n
ys <- mkForallVars n
return $ valid xs &&& (valid ys ==> cost xs `cmp` cost ys)
case getModel m of
Right (True, _) -> error "SBV: Backend solver reported \"unknown\""
Right (False, a) -> return $ Just a
Left _ -> return Nothing
-- | Optimization using iteration
iterOptimize :: (SatModel a, Show a, SymWord a, Show c, SymWord c) => Bool -> SMTConfig -> (SBV c -> SBV c -> SBool) -> ([SBV a] -> SBV c) -> Int -> ([SBV a] -> SBool) -> IO (Maybe [a])
iterOptimize chatty cfg cmp cost n valid = do
msg "Trying to find a satisfying solution."
m <- satWith cfg $ valid `fmap` mkExistVars n
case getModel m of
Left _ -> do msg "No satisfying solutions found."
return Nothing
Right (True, _) -> error "SBV: Backend solver reported \"unknown\""
Right (False, a) -> do msg $ "First solution found: " ++ show a
let c = cost (map literal a)
msg $ "Initial value is : " ++ show (fromJust (unliteral c))
msg "Starting iterative search."
go (1::Int) a c
where msg m | chatty = putStrLn $ "*** " ++ m
| True = return ()
go i curSol curCost = do
msg $ "Round " ++ show i ++ " ****************************"
m <- satWith cfg $ do xs <- mkExistVars n
return $ let c = cost xs in valid xs &&& (c `cmp` curCost &&& c ./= curCost)
case getModel m of
Left _ -> do msg "The current solution is optimal. Terminating search."
return $ Just curSol
Right (True, _) -> error "SBV: Backend solver reported \"unknown\""
Right (False, a) -> do msg $ "Solution: " ++ show a
let c = cost (map literal a)
msg $ "Value : " ++ show (fromJust (unliteral c))
go (i+1) a c

248
sbv/Data/SBV/Tools/Polynomial.hs
View File

@ -1,248 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.BitVectors.Polynomials
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Implementation of polynomial arithmetic
-----------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Data.SBV.Tools.Polynomial (Polynomial(..), crc, crcBV, ites, addPoly, mdp) where
import Data.Bits (Bits(..))
import Data.List (genericTake)
import Data.Maybe (fromJust)
import Data.Word (Word8, Word16, Word32, Word64)
import Data.SBV.BitVectors.Data
import Data.SBV.BitVectors.Model
import Data.SBV.BitVectors.Splittable
import Data.SBV.Utils.Boolean
-- | Implements polynomial addition, multiplication, division, and modulus operations
-- over GF(2^n). NB. Similar to 'sQuotRem', division by @0@ is interpreted as follows:
--
-- @x `pDivMod` 0 = (0, x)@
--
-- for all @x@ (including @0@)
--
-- Minimal complete definition: 'pMult', 'pDivMod', 'showPolynomial'
class (Num a, Bits a) => Polynomial a where
-- | Given bit-positions to be set, create a polynomial
-- For instance
--
-- @polynomial [0, 1, 3] :: SWord8@
--
-- will evaluate to @11@, since it sets the bits @0@, @1@, and @3@. Mathematicans would write this polynomial
-- as @x^3 + x + 1@. And in fact, 'showPoly' will show it like that.
polynomial :: [Int] -> a
-- | Add two polynomials in GF(2^n).
pAdd :: a -> a -> a
-- | Multiply two polynomials in GF(2^n), and reduce it by the irreducible specified by
-- the polynomial as specified by coefficients of the third argument. Note that the third
-- argument is specifically left in this form as it is usally in GF(2^(n+1)), which is not available in our
-- formalism. (That is, we would need SWord9 for SWord8 multiplication, etc.) Also note that we do not
-- support symbolic irreducibles, which is a minor shortcoming. (Most GF's will come with fixed irreducibles,
-- so this should not be a problem in practice.)
--
-- Passing [] for the third argument will multiply the polynomials and then ignore the higher bits that won't
-- fit into the resulting size.
pMult :: (a, a, [Int]) -> a
-- | Divide two polynomials in GF(2^n), see above note for division by 0.
pDiv :: a -> a -> a
-- | Compute modulus of two polynomials in GF(2^n), see above note for modulus by 0.
pMod :: a -> a -> a
-- | Division and modulus packed together.
pDivMod :: a -> a -> (a, a)
-- | Display a polynomial like a mathematician would (over the monomial @x@), with a type.
showPoly :: a -> String
-- | Display a polynomial like a mathematician would (over the monomial @x@), the first argument
-- controls if the final type is shown as well.
showPolynomial :: Bool -> a -> String
-- defaults.. Minumum complete definition: pMult, pDivMod, showPolynomial
polynomial = foldr (flip setBit) 0
pAdd = xor
pDiv x y = fst (pDivMod x y)
pMod x y = snd (pDivMod x y)
showPoly = showPolynomial False
instance Polynomial Word8 where {showPolynomial = sp; pMult = lift polyMult; pDivMod = liftC polyDivMod}
instance Polynomial Word16 where {showPolynomial = sp; pMult = lift polyMult; pDivMod = liftC polyDivMod}
instance Polynomial Word32 where {showPolynomial = sp; pMult = lift polyMult; pDivMod = liftC polyDivMod}
instance Polynomial Word64 where {showPolynomial = sp; pMult = lift polyMult; pDivMod = liftC polyDivMod}
instance Polynomial SWord8 where {showPolynomial b = liftS (sp b); pMult = polyMult; pDivMod = polyDivMod}
instance Polynomial SWord16 where {showPolynomial b = liftS (sp b); pMult = polyMult; pDivMod = polyDivMod}
instance Polynomial SWord32 where {showPolynomial b = liftS (sp b); pMult = polyMult; pDivMod = polyDivMod}
instance Polynomial SWord64 where {showPolynomial b = liftS (sp b); pMult = polyMult; pDivMod = polyDivMod}
lift :: SymWord a => ((SBV a, SBV a, [Int]) -> SBV a) -> (a, a, [Int]) -> a
lift f (x, y, z) = fromJust $ unliteral $ f (literal x, literal y, z)
liftC :: SymWord a => (SBV a -> SBV a -> (SBV a, SBV a)) -> a -> a -> (a, a)
liftC f x y = let (a, b) = f (literal x) (literal y) in (fromJust (unliteral a), fromJust (unliteral b))
liftS :: SymWord a => (a -> String) -> SBV a -> String
liftS f s
| Just x <- unliteral s = f x
| True = show s
-- | Pretty print as a polynomial
sp :: Bits a => Bool -> a -> String
sp st a
| null cs = '0' : t
| True = foldr (\x y -> sh x ++ " + " ++ y) (sh (last cs)) (init cs) ++ t
where t | st = " :: GF(2^" ++ show n ++ ")"
| True = ""
#if __GLASGOW_HASKELL__ >= 708
n = maybe (error "SBV.Polynomial.sp: Unexpected non-finite usage!") id (bitSizeMaybe a)
#else
n = bitSize a
#endif
is = [n-1, n-2 .. 0]
cs = map fst $ filter snd $ zip is (map (testBit a) is)
sh 0 = "1"
sh 1 = "x"
sh i = "x^" ++ show i
-- | Add two polynomials
addPoly :: [SBool] -> [SBool] -> [SBool]
addPoly xs [] = xs
addPoly [] ys = ys
addPoly (x:xs) (y:ys) = x <+> y : addPoly xs ys
ites :: SBool -> [SBool] -> [SBool] -> [SBool]
ites s xs ys
| Just t <- unliteral s
= if t then xs else ys
| True
= go xs ys
where go [] [] = []
go [] (b:bs) = ite s false b : go [] bs
go (a:as) [] = ite s a false : go as []
go (a:as) (b:bs) = ite s a b : go as bs
-- | Multiply two polynomials and reduce by the third (concrete) irreducible, given by its coefficients.
-- See the remarks for the 'pMult' function for this design choice
polyMult :: (Num a, Bits a, SymWord a, FromBits (SBV a)) => (SBV a, SBV a, [Int]) -> SBV a
polyMult (x, y, red)
| isReal x
= error $ "SBV.polyMult: Received a real value: " ++ show x
| not (isBounded x)
= error $ "SBV.polyMult: Received infinite precision value: " ++ show x
| True
= fromBitsLE $ genericTake sz $ r ++ repeat false
where (_, r) = mdp ms rs
ms = genericTake (2*sz) $ mul (blastLE x) (blastLE y) [] ++ repeat false
rs = genericTake (2*sz) $ [if i `elem` red then true else false | i <- [0 .. foldr max 0 red] ] ++ repeat false
sz = intSizeOf x
mul _ [] ps = ps
mul as (b:bs) ps = mul (false:as) bs (ites b (as `addPoly` ps) ps)
polyDivMod :: (Num a, Bits a, SymWord a, FromBits (SBV a)) => SBV a -> SBV a -> (SBV a, SBV a)
polyDivMod x y
| isReal x
= error $ "SBV.polyDivMod: Received a real value: " ++ show x
| not (isBounded x)
= error $ "SBV.polyDivMod: Received infinite precision value: " ++ show x
| True
= ite (y .== 0) (0, x) (adjust d, adjust r)
where adjust xs = fromBitsLE $ genericTake sz $ xs ++ repeat false
sz = intSizeOf x
(d, r) = mdp (blastLE x) (blastLE y)
-- conservative over-approximation of the degree
degree :: [SBool] -> Int
degree xs = walk (length xs - 1) $ reverse xs
where walk n [] = n
walk n (b:bs)
| Just t <- unliteral b
= if t then n else walk (n-1) bs
| True
= n -- over-estimate
mdp :: [SBool] -> [SBool] -> ([SBool], [SBool])
mdp xs ys = go (length ys - 1) (reverse ys)
where degTop = degree xs
go _ [] = error "SBV.Polynomial.mdp: Impossible happened; exhausted ys before hitting 0"
go n (b:bs)
| n == 0 = (reverse qs, rs)
| True = let (rqs, rrs) = go (n-1) bs
in (ites b (reverse qs) rqs, ites b rs rrs)
where degQuot = degTop - n
ys' = replicate degQuot false ++ ys
(qs, rs) = divx (degQuot+1) degTop xs ys'
-- return the element at index i; if not enough elements, return false
-- N.B. equivalent to '(xs ++ repeat false) !! i', but more efficient
idx :: [SBool] -> Int -> SBool
idx [] _ = false
idx (x:_) 0 = x
idx (_:xs) i = idx xs (i-1)
divx :: Int -> Int -> [SBool] -> [SBool] -> ([SBool], [SBool])
divx n _ xs _ | n <= 0 = ([], xs)
divx n i xs ys' = (q:qs, rs)
where q = xs `idx` i
xs' = ites q (xs `addPoly` ys') xs
(qs, rs) = divx (n-1) (i-1) xs' (tail ys')
-- | Compute CRCs over bit-vectors. The call @crcBV n m p@ computes
-- the CRC of the message @m@ with respect to polynomial @p@. The
-- inputs are assumed to be blasted big-endian. The number
-- @n@ specifies how many bits of CRC is needed. Note that @n@
-- is actually the degree of the polynomial @p@, and thus it seems
-- redundant to pass it in. However, in a typical proof context,
-- the polynomial can be symbolic, so we cannot compute the degree
-- easily. While this can be worked-around by generating code that
-- accounts for all possible degrees, the resulting code would
-- be unnecessarily big and complicated, and much harder to reason
-- with. (Also note that a CRC is just the remainder from the
-- polynomial division, but this routine is much faster in practice.)
--
-- NB. The @n@th bit of the polynomial @p@ /must/ be set for the CRC
-- to be computed correctly. Note that the polynomial argument 'p' will
-- not even have this bit present most of the time, as it will typically
-- contain bits @0@ through @n-1@ as usual in the CRC literature. The higher
-- order @n@th bit is simply assumed to be set, as it does not make
-- sense to use a polynomial of a lesser degree. This is usually not a problem
-- since CRC polynomials are designed and expressed this way.
--
-- NB. The literature on CRC's has many variants on how CRC's are computed.
-- We follow the painless guide (<http://www.ross.net/crc/download/crc_v3.txt>)
-- and compute the CRC as follows:
--
-- * Extend the message 'm' by adding 'n' 0 bits on the right
--
-- * Divide the polynomial thus obtained by the 'p'
--
-- * The remainder is the CRC value.
--
-- There are many variants on final XOR's, reversed polynomials etc., so
-- it is essential to double check you use the correct /algorithm/.
crcBV :: Int -> [SBool] -> [SBool] -> [SBool]
crcBV n m p = take n $ go (replicate n false) (m ++ replicate n false)
where mask = drop (length p - n) p
go c [] = c
go c (b:bs) = go next bs
where c' = drop 1 c ++ [b]
next = ite (head c) (zipWith (<+>) c' mask) c'
-- | Compute CRC's over polynomials, i.e., symbolic words. The first
-- 'Int' argument plays the same role as the one in the 'crcBV' function.
crc :: (FromBits (SBV a), FromBits (SBV b), Num a, Num b, Bits a, Bits b, SymWord a, SymWord b) => Int -> SBV a -> SBV b -> SBV b
crc n m p
| isReal m || isReal p
= error $ "SBV.crc: Received a real value: " ++ show (m, p)
| not (isBounded m) || not (isBounded p)
= error $ "SBV.crc: Received an infinite precision value: " ++ show (m, p)
| True
= fromBitsBE $ replicate (sz - n) false ++ crcBV n (blastBE m) (blastBE p)
where sz = intSizeOf p

81
sbv/Data/SBV/Utils/Boolean.hs
View File

@ -1,81 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Utils.Boolean
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Abstraction of booleans. Unfortunately, Haskell makes Bool's very hard to
-- work with, by making it a fixed-data type. This is our workaround
-----------------------------------------------------------------------------
module Data.SBV.Utils.Boolean(Boolean(..), bAnd, bOr, bAny, bAll) where
infixl 6 <+> -- xor
infixr 3 &&&, ~& -- and, nand
infixr 2 |||, ~| -- or, nor
infixr 1 ==>, <=> -- implies, iff
-- | The 'Boolean' class: a generalization of Haskell's 'Bool' type
-- Haskell 'Bool' and SBV's 'SBool' are instances of this class, unifying the treatment of boolean values.
--
-- Minimal complete definition: 'true', 'bnot', '&&&'
-- However, it's advisable to define 'false', and '|||' as well (typically), for clarity.
class Boolean b where
-- | logical true
true :: b
-- | logical false
false :: b
-- | complement
bnot :: b -> b
-- | and
(&&&) :: b -> b -> b
-- | or
(|||) :: b -> b -> b
-- | nand
(~&) :: b -> b -> b
-- | nor
(~|) :: b -> b -> b
-- | xor
(<+>) :: b -> b -> b
-- | implies
(==>) :: b -> b -> b
-- | equivalence
(<=>) :: b -> b -> b
-- | cast from Bool
fromBool :: Bool -> b
-- default definitions
false = bnot true
a ||| b = bnot (bnot a &&& bnot b)
a ~& b = bnot (a &&& b)
a ~| b = bnot (a ||| b)
a <+> b = (a &&& bnot b) ||| (bnot a &&& b)
a <=> b = (a &&& b) ||| (bnot a &&& bnot b)
a ==> b = bnot a ||| b
fromBool True = true
fromBool False = false
-- | Generalization of 'and'
bAnd :: Boolean b => [b] -> b
bAnd = foldr (&&&) true
-- | Generalization of 'or'
bOr :: Boolean b => [b] -> b
bOr = foldr (|||) false
-- | Generalization of 'any'
bAny :: Boolean b => (a -> b) -> [a] -> b
bAny f = bOr . map f
-- | Generalization of 'all'
bAll :: Boolean b => (a -> b) -> [a] -> b
bAll f = bAnd . map f
instance Boolean Bool where
true = True
false = False
bnot = not
(&&&) = (&&)
(|||) = (||)

40
sbv/Data/SBV/Utils/Lib.hs
View File

@ -1,40 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Utils.Lib
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Misc helpers
-----------------------------------------------------------------------------
module Data.SBV.Utils.Lib where
-- | Monadic lift over 2-tuples
mlift2 :: Monad m => (a' -> b' -> r) -> (a -> m a') -> (b -> m b') -> (a, b) -> m r
mlift2 k f g (a, b) = f a >>= \a' -> g b >>= \b' -> return $ k a' b'
-- | Monadic lift over 3-tuples
mlift3 :: Monad m => (a' -> b' -> c' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (a, b, c) -> m r
mlift3 k f g h (a, b, c) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> return $ k a' b' c'
-- | Monadic lift over 4-tuples
mlift4 :: Monad m => (a' -> b' -> c' -> d' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (a, b, c, d) -> m r
mlift4 k f g h i (a, b, c, d) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> return $ k a' b' c' d'
-- | Monadic lift over 5-tuples
mlift5 :: Monad m => (a' -> b' -> c' -> d' -> e' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (a, b, c, d, e) -> m r
mlift5 k f g h i j (a, b, c, d, e) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> return $ k a' b' c' d' e'
-- | Monadic lift over 6-tuples
mlift6 :: Monad m => (a' -> b' -> c' -> d' -> e' -> f' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (f -> m f') -> (a, b, c, d, e, f) -> m r
mlift6 k f g h i j l (a, b, c, d, e, y) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> return $ k a' b' c' d' e' y'
-- | Monadic lift over 7-tuples
mlift7 :: Monad m => (a' -> b' -> c' -> d' -> e' -> f' -> g' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (f -> m f') -> (g -> m g') -> (a, b, c, d, e, f, g) -> m r
mlift7 k f g h i j l m (a, b, c, d, e, y, z) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> return $ k a' b' c' d' e' y' z'
-- | Monadic lift over 8-tuples
mlift8 :: Monad m => (a' -> b' -> c' -> d' -> e' -> f' -> g' -> h' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (f -> m f') -> (g -> m g') -> (h -> m h') -> (a, b, c, d, e, f, g, h) -> m r
mlift8 k f g h i j l m n (a, b, c, d, e, y, z, w) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> n w >>= \w' -> return $ k a' b' c' d' e' y' z' w'

36
sbv/Data/SBV/Utils/TDiff.hs
View File

@ -1,36 +0,0 @@
-----------------------------------------------------------------------------
-- |
-- Module : Data.SBV.Utils.TDiff
-- Copyright : (c) Levent Erkok
-- License : BSD3
-- Maintainer : erkokl@gmail.com
-- Stability : experimental
--
-- Runs an IO computation printing the time it took to run it
-----------------------------------------------------------------------------
module Data.SBV.Utils.TDiff(timeIf) where
import Control.DeepSeq (rnf, NFData(..))
import System.Time (TimeDiff(..), normalizeTimeDiff, diffClockTimes, getClockTime)
import Numeric (showFFloat)
showTDiff :: TimeDiff -> String
showTDiff itd = et
where td = normalizeTimeDiff itd
vals = dropWhile (\(v, _) -> v == 0) (zip [tdYear td, tdMonth td, tdDay td, tdHour td, tdMin td] "YMDhm")
sec = ' ' : show (tdSec td) ++ dropWhile (/= '.') pico
pico = showFFloat (Just 3) (((10**(-12))::Double) * fromIntegral (tdPicosec td)) "s"
et = concatMap (\(v, c) -> ' ':show v ++ [c]) vals ++ sec
-- | If selected, runs the computation @m@, and prints the time it took
-- to run it. The return type should be an instance of 'NFData' to ensure
-- the correct elapsed time is printed.
timeIf :: NFData a => Bool -> String -> IO a -> IO a
timeIf False _ m = m
timeIf True w m = do start <- getClockTime
r <- m
end <- rnf r `seq` getClockTime
let elapsed = diffClockTimes end start
putStrLn $ "** Elapsed " ++ w ++ " time:" ++ showTDiff elapsed
return r

26
sbv/LICENSE
View File

@ -1,26 +0,0 @@
SBV: SMT Based Verification in Haskell
Copyright (c) 2010-2014, Levent Erkok (erkokl@gmail.com)
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
* Neither the name of the developer (Levent Erkok) nor the
names of its contributors may be used to endorse or promote products
derived from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL LEVENT ERKOK BE LIABLE FOR ANY
DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

1
src/.gitignore vendored
View File

@ -1 +0,0 @@
GitRev.hs

16
src/Cryptol/Eval.hs
View File

@ -1,6 +1,6 @@
-- |
-- Module : $Header$
-- Copyright : (c) 2013-2014 Galois, Inc.
-- Copyright : (c) 2013-2015 Galois, Inc.
-- License : BSD3
-- Maintainer : cryptol@galois.com
-- Stability : provisional
@ -43,7 +43,7 @@ evalExpr env expr = case expr of
ECon con -> evalECon con
EList es ty -> evalList env es (evalType env ty)
EList es ty -> VSeq (isTBit (evalType env ty)) (map (evalExpr env) es)
ETuple es -> VTuple (map eval es)
@ -208,15 +208,3 @@ evalMatch env m = case m of
-- they are typechecked that way; the read environment to evalDecl is the same
-- as the environment to bind a new name in.
Let d -> [evalDecl env d env]
-- Lists -----------------------------------------------------------------------
-- | Evaluate a list literal, optionally packing them into a word.
evalList :: EvalEnv -> [Expr] -> TValue -> Value
evalList env es ty = toPackedSeq w ty (map (evalExpr env) es)
where
w = TValue $ tNum $ length es

Some files were not shown because too many files have changed in this diff Show More