pax_global_header00006660000000000000000000000064137755632550014534gustar00rootroot0000000000000052 comment=157a03d09e3ac6601b182f63967aa4f13906ee89 curry-tools-v3.3.0/000077500000000000000000000000001377556325500142275ustar00rootroot00000000000000curry-tools-v3.3.0/.gitignore000066400000000000000000000016551377556325500162260ustar00rootroot00000000000000# intermediate files *~ .curry Curry_Main_Goal.curry cpm/src/CPM/ConfigPackage.curry *.agdai *_cache *_CACHE optimize/.cpm/packages/cass-* optimize/.cpm/packages/cass-analysis-* optimize/.cpm/packages/containers-* optimize/.cpm/packages/csv-* optimize/.cpm/packages/currypath-* optimize/.cpm/packages/directory-* optimize/.cpm/packages/distribution-* optimize/.cpm/packages/filepath-* optimize/.cpm/packages/flatcurry-* optimize/.cpm/packages/frontend-exec-* optimize/.cpm/packages/global-* optimize/.cpm/packages/io-extra-* optimize/.cpm/packages/process-* optimize/.cpm/packages/propertyfile-* optimize/.cpm/packages/queue-* optimize/.cpm/packages/random-* optimize/.cpm/packages/read-legacy-* optimize/.cpm/packages/redblacktree-* optimize/.cpm/packages/scc-* optimize/.cpm/packages/socket-* optimize/.cpm/packages/time-* optimize/.cpm/packages/wl-pprint-* optimize/.cpm/packages/xml-* # executables cpm/src/CPM.Main optimize/BindingOpt curry-tools-v3.3.0/LICENSE000066400000000000000000000027101377556325500152340ustar00rootroot00000000000000Copyright (c) 2011-2018, Michael Hanus 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. - None of the names of the copyright holders and 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 THE COPYRIGHT OWNER OR CONTRIBUTORS 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. curry-tools-v3.3.0/Makefile000066400000000000000000000034761377556325500157010ustar00rootroot00000000000000# Generate various tools for Curry # Required: # - root location of the Curry System specified by variable ROOT ROOT ?= $(error Please specify the variable ROOT) export BINDIR = $(ROOT)/bin export LIBDIR = $(ROOT)/lib export CLEANCURRY = $(BINDIR)/cleancurry export REPL = $(BINDIR)/curry # Directory names of all tools: ALLTOOLDIRS = $(filter-out $(EXCLUDES), $(sort $(notdir $(shell find . -mindepth 1 -maxdepth 1 -type d)))) EXCLUDES = .git # Directory names of all tools having a Makefile: TOOLDIRS = $(foreach d, $(ALLTOOLDIRS), $(shell test -f $(d)/Makefile && echo $(d))) make_TOOLDIRS=$(addprefix make_,$(TOOLDIRS)) compile_TOOLDIRS=$(addprefix compile_,$(TOOLDIRS)) install_TOOLDIRS=$(addprefix install_,$(TOOLDIRS)) clean_TOOLDIRS=$(addprefix clean_,$(TOOLDIRS)) uninstall_TOOLDIRS=$(addprefix uninstall_,$(TOOLDIRS)) .PHONY: all all: $(make_TOOLDIRS) ########################################################################### # Make the different tools: make_%: @cd $* && $(MAKE) ########################################################################### .PHONY: compile compile: $(compile_TOOLDIRS) $(compile_TOOLDIRS): @cd $(patsubst compile_%,%,$@) && $(MAKE) compile .PHONY: install install: $(install_TOOLDIRS) $(install_TOOLDIRS): @cd $(patsubst install_%,%,$@) && $(MAKE) install .PHONY: clean clean: $(clean_TOOLDIRS) $(clean_TOOLDIRS): @cd $(patsubst clean_%,%,$@) && $(MAKE) clean .PHONY: uninstall uninstall: $(uninstall_TOOLDIRS) $(uninstall_TOOLDIRS): @cd $(patsubst uninstall_%,%,$@) && $(MAKE) uninstall ######################################################################## # Testing the tools # Tools with test suites: TESTTOOLS = optimize cpm # run the test suites to check the tools .PHONY: runtest runtest: $(addprefix runtest_,$(TESTTOOLS)) runtest_%: cd $* && $(MAKE) runtest curry-tools-v3.3.0/README.md000066400000000000000000000010221377556325500155010ustar00rootroot00000000000000Curry Tools =========== This directory contains some base tools for Curry that are used by different Curry systems, like PAKCS or KiCS2. These are: `cpm` This directory contains the Curry package manager (CPM) with the main executable `cypm`. CPM is a tool to distribute and install Curry packages. It can be used to download further Curry libraries and applications. `optimize`: The implementation of optimization tools for Curry, in particular, a transformation tool to replace Boolean equalities by unification constraints. curry-tools-v3.3.0/cpm/000077500000000000000000000000001377556325500150065ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/Implementation.md000066400000000000000000000063061377556325500203220ustar00rootroot00000000000000Some details about CPM's Implementation ======================================== Information about CPM's local storage structure (i.e., on the client side) can be found in the manual. Here is some information about CPM's global storage structure. Global package index -------------------- CPM requires a global index containing the specifications of all available packages. The default URL is defined in `CPM.Config.packageIndexDefaultURL`, currently as https://git.ps.informatik.uni-kiel.de/curry-packages/cpm-index.git This configuration can be changed by the `.cpmrc` value PACKAGE_INDEX_URL Currently, it is a git repository but it could also be a tar file or a gzipped tar file. The directory referenced by this URL must contains for each package `pkg` and version `vers` a file pkg/vers/package.json containing the package specification in JSON format. For instance, it contains the files cpm/2.0.0/package.json cpm/2.1.0/package.json cpm/2.1.1/package.json The global package index is downloaded by the CPM command cypm update This command also create a local sqlite3 database containing the most important information about each package. The database is used by various CPM commands to accelerate the access to information about packages. Global package store -------------------- CPM uses a global store containing a gzipped tar file for each package. The default URL is defined in `CPM.Config.packageTarFilesDefaultURL`, currently as https://www-ps.informatik.uni-kiel.de/~cpm/PACKAGES/ This configuration can be changed by the `.cpmrc` value PACKAGE_TARFILES_URL Currently, it is a git repository but it could also be a tar file or a gzipped tar file. In order to download the package `pkg` in version `vers`, CPM extends this URL by the string `pkg-vers.tar.gz`. For instance, CPM downloads version 2.1.0 of the package `cpm` from https://www-ps.informatik.uni-kiel.de/~cpm/PACKAGES/cpm-2.1.0.tar.gz If CPM cannot download anything from this location, it tries to download the package from the `source` field of the package description. Global package index cache -------------------------- In order to accelerate the creation of the sqlite3 database during the `update` command, CPM tries to download the file https://www-ps.informatik.uni-kiel.de/~cpm/PACKAGES/REPOSITORY_CACHE.csv which contains the database information in CSV format. If CPM cannot download this file, it creates the database by reading all package specifications of the global package index (which takes more time than reading the CSV file). Uploading packages ------------------ Currently, new package or package version can be uploaded to these global stores by the command cypm upload (see the manual for more details). Currently, only packages having a source specification of the form "source": { "git": "...git.ps.informatik.uni-kiel.de/curry-packages/....git", "tag": "$version" can be uploaded. Furthermore, one has to have write access to the source repository. This command tests the package and, in case of a successful test, uploads the package to the global package index and store via the web script at URL https://www-ps.informatik.uni-kiel.de/~cpm/cpm-upload.cgi curry-tools-v3.3.0/cpm/LICENSE000066400000000000000000000027351377556325500160220ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/Makefile000066400000000000000000000041131377556325500164450ustar00rootroot00000000000000# Makefile for Curry Package Manager (CPM) # The tool name of the application: TOOL = $(BINDIR)/cypm CURRYTOOL = $(BINDIR)/$(CURRYSYSTEM)-$(notdir $(TOOL)) # The default options for the REPL (options "rts -T" required for KiCS2 # in order to get elapsed times): ifeq ($(CURRYSYSTEM),kics2) export REPL_OPTS = --noreadline :set -time :set rts -T else export REPL_OPTS = --noreadline :set -time endif # Source modules of CPM: DEPS = src/CPM/*.curry src/CPM/*/*.curry .PHONY: all compile install clean uninstall runtest all: install install: compile rm -f $(TOOL) $(CURRYTOOL) cd $(BINDIR) && ln -s ../currytools/cpm/src/CPM.Main $(notdir $(TOOL)) # install also cypm binary with Curry system as prefix: cd $(BINDIR) && ln -s $(notdir $(TOOL)) $(CURRYTOOL) compile: src/CPM.Main clean: rm -Rf src/CPM.Main src/.curry vendor/*/src/.curry uninstall: clean rm -f $(TOOL) $(CURRYTOOL) src/CPM.Main: src/CPM/ConfigPackage.curry $(DEPS) @echo Root location of Curry system: $(ROOT) @if [ ! -d "$(ROOT)" ] ; then echo "Error: not a valid directory!" ; exit 1; fi @export CURRYPATH=""; \ for i in `ls vendor`; do \ export CURRYPATH="$$CURRYPATH:`pwd`/vendor/$$i/src"; \ done; \ echo "Set CURRYPATH to $$CURRYPATH"; \ cd src; $(REPL) --nocypm $(REPL_OPTS) :l CPM.Main :save :quit src/CPM/ConfigPackage.curry: Makefile @echo "module CPM.ConfigPackage where" > $@ @echo "packagePath :: String" >> $@ @echo "packagePath = \"$(CURDIR)\"" >> $@ @echo "packageVersion :: String" >> $@ @echo "packageVersion = \"3.0.0\"" >> $@ @echo "Curry configuration module '$@' written." runtest: @export CURRYPATH=""; \ for i in `ls vendor`; do \ export CURRYPATH="$$CURRYPATH:`pwd`/vendor/$$i/src"; \ done; \ cd src && curry-check CPM.Package CPM.Resolution CPM.LookupSet .PHONY: doc doc: @export CURRYPATH=""; \ for i in `ls vendor`; do \ export CURRYPATH="$$CURRYPATH:`pwd`/vendor/$$i/src"; \ done; \ export CURRYPATH="$$CURRYPATH:`pwd`/src"; \ curry-doc cdoc CPM.Main .PHONY: manual manual: pdflatex -output-directory=docs docs/manual.tex curry-tools-v3.3.0/cpm/README.md000066400000000000000000000071171377556325500162730ustar00rootroot00000000000000# The Curry Package Manager This repository contains the Curry package manager (CPM). ## Quick Start To build the Curry package manager, you need to run `make` inside this directory. The `Makefile` assumes that the `curry` executable and `git` are on your path. If the build was successful, a `cypm` binary will be placed in the directory `~/.cpm/bin` (which is also the directory where CPM installs binaries of tools distributed in packages). Therefore, you should add this directory to your path. Afterwards, run `cypm update` to clone a copy of the central package index repository. More information can be found in the manual, see the `docs` directory. ## Documentation Use `make manual` to generate a PDF version of the manual. A working LaTeX installation is required. `make doc` generates the CurryDoc documentation for the CPM source code in the `cdoc` directory. ## Contributing Please run the tests using `make test` before publishing your changes. You should also run the performance tests when you make changes to the API or behavior comparison modules or the resolution algorithm. To run the performance tests, build the performance test program using `make buildperf`. You can then use `bin/perftest` to execute the different performance test. To test the API comparison algorithm, use `bin/perftest api -n NUMBER`, where `NUMBER` is the number of added, changed and removed functions and types each that you want to compare. Note that when you specify 1000, the API comparison will compare 6000 elements: 1000 added functions, 1000 removed functions, 1000 changed functions, 1000 added types, 1000 removed types, and 1000 changed types. The behavior comparison algorithm can be tested using `bin/perftest behavior -t T -f F`, where `F` is the number of functions to compare and `T` is the depth to which the type of each function's argument is nested. For example, if `T` is set to 2, each generated function will take a type `Nested1`, which is defined as follows: ```haskell data Nested1 = Nested1 Nested2 data Nested2 = Nested2 String ``` To test the resolution algorithm, you need a set of test data, which you can find in the [cpm-perf-test-data](1) repository. Make sure that `packages.term` from thate repository is available in the current directory and then run `bin/perftest resolution --packages=P`, where `P` is a comma-separated list of package identifiers. A complete list of package identifiers available in the test data set can be found in the `packages.txt` file alongside `packages.term`. A good set of packages to start with is the following: - `express-4.14.0` has 1,759 dependencies available in 23,295 different versions. Resolution succeeds relatively quickly, since a solution can be found early in the candidate tree. - `express-3.9.0` has 1,794 dependencies available in 23,286 different versions. Resolution fails in about a quarter second on KiCS2 since a package is missing in the sample data set. - `chalk-1.1.3` only has 8 dependencies available in 65 different versions. Resolution succeeds very quickly. - `request-2.74.0` has 1,789 dependencies available in 23,229 different versions. Resolution still succeeds quickly on KiCS2, but takes over a second on PAKCS. - `mocha-1.21.5` has 1,789 dependencies available in 23,229 different versions. Resolution fails with a dependency conflict in about 4.5 seconds on KiCS2, but fails to finish in a reasonable timeframe on PAKCS. - `karma-1.2.0` has 1,850 dependencies available in 24,264 different versions. Currently, the resolution algorithm is too slow and does not arrive at a solution in a reasonable timeframe. curry-tools-v3.3.0/cpm/docs/000077500000000000000000000000001377556325500157365ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/docs/README.txt000066400000000000000000000003561377556325500174400ustar00rootroot00000000000000This directory contains some documention for the Curry Package Manager: currysystem_manual.tex: A short description to be included in the main manual of the Curry system. manual.tex: The main manual of CPM as a separate document. curry-tools-v3.3.0/cpm/docs/currysystem_manual.tex000066400000000000000000000046261377556325500224360ustar00rootroot00000000000000\section{\texttt{cypm}: The Curry Package Manager} \label{sec-cpm} The Curry package manager (CPM) is a tool to distribute and install Curry libraries and applications and manage version dependencies between these libraries. Since CPM offers a lot of functionality, there is a separate manual available.\footnote{\url{http://curry-lang.org/tools/cpm}} Therefore, we describe here only some basic CPM commands. The executable \code{cypm} is located in the \code{bin} directory of \CYS. Hence, if you have this directory in your path, you can start CPM by cloning a copy of the central package index repository: % \begin{curry} > cypm update \end{curry} % Now you can show a short list of all packages in this index by % \begin{curry} > cypm list Name Synopsis Version ---- -------- ------- abstract-curry Libraries to deal with AbstractCurry programs 2.0.0 abstract-haskell Libraries to represent Haskell programs in Curry 2.0.0 addtypes A tool to add missing type signatures in a Curry 2.0.0 program base Base libraries for Curry systems 1.0.0 $\ldots$ \end{curry} % The command % \begin{curry} > cypm info PACKAGE \end{curry} % can be used to show more information about the package with name \code{PACKAGE}. Some packages do not contain only useful libraries but also tools with some binary. In order to install such tools, one can use the command % \begin{curry} > cypm install PACKAGE \end{curry} % This command checks out the package in some internal directory (\code{\$HOME/.cpm/apps_\ldots}) and installs the binary of the tool provided by the package in \code{\$HOME/.cpm/bin}. Hence it is recommended to add this directory to your path. For instance, the most recent version of CPM can be installed by the following commands: % \begin{curry} > cypm update $\ldots$ > cypm install cpm $\ldots$ Package 'cpm-xxx' checked out $\ldots$ $\ldots$ INFO Installing executable 'cypm' into '/home/joe/.cpm/bin' \end{curry} % Now, the binary \code{cypm} of the most recent CPM version can be used if \code{\$HOME/.cpm/bin} is in your path (before \code{\cyshome{}/bin}!). A detailed description how to write your own packages with the use of other packages can be found in the manual of CPM. curry-tools-v3.3.0/cpm/docs/manual.tex000066400000000000000000001742201377556325500177430ustar00rootroot00000000000000\documentclass[11pt]{article} \usepackage{url} \usepackage{syntax} \usepackage{listings} \usepackage{amsmath} \lstset{aboveskip=1.5ex, belowskip=1.2ex, showstringspaces=false, mathescape=true, flexiblecolumns=false, xleftmargin=2ex, basewidth=0.52em, basicstyle=\small\ttfamily} \lstset{literate={->}{{$\rightarrow{}\!\!\!$}}3 } \renewcommand{\tt}{\usefont{OT1}{cmtt}{m}{n}\selectfont} \newcommand{\codefont}{\small\tt} \newcommand{\code}[1]{\mbox{\codefont #1}} \newcommand{\ccode}[1]{``\code{#1}''} % The layout of this manual is adapted from the KiCS2 manual. %%% ------------------------------------------------------------------ \usepackage[colorlinks,linkcolor=blue]{hyperref} \hypersetup{bookmarksopen=true} \hypersetup{bookmarksopenlevel=0} \hypersetup{pdfstartview=FitH} \usepackage{thumbpdf} %%% ------------------------------------------------------------------ \setlength{\textwidth}{16.5cm} \setlength{\textheight}{23cm} \renewcommand{\baselinestretch}{1.1} \setlength{\topmargin}{-1cm} \setlength{\oddsidemargin}{0cm} \setlength{\evensidemargin}{0cm} \setlength{\marginparwidth}{0.0cm} \setlength{\marginparsep}{0.0cm} \begin{document} \title{CPM User's Manual} \author{Jonas Oberschweiber \qquad Michael Hanus\\[1ex] {\small Institut f\"ur Informatik, CAU Kiel, Germany}\\[1ex] {\small\texttt{packages@curry-lang.org}} } \maketitle \tableofcontents \clearpage \section{Introduction} This document describes the Curry package manager (CPM), a tool to distribute and install Curry libraries and manage version dependencies between these libraries. A distinguishing feature of CPM is its ability to perform \emph{semantic versioning checking}, i.e., CPM provides a command to check the semantics of a new package version against an older version of the same package. \bigskip\bigskip \section{Installing the Curry Package Manager} \subsection{Requirements} CPM requires \emph{Git}\footnote{\url{http://www.git-scm.com}}, \emph{curl}\footnote{\url{https://curl.haxx.se}}, \emph{tar}, and \emph{unzip} to be available on the \code{PATH} during installation and operation. It is strongly recommended that SQLite\footnote{\url{https://www.sqlite.org}} is installed so that the executable \code{sqlite3} is in your path. In this case, CPM uses a SQLite database for caching the central package index (see Section~\ref{sec:internals}). This yields faster response times of various CPM commands. CPM is part of recent distributions of the Curry systems PAKCS\footnote{\url{https://www.informatik.uni-kiel.de/~pakcs/}} (since version 1.15.0) and KiCS2\footnote{\url{https://www-ps.informatik.uni-kiel.de/kics2/}} (since version 0.6.0) so that it can directly be used with these Curry systems. If you use an older release of PAKCS or KiCS2 or you want to install some CPM version from the source repository, the following section contains some hints about the installation of CPM. \subsection{Source Code Installation} To install and use CPM, a working installation of either PAKCS in version 1.14.1 or greater, or KiCS2 in version 0.5.1 or greater is required. You need to ensure that your Haskell installation reads files using UTF-8 encoding by default. Haskell uses the system locale charmap for its default encoding. You can check the current value using \code{System.IO.localeEncoding} inside a \code{ghci} session. To install CPM from the sources, enter the root directory of the CPM source distribution. The main executable \code{curry} of your Curry system must be in your path (otherwise, you can also specify the root location of your Curry system by modifying the definition of \code{CURRYROOT} in the \code{Makefile}). Then type \code{make} to compile CPM which generates a binary called \code{cypm} in the \code{bin} subdirectory. Put this binary somewhere on your path. \clearpage \section{Starting the Curry Package Manager} If the binary \code{cypm} is on your path, execute the command % \begin{lstlisting} > cypm update \end{lstlisting} % to pull down a copy of the central package index to your system. You can use the same command to update later your copy of the central package index to the newest version. Afterwards, you can show a list of all packages in this index by % \begin{lstlisting} > cypm list \end{lstlisting} % The command % \begin{lstlisting} > cypm info PACKAGE \end{lstlisting} % can be used to show more information about a package. There is also a command % \begin{lstlisting} > cypm search QUERY \end{lstlisting} % to search inside the central package index. Section~\ref{sec:cmd-reference} contains a complete list of all available CPM commands. \clearpage \section{Package Basics} \label{sec:package-basics} Essentially, a Curry package is nothing more than a directory structure containing a \code{package.json} file and a \code{src} directory at its root. The \code{package.json} file is a JSON file containing package metadata, the \code{src} directory contains the Curry modules that make up the package. We assume familiarity with the JSON file format. A good introduction can be found at \url{http://json.org}. The package specification file must contain a top-level JSON object with at least the keys \code{name}, \code{author}, \code{version}, \code{synopsis} and \code{dependencies}. More possible fields are described in Section~\ref{sec:reference}. A package's name may contain any ASCII alphanumeric character as well as dashes (\code{-}) and underscores (\code{_}). It must start with an alphanumeric character. The author field is a free-form field, but the suggested format is either a name (\code{John Doe}), or a name followed by an email address in angle brackets (\code{John Doe }). Multiple authors can either be separated by commas or written as a list of strings. Versions must be specified in the format laid out in the semantic versioning standard:\footnote{\url{http://www.semver.org}} each version number consists of numeric major, minor and patch versions separated by dot characters as well as an optional pre-release specifier consisting of ASCII alphanumerics and hyphens, e.g. \code{1.2.3} and \code{1.2.3-beta5}. Please note that build metadata as specified in the standard is not supported. The synopsis should be a short summary of what the package does. Use the \code{description} field for longer form explanations. Dependencies are specified as a nested JSON object with package names as keys and dependency constraints as values. A dependency constraint restricts the range of versions of the dependency that a package is compatible to. Constraints consist of elementary comparisons that can be combined into conjunctions, which can then be combined into one large disjunction---essentially a disjunctive normal form. The supported comparison operators are \code{<}, \code{<=}, \code{>}, \code{>=}, \code{=}, \code{\char126}, and \code{\char94}. The first five are interpreted according to the rules for comparing version numbers laid out in the semantic versioning standard. \code{\char126} requires\footnote{% In previous versions of CPM this was denoted as \code{{\char126}>} and called \emph{semantic versioning arrow}.} that the package version be at least as large as its argument but still within the same minor version, i.e., \code{{\char126}1.2.3} would match \code{1.2.3}, \code{1.2.9}, and \code{1.2.55} but not \code{1.2.2}, \code{1.3.0}, or \code{2.1.0}. Analogously, \code{\char94} requires that the package version be at least as large as its argument but still within the same major version, i.e., \code{{\char94}1.2.3} would match \code{1.2.3} and \code{1.4.3} but not \code{2.1.0}. To combine multiple comparisons into a conjunction, separate them by commas, e.g., \begin{lstlisting} >= 2.0.0, < 3.0.0 \end{lstlisting} would match all versions with major version \code{2}. Note that it would not match \code{2.1.3-beta5} for example, since pre-release versions are only matched if the comparison is explicitly made to a pre-release version, e.g., \code{= 2.1.3-beta5} or \code{> 2.1.3-beta2}. Conjunctions can be combined into a disjunction via the \code{||} characters, e.g., \begin{lstlisting} >= 2.0.0, < 3.0.0 || >= 4.0.0 \end{lstlisting} would match any version within major version \code{2} and from major version \code{4} onwards, but no version within major version \code{3}. \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Using Packages} Curry packages can be used as dependencies of other Curry packages or to install applications implemented with a package. In the following we describe both possibilities of using packages. \subsection{Creating New Packages} Creating a new Curry package is easy. To use a Curry package in your project, create a \code{package.json} file in the root, fill it with the minimum amount of information discussed in the previous session, and move your Curry code to a \code{src} directory inside your project's directory. Alternatively, if you are starting a new project, use the \code{cypm new } command, which creates a new project directory with a \code{package.json} file for you.\footnote{The \code{new} command also creates some other useful template files. Look into the output of this command.} Then declare the dependencies inside the new \code{package.json} file, e.g.: \begin{lstlisting} { ..., "dependencies": { "base": "^1.0.0", "html": ">= 2.0.0, < 2.2.0" "json": "~1.1.0" } } \end{lstlisting} % Then run \code{cypm install} to install all dependencies of the current package and start your interactive Curry environment with \code{cypm curry}. You will be able to load the JSON package's modules in your Curry session. \subsection{Installing and Updating Dependencies} To install the current package's dependencies, run \code{cypm install}. This will install the most recent version of all dependencies that are compatible to the package's dependency constraints. Note that a subsequent run of \code{cypm install} will always prefer the versions it installed on a previous run, if they are still compatible to the package's dependencies. If you want to explicitly install the newest compatible version regardless of what was installed on previous runs of \code{cypm install}, you can use the \code{cypm upgrade} command to upgrade all dependencies to their newest compatible versions, or \code{cypm upgrade } to update a specific package and all its transitive dependencies to the newest compatible version. If the package also contains an implementation of a complete executable, e.g., some useful tool, which can be specifed in the \code{package.json} file (see Section~\ref{sec:reference}), then the command \code{cypm install} also compiles the application and installs the executable in the \code{bin} install directory of CPM (see Section~\ref{sec:config} for details). The installation of executables can be suppressed by the \code{cypm install} option \code{-n} or \code{--noexec}. \subsection{Checking out Packages} \label{sec:checkout} In order to use, experiment with or modify an existing package, one can use the command \begin{lstlisting} cypm checkout \end{lstlisting} to install a local copy of a package. This is also useful to install some tool distributed as a package. For instance, to install \code{curry-check}, a property-testing tool for Curry, one can check out the most recent version and install the tool: % \begin{lstlisting} > cypm checkout currycheck $\ldots$ Package 'currycheck-1.0.1' checked out into directory 'currycheck'. > cd currycheck > cypm install $\ldots$ INFO Installing executable 'curry-check into '/home/joe/.cpm/bin' \end{lstlisting} % Now, the tool \code{curry-check} is ready to use if \code{\$HOME/.cpm/bin} is in your path (see Section~\ref{sec:config} for details about changing the location of this default path). \subsection{Installing Applications of Packages} \label{sec:installapp} Some packages do not contain only useful libraries but also application programs or tools. In order to install the executables of such applications without explicitly checking out the package in some local directory, one can use the command \begin{lstlisting} cypm install \end{lstlisting} This command checks out the package in some internal directory (default: \code{\$HOME/.cpm/apps_$Curry system$}, see Section~\ref{sec:config}) and installs the binary of the application provided by the package in \code{\$HOME/.cpm/bin} (see also Section~\ref{sec:checkout}). For instance, the most recent version of the web framework Spicey can be installed by the following command: % \begin{lstlisting} > cypm install spicey $\ldots$ Package 'spicey-xxx' checked out $\ldots$ $\ldots$ INFO Installing executable 'spiceup' into '/home/joe/.cpm/bin' \end{lstlisting} % Now, the binary \code{spiceup} of Spicey can be used if \code{\$HOME/.cpm/bin} is in your path (see Section~\ref{sec:config} for details about changing the location of this default path). \subsection{Executing the Curry System in a Package} To use the dependencies of a package, the Curry system needs to be started via CPM so that it will know where to search for the modules provided. You can use the command \ccode{cypm curry} to start the Curry system (which is either the compiler used to install CPM or specified with the configuration option \code{CURRY_BIN}, see Section~\ref{sec:config}). Any parameters given to \ccode{cypm curry} will be passed along verbatim to the Curry system. For example, the following will start the Curry system, print the result of evaluating the expression \code{39+3} and then quit. \begin{lstlisting} > cypm curry :eval "39+3" :quit \end{lstlisting} % To execute other Curry commands, such as \ccode{curry check}, with the package's dependencies available, you can use the \ccode{cypm exec} command. This command will set the \code{CURRYPATH} environment variable and then execute the command given after \ccode{exec}. \subsection{Using Packages Outside a Package} \label{sec:meta-package} In principle, packages can be used only inside another package by declaring dependencies in the package specification file \code{package.json}. If you invoke \code{cypm} in a directory which contains no package specification file, CPM searches for such a file from the current directory to the parent directories (up to the root of the file system). Thus, if you are outside a package, such a file is not available. In order to support the use other packages outside package, CPM provides a meta-package which is usually stored in your home directory at \code{\char126/.cpm/$Curry system$-homepackage}.\footnote{% Use \code{cypm config} and look at \code{HOME_PACKAGE_PATH} to see the current location of this meta-package.} This meta-package is used when your are not inside another package. Hence, if you write some Curry program which is not a package but you want to use some package \code{P}, you have to add a dependency to \code{P} to this meta-package. CPM does this automatically for you with the CPM command \code{cypm add --dependency} (short: \code{cypm add -d}). For instance, to use the libraries of the JSON package in your application, one can use the following commands: % \begin{lstlisting} > cypm add -d json # add 'json' dependency to meta-package > cypm install # download and install all dependencies > cypm curry # start Curry system with JSON libraries in load path ... Prelude> :load JSON.Data JSON.Data> \end{lstlisting} % The default behavior of the \code{add} command is to add the dependency \emph{and} install all dependencies, i.e., the previous commands can be reduced as follows: % \begin{lstlisting} > cypm add json > cypm curry ... Prelude> :load JSON.Data JSON.Data> \end{lstlisting} \subsection{Replacing Dependencies with Local Versions} \label{sec:cpm-link} During development of your applications, situations may arise in which you want to temporarily replace one of your package's dependencies with a local copy, without having to publish a copy of that dependency somewhere or increasing the dependency's version number. One such situation is a bug in a dependency not controlled by you: if your own package depends on package $A$ and $A$'s current version is $1.0.3$ and you encounter a bug in this version, then you might be able to investigate, find and fix the bug. Since you are not the the author of $A$, however, you cannot release a new version with the bug fixed. So you send off your patch to $A$'s maintainer and wait for $1.0.4$ to be released. In the meantime, you want to use your local, fixed copy of version $1.0.3$ from your package. The \code{cypm link} command allows you to replace a dependency with your own local copy. \code{cypm link} takes a directory containing a copy of one of the current package's dependencies as its argument. It creates a symbolic link from that directory the the current package's local package cache. If you had a copy of \code{A-1.0.3} in the \code{\char126/src/A-1.0.3} directory, you could use \code{cypm link \char126/src/A-1.0.3} to ensure that any time \code{A-1.0.3} is used from the current package, your local copy is used instead of the one from the global package cache. To remove any links, use \code{cypm upgrade} without any arguments, which will clear the local package cache. See Section~\ref{sec:internals} for more information on the global and local package caches. \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Authoring Packages} If you want to create packages for other people to use, you should consider filling out more metadata fields than the bare minimum. See Section~\ref{sec:reference} for a reference of all available fields. \subsection{Semantic Versioning} \label{sec:semantic-versioning} The versions of published packages should adhere to the semantic versioning standard, which lays out rules for which components of a version number must change if the public API of a package changes. Recall that a semantic versioning version number consists of a major, minor and patch version as well as an optional pre-release specifier. In short, semantic versioning defines the following rules: \begin{itemize} \item If the type of any public API is changed or removed or the expected behavior of a public API is changed, you must increase the major version number and reset the minor and patch version numbers to $0$. \item If a public API is added, you must increase at least the minor version number and reset the patch version number to $0$. \item If only bug fixes are introduced, i.e. nothing is added or removed and behavior is only changed to removed deviations from the expected behavior, then it is sufficient to increase the patch version number. \item Once a version is published, it must not be changed. \item For pre-releases, sticking to these rules is encouraged but not required. \item If the major version number is $0$, the package is still considered under development and thus unstable. In this case, the rules do not apply, although following them as much as possible as still encouraged. Release $1.0.0$ is considered to be the first stable version. \end{itemize} % To aid you in following these rules, CPM provides the \code{diff} command. \code{diff} can be used to compare the types and behavior of a package's public API between two versions of that package. If it finds any differences, it checks whether they are acceptable under semantic versioning for the difference in version numbers between the two package versions. To use \code{diff}, you need to be in the directory of one of the versions, i.e., your copy for development, and have the other version installed in CPM's global package cache (see the \code{cypm install} command). For example, if you are developing version $1.3.0$ of the JSON package and want to make sure you have not introduced any breaking changes when compared to the previous version $1.2.6$, you can use the \code{cypm diff 1.2.6} command while in the directory of version $1.3.0$. CPM will then check the types of all public functions and data types in all exported modules of both versions (see the \code{exportedModules} field of the package specification) and report any differences and whether they violate semantic versioning. CPM will also compare the behavior of all exported functions in all exported modules whose types have not changed. Actually, this part is performed by CurryCheck \cite{Hanus16LOPSTR}, a property-based test tool for Curry. For this purpose, CPM generates a Curry program containing properties stating the equivalence of two operations with the same name but defined in two different versions of a package. The ideas and scheme of this generation process are described in \cite{Hanus17ICLP}. Note that not all functions can be compared via CurryCheck. In particular, functions taking other functions as arguments (there are a few other minor restrictions) can not be checked so that CPM automatically excludes them from checking. Note that the results of non-terminating operations, like \code{Prelude.repeat}, cannot be compared in a finite amount of time. To avoid the execution of possibly non-terminating check programs, CPM compares the behavior of operations only if it can prove the termination or productivity\footnote{% An operation is productive if it always produces outermost constructors, i.e., it cannot run forever without producing constructors.} of these operations. Since CPM uses simple criteria to approximate these properties, there might be operations that are terminating or productive but CPM cannot show it. In these cases you can use the compiler pragmas \verb|{-# TERMINATE -#}| or \verb|{-# PRODUCTIVE -#}| to annotate such functions. Then CPM will trust these annotations and treat the annotated operations as terminating or productive, respectively. For instance, CPM will check the following operation although it cannot show its termination: \begin{lstlisting} {-# TERMINATE -#} mcCarthy :: Int -> Int mcCarthy n | n<=100 = mcCarthy (mcCarthy (n+11)) | n>100 = n-10 \end{lstlisting} % As another example, consider the following operation defining an infinite list: \begin{lstlisting} ones :: [Int] ones = 1 : ones \end{lstlisting} % Although this operation is not terminating, it is productive since with every step a new constructor is produced. CPM compares such operations by comparing their results up to some depth. On the other hand, the following operation is not classified as productive by CPM (note that it would not be productive if the filter condition is changed to \code{(>1)}): \begin{lstlisting} {-# PRODUCTIVE -#} anotherOnes :: [Int] anotherOnes = filter (>0) ones \end{lstlisting} % Due to the pragma, CPM will compare this operation as other productive operations. There might be situations when operations should not be compared, e.g., if the previous version of the operation was buggy. In this case, one can mark those functions with the compiler pragma \verb|{-# NOCOMPARE -#}| so that CPM will not generate tests for them. Note that there are different ways to state the equivalence of operations (e.g., see the discussion in \cite{BacciEtAl12}). CPM offers two kinds of equivalence tests: \begin{itemize} \item \emph{Ground equivalence} means that two operations are considered as equivalent if they yield identical values for identical input values. \item \emph{Contextual or full equivalence} means that two operations are considered as equivalent if they produce the same results in all possible contexts. \end{itemize} % Since contextual equivalence is more meaningful in the context of semantic versioning, CPM tests this kind of equivalence in the default case, based on the techniques described in \cite{AntoyHanus18FLOPS}. However, using the option \code{--ground} of the \code{diff} command, one can also enfore the checking of ground equivalence as described in \cite{Hanus17ICLP}. \subsection{Adding Packages to the Central Package Index} \label{sec:adding-a-package} When you have your package ready and want to use it in other packages, it must be added to the central package index so that CPM can find it when searching for packages. For this purpose, you can use the \ccode{cypm add} command: % \begin{lstlisting} > cypm add --package mypackage \end{lstlisting} % In this case, \code{mypackage} is the name of the directory containing you package. In particular, the JSON file \ccode{mypackage/package.json} must contain the metadata of the package (see also Section~\ref{sec:reference}). This command copies your package into your local copy of the central package index so that it can be used in other packages. If you want to replace this copy by an improved version of the same package, you have to provide the option \code{-f} or \code{--force}. Note that this command makes your package only available on your local system. If you want to publish your package so that it can be used by other CPM users, follow the instruction described next. \subsection{Publishing a Package} \label{sec:publishing-a-package} There are three things that need to be done to publish a package: make the package accessible somewhere, add the location to the package specification, and add the package specification to the central package index. CPM supports ZIP (suffix \ccode{.zip}) or compressed TAR (suffix \ccode{.tar.gz}) files accessible over HTTP as well as Git repositories as package sources. You are free to choose one of those, but a publicly accessible Git repository is preferred. To add the location to the package specification, use the \code{source} key. For a HTTP source, use: % \begin{lstlisting} { ..., "source": { "http": "http://example.com/package-1.0.3.zip" } } \end{lstlisting} % For a Git source, you have to specify both the repository as well as the revision that represents the version: % \begin{lstlisting} { ..., "source": { "git": "git+ssh://git@github.com:john-doe/package.git", "tag": "v1.2.3" } } \end{lstlisting} % There is also a shorthand, \code{\$version}, available to automatically use a tag consisting of the letter \code{v} followed by the current version number, as in the example above. Specifying \code{\$version} as the tag and then tagging each version in the format \code{v1.2.3} is preferred, since it does not require changing the source location in the \code{package.json} file every time a new version is released. If one already has a repository with another tagging scheme, one can also place the string \code{\$version\$} in the tag, which will be automatically replaced by the current version number. Thus, the tag \ccode{\$version} is equivalent to the tag \ccode{v\$version\$}. After you have published the files for your new package version, you have to add the corresponding package specification to the central package index. This can be done with the \ccode{cypm add} command (see Section~\ref{sec:adding-a-package}). If you have access to the Git repository containing the central package index, then you can push the modified version of this Git repository. Otherwise, send your package specification file to \url{packages@curry-lang.org} in order to publish it. \clearpage \section{The \texttt{base} Package} \label{sec:basepackage} Every Curry distribution comes with some libraries to support basic operations, like list operations, actions to read and write files, etc. The most prominent library is the \code{Prelude} which is implicitly added to the import list of a Curry module. In order to manage different versions of these base libraries, there is a distinguished package \code{base} containing these libraries. Thus, one can include a dependency to a specific version of the \code{base} package in the \code{package.json} file, e.g.: % \begin{lstlisting} { ..., "dependencies": { "base": ">= 2.1.0, < 3.0.0", "html": ">= 2.0.0, < 2.2.0" "json": "~1.1.0" } ... } \end{lstlisting} % Each Curry system comes with a specific version of the \code{base} package. This version can be queried with the option \code{--base-version}, e.g., % \begin{lstlisting} > pakcs --base-version 3.0.0 \end{lstlisting} % If CPM tries to install a package, it adds the condition that the version of package \code{base} must be identical to the \code{base} version of the compiler used by CPM. For instance, if \code{pakcs} is used by CPM (see Section~\ref{sec:config} how to change the default compiler of CPM), the dependencies shown above are changed to % \begin{lstlisting} { ..., "dependencies": { "base": "= 3.0.0, >= 2.1.0, < 3.0.0", "html": ">= 2.0.0, < 2.2.0" "json": "~1.1.0" } ... } \end{lstlisting} % before resolving all constraints. Of course, in this case, the constraints are not solvable so that one has to choose another Curry compiler for this package. \clearpage \section{Configuration} \label{sec:config} CPM can be configured via the \code{\$HOME/.cpmrc} configuration file. The following list shows all configuration options and their default values. \begin{description} \item[\fbox{\code{CURRY_BIN}}] The name of the executable of the Curry system used to compile and test packages. The default value is the binary of the Curry system which has been used to compile CPM. \item[\fbox{\code{REPOSITORY_PATH}}] The path to the index of all packages. Default value: \code{\$HOME/.cpm/index}. \item[\fbox{\code{PACKAGE_INSTALL_PATH}}] The path to the global package cache. This is where all downloaded packages are stored. Default value: \code{\$HOME/.cpm/packages} \item[\fbox{\code{BIN_INSTALL_PATH}}] The path to the executables of packages. This is the location where the compiled executables of packages containing full applications are stored. Hence, in order to use such applications, one should have this path in the personal load path (environment variable \code{PATH}). Default value: \code{\$HOME/.cpm/bin} \item[\fbox{\code{APP_PACKAGE_PATH}}] The path to the package cache where packages are checked out if only their binaries are installed (see Section~\ref{sec:installapp}). Default value: \code{\$HOME/.cpm/apps_$Curry system$}. \item[\fbox{\code{HOME_PACKAGE_PATH}}] The path to the meta-package which is used if you are outside another package (see Section~\ref{sec:meta-package}). Default value: \code{\$HOME/.cpm/$Curry system$-homepackage}. \item[\fbox{\code{PACKAGE_INDEX_URL}}] The URL of the central package index which is used by the \code{update} command to download the index of all repositories. Default value: \begin{lstlisting} https://www-ps.informatik.uni-kiel.de/~cpm/PACKAGES/INDEX.tar.gz \end{lstlisting} One can also provide more than one URL which are tried in sequential order until one index could be downloaded. In this case, the URLs should be separated by a vertical bar (\ccode{|}). \item[\fbox{\code{PACKAGE_TARFILES_URL}}] The URL prefix to the directory containing the ``tar'' files of all packages. If a package $p$ with version $v$ is downloaded (via the \code{install} or \code{checkout} command), the source of the package is downloaded from this location as file \code{$p$-$v$.tar.gz}. Default value: \begin{lstlisting} https://www-ps.informatik.uni-kiel.de/~cpm/PACKAGES/ \end{lstlisting} For instance, the package \code{cpm} with version \code{2.2.0} is downloaded from \begin{lstlisting} https://www-ps.informatik.uni-kiel.de/~cpm/PACKAGES/cpm-2.2.0.tar.gz \end{lstlisting} One can also provide more than one URL prefix which are tried in sequential order until the package could be downloaded from one of them. In this case, the URL prefixes should be separated by a vertical bar (\ccode{|}). \end{description} % The CPM command \begin{lstlisting} > cypm config \end{lstlisting} shows the current values of the configuration options. Note that one write the option names also in lowercase or omit the underscores. For instance, one can write \code{currybin} instead of \code{CURRY_BIN}. Moreover, one can override the values of these configuration options by the CPM options \code{-d} or \code{--define}. For instance, to install the binary of the package \code{spicey} in the directory \code{\$HOME/bin}, one can execute the command \begin{lstlisting} > cypm --define bin_install_path=$\$$HOME/bin install spicey \end{lstlisting} \clearpage \section{Some CPM Internals} \label{sec:internals} CPM's central package index contains all package specification files. It is stored at a central server where the actual location is defined by CPM's configuration variable \code{PACKAGE_INDEX_URL}, see Section~\ref{sec:config}. When the command \begin{lstlisting} > cypm update \end{lstlisting} is executed, a copy of this index is downloaded and stored on your local system in the directory \code{\$HOME/.cpm/index}, unless you changed the location using the \code{REPOSITORY_PATH} setting. CPM uses the package index when searching for and installing packages and during dependency resolution. This index contains a directory for each package, which contain subdirectories for all versions of that package which in turn contain the package specification files. So the specification for version $1.0.5$ of the \code{json} package would be located in \code{json/1.0.5/package.json}. When a package is installed on the system, it is stored in the \emph{global package cache}. By default, the global package cache is located in \code{\$HOME/.cpm/packages}. When a package \emph{foo}, stored in directory \code{foo}, depends on a package \emph{bar}, a link to \emph{bar's} directory in the global package cache is added to \emph{foo's} local package cache when dependencies are resolved for \emph{foo}. The \emph{local package cache} is stored in \code{foo/.cpm/package_cache}. Whenever dependencies are resolved, package versions already in the local package cache are preferred over those from the central package index or the global package cache. When a module inside a package is compiled, packages are first copied from the local package cache to the \emph{run-time cache}, which is stored in \code{foo/.cpm/packages}. Ultimately, the Curry compiler only sees the package copies in the run-time cache, and never those from the local or global package caches. \clearpage \section{Command Reference} \label{sec:cmd-reference} This section gives a short description of all available CPM commands. In addition to the commands listed below, there are some global options which can be placed in front of the CPM command: \begin{description} \item[\code{-d$\,|\,$--define $option$=$value$}:] This option overrides the configuration options of CPM, see Section~\ref{sec:config}. \item[\code{-v$\,|\,$--verbosity [info|debug]}:] The default value is \code{info}. The value \code{debug} provides more output messages in order to see what CPM is doing. \item[\code{-t$\,|\,$--time}:] This option adds the elapsed time to every info or debug output line. \end{description} % The available commands of CPM are: \begin{description} \item[\fbox{\code{config}}] Shows the current configuration of CPM (see also Section~\ref{sec:config}). The option \code{--all} shows also the names and version of the packages installed in the global package cache. \item[\fbox{\code{info}}] Gives information on the current package, e.g. the package's name, author, synopsis and its dependency specifications. \item[\fbox{\code{info $package$ [--all]}}] Prints information on the newest known version (compatible to the current compiler) of the given package. The option \code{--all} shows more information. \item[\fbox{\code{info $package$ $version$ [--all]}}] Prints basic information on the given package version. The option \code{--all} shows more information. \item[\fbox{\code{list [--system] [--versions] [--csv]}}] List the names and synopses of all packages of the central package index. Unless the option \code{--versions} is set, only the newest version of a package is shown. The option \code{--system} restricts the list to those packages which are compatible with the current compiler (if it is explicitly specified in the package). The option \code{--versions} shows all versions of the packages. If a package is not compatible to the current compiler, then the package version is shown in brackets (e.g., \ccode{(1.5.4)}). The option \code{--csv} shows the information in CSV format. \item[\fbox{\code{list --category [--csv]}}] List the category names together with the packages belonging to this category (see Section~\ref{sec:reference}) of the central package index. The option \code{--csv} shows the information in CSV format. \item[\fbox{\code{search [--module|--exec] $query$}}] Searches the names, synopses, and exported module names of all packages of the central package index for occurrences of the given search term. If the option \code{--module} is set, then the given name is searched in the list of exported modules. Thus, the package exporting the module \code{JSON.Data} can be found by the command % \begin{lstlisting} > cypm search --module JSON.Data \end{lstlisting} % If the option \code{--exec} is set, then the search is restricted to the name of the executable provided by the package. For instance, the command % \begin{lstlisting} > cypm search --exec show \end{lstlisting} % lists all packages where the name of the executable contains the string \ccode{show}. \item[\fbox{\code{update}}] Updates the local copy of the central package index to the newest available version. This command also cleans the global package cache in order to support the download of fresh package versions. Note that this also removes local copies of packages installed by the command \ccode{add --package}. The option \code{--url} allows to specify a different URL for the central package index (might be useful for experimental purposes). \item[\fbox{\code{install}}] Installs all dependencies of the current package. Furthermore, if the current package contains an executable application, the application is compiled and the executable is installed (unless the option \code{-n} or \code{--noexec} is set). With the option \code{-x} or \code{--exec}, the executable is installed without installing all dependencies again. This is useful to speed up the re-installation of a previously installed application. \item[\fbox{\code{install $package$ [--$pre$]}}] Installs the application provided by the newest version (compatible to the current compiler) of a package. The binary of the application is installed into the directory \code{\$HOME/.cpm/bin} (this location can be changed via the \code{\$HOME/.cpmrc} configuration file or by the CPM option \code{--define}, see Section~\ref{sec:config}). \code{--$pre$} enables the installation of pre-release versions. \item[\fbox{\code{install $package$ $version$}}] Installs the application provided by a specific version of a package. The binary of the application is installed into the directory \code{\$HOME/.cpm/bin} (this location can be changed via the \code{\$HOME/.cpmrc} configuration file or by the CPM option \code{--define}, see Section~\ref{sec:config}). \item[\fbox{\code{install $package$.zip}}] Installs a package from a ZIP file to the global package cache. The ZIP file must contain at least the package description file \code{package.json} and the directory \code{src} containing the Curry source files. \item[\fbox{\code{uninstall}}] Uninstalls the executable installed for the current package. \item[\fbox{\code{uninstall $package$}}] Uninstalls the executable and the cached copy of a package which has been installed by the \code{install} command. \item[\fbox{\code{uninstall $package$ $version$}}] Uninstalls a specific version of a package from the global package cache. \item[\fbox{\code{checkout $package$ [--$pre$]}}] Checks out the newest version (compatible to the current compiler) of a package into the local directory \code{$package$} in order to test its operations or install a binary of the package. \code{--$pre$} enables the installation of pre-release versions. \item[\fbox{\code{checkout $package$ $version$}}] Checks out a specific version of a package into the local directory \code{$package$} in order to test its operations or install a binary of the package.. \item[\fbox{\code{upgrade}}] Upgrades all dependencies of the current package to the newest compatible version. \item[\fbox{\code{upgrade $package$}}] Upgrades a specific dependency of the current package and all its transitive dependencies to their newest compatible versions. \item[\fbox{\code{deps}}] Does a dependency resolution run for the current package and prints out the results. The result is either a list of all package versions chosen or a description of the conflict encountered during dependency resolution. Using the option \code{--path]}, only the value of \code{CURRYPATH} required to load modules of this package is shown. \item[\fbox{\code{test}}] Tests the current package with CurryCheck. If the package specification contains a definition of a test suite (entry \code{testsuite}, see Section~\ref{sec:reference}), then the modules defined there are tested. If there is no test suite defined, the list of exported modules are tested, if they are explicitly specified (field \code{exportedModules} of the package specification), otherwise all modules in the directory \code{src} (including hierarchical modules stored in its subdirectories) are tested. Using the option \code{--modules}, one can also specify a comma-separated list of module names to be tested. \item[\fbox{\code{doc}}] Generates the documentation of the current package. The documentation consists of the API documentation (in HTML format) and the manual (if provided) in PDF format. The options \code{--programs} and \code{--text} forces to generate only the API documentation and the manual, respectively. Using the option \code{--docdir}, one can specify the target directory where the documentation should be stored. If this option is not provided, \ccode{cdoc} is used as the documentation directory. The actual documentation will be stored in the subdirectory \code{$name$-$version$} of the documentation directory. The API documentation in HTML format is generated with CurryDoc. If the package specification contains a list of exported modules (see Section~\ref{sec:reference}), then these modules are documented. Otherwise, the main module (if the package specification contains the entry \code{executable}, see Section~\ref{sec:reference}) or all modules in the directory \code{src} (including hierarchical modules stored in its subdirectories) are documented. Using the option \code{--modules}, one can also specify a comma-separated list of module names to be documented. In the default case, modules contained in packages used by the current package are not documented. Instead, it is assumed that these packages are already documented\footnote{See \url{http://www.informatik.uni-kiel.de/~curry/cpm/} for the documentation of all packages. This default location can be changed with the option \code{--url}.} so that links to these package documentations are generated. Using the option \code{--full}, one can generate also the documentation of packages used by the current package. This might be reasonable if one uses packages which are only locally installed. The manual is generated only if the package specification contains a field \code{documentation} where the main file of the manual is specified (see Section~\ref{sec:reference} for more details). \item[\fbox{\code{diff [$version$]}}] Compares the API and behavior of the current package to another version of the same package. If the version option is missing, the latest version of the current package found in the repository is used for comparison. If the options \code{--api-only} or \code{--behavior-only} are added, then only the API or the behavior are compared, respectively. In the default case, all modules commonly exported by both versions of the package are compared. Using the option \code{--modules}, one can restrict this comparison to a list of modules specified by a comma-separated list of module names. As described in Section~\ref{sec:semantic-versioning}, CPM uses property tests to compare the behavior of different package versions. In order to avoid infinite loops durings these tests, CPM analyzes the termination behavior of the involved operations. Using the operation \code{--unsafe}, CPM omits this program analysis but then you have to ensure that all operations are terminating (or you can annotate them by pragmas, see Section~\ref{sec:semantic-versioning}). In the default case, CPM tests the contextual equivalence of operations (see Section~\ref{sec:semantic-versioning}). With the option \code{--ground}, the ground equivalence of operations is tested. \item[\fbox{\code{exec $command$}}] Executes an arbitrary command with the \code{CURRYPATH} environment variable set to the paths of all dependencies of the current package. For example, it can be used to execute \ccode{curry check} or \ccode{curry analyze} with correct dependencies available. \item[\fbox{\code{curry $args$}}] Executes the Curry compiler with the dependencies of the current package available. Any arguments are passed verbatim to the compiler. \item[\fbox{\code{link $source$}}] Can be used to replace a dependency of the current package using a local copy, see Section~\ref{sec:cpm-link} for details. \item[\fbox{\code{add --package $dir$ [--force]}}] Copies the package contained in directory $dir$ into the local copy of the central package index so that it can be used by other packages in the local environment (see Section~\ref{sec:adding-a-package} for details). The option \ccode{--force} allows to overwrite existing copies in the central package index. \item[\fbox{\code{add --dependency $package$ [--force]}}] Adds the package $package$ as a new dependency. This command adds a dependency to the given package either in the package description file (\code{package.json}) of the current package or in the meta-package (see Section~\ref{sec:meta-package}). The option \ccode{--force} allows to overwrite existing dependencies in the package description file. \item[\fbox{\code{add $package$ [--force]}}] Adds the package $package$ as a new dependency and install the new dependencies. Thus, this abbreviates the two commands \begin{lstlisting} cypm add $package$ && cypm install \end{lstlisting} \item[\fbox{\code{upload [--notagging] [--force]}}] Uploads the current package to the central package index so that it can be used by other developers via CPM (if they update their local copy of the central package index by \ccode{cypm update}). For security reasons (this will be weakened in the future), the package must have a source specification (see Section~\ref{sec:publishing-a-package}) of the following form: % \begin{lstlisting} { ..., "source": { "git": "$\ldots$git.ps.informatik.uni-kiel.de/curry-packages/$\ldots$.git", "tag": "$\$$version" } } \end{lstlisting} % Thus, the source is managed as a Git repository which is stored at the server \code{git.ps.informatik.uni-kiel.de} in group \code{curry-packages} and has an automatic version tag. Unless the option \code{--nottagging} is given, the version tag wil be automatically set in the local repository (and pushed to the remote repository, i.e., one should have write access to the remote repository). Then the remote repository will be cloned and tested (by \ccode{cypm test}). If this is successful, the package specification of the repository will be added to the central package index (by a web service of the central package index). The option \ccode{--force} allows to overwrite an existing version in the central package index. \item[\fbox{\code{clean}}] Cleans the current package from the generated auxiliary files, e.g., intermediate Curry files, installed dependent packages, etc. Note that a binary installed in the CPM \code{bin} directory (by the \code{install} command) will not be removed. Hence, this command can be used to clean an application package after installing the application. \item[\fbox{\code{new $project$}}] Creates a new project package with the given name and some template files. \end{description} \clearpage \section{Package Specification Reference} \label{sec:reference} This section describes all metadata fields available in a CPM package specification. Mandatory fields are marked with a \code{*} character. \begin{description} \item[\fbox{\code{name*}}] The name of the package. Must only contain ASCII letters, digits, hyphens and underscores. Must start with a letter. \item[\fbox{\code{version*}}] The version of the package. Must follow the format for semantic versioning version numbers. \item[\fbox{\code{author*}}] The package's author. This is a free-form field, the suggested format is either a name or a name followed by an email address in angle brackets, e.g., \begin{lstlisting} John Doe \end{lstlisting} Multiple authors can either be separated by commas or written as a list of strings. \item[\fbox{\code{maintainer}}] The current maintainers of the package, if different from the original authors. This field allows the current maintainers to indicate the best person or persons to contact about the package while attributing the original authors. The suggested format is similarly to the authors, i.e., a name followed by an email address in angle brackets, e.g., \begin{lstlisting} John Doe \end{lstlisting} Multiple maintainers can either be separated by commas or written as a list of strings. \item[\fbox{\code{synopsis*}}] A short form summary of the package's purpose. It should be kept as short as possible (ideally, less than 100 characters). \item[\fbox{\code{description}}] A longer form description of what the package does. \item[\fbox{\code{category}}] A list of keywords that characterize the main area where the package can be used, e.g., \code{Data}, \code{Numeric}, \code{GUI}, \code{Web}, etc. \item[\fbox{\code{license}}] The license under which the package is distributed. This is a free-form field. In case of a well-known license such as the GNU General Public License\footnote{\url{https://www.gnu.org/licenses/gpl-3.0.en.html}}, the SPDX license identifier\footnote{\url{https://spdx.org/licenses/}} should be specified. If a custom license is used, this field should be left blank in favor of the license file field. \item[\fbox{\code{licenseFile}}] The name of a file in the root directory of the package containing explanations regarding the license of the package or the full text of the license. The suggested name for this file is \code{LICENSE}. \item[\fbox{\code{copyright}}] Copyright information regarding the package. \item[\fbox{\code{homepage}}] The package's web site. This field should contain a valid URL. \item[\fbox{\code{bugReports}}] A place to report bugs found in the package. The suggested formats are either a valid URL to a bug tracker or an email address. \item[\fbox{\code{repository}}] The location of a SCM repository containing the package's source code. Should be a valid URL to either a repository (e.g. a Git URL), or a website representing the repository. \item[\fbox{\code{dependencies*}}] The package's dependencies. This must be JSON object where the keys are package names and the values are version constraints. See Section~\ref{sec:package-basics} for more details. \item[\fbox{\code{compilerCompatibility}}] The package's compatibility to different Curry compilers. Expects a JSON object where the keys are compiler names and the values are version constraints. Currently, the supported compiler names are \code{pakcs} and \code{kics2}. If this field is missing or contains an empty JSON object, the package is assumed to be compatible to all compilers in all versions. The compiler compatibility of a package is also relevant when some version of a package should be examined or installed (with CPM commands \code{info}, \code{checkout}, \code{install}). If a newest package should be installed, i.e., no specific version number is provided, then only the newest version which is compatible to the current Curry compiler (see also Section~\ref{sec:config} for configuration option \code{CURRY_BIN}) is considered. Similarly, the current package is executed (CPM commands \code{curry} and \code{test}) only if the current Curry compiler is compatible to this package. \item[\fbox{\code{source}}] A JSON object specifying where the version of the package described in the specification can be obtained. See Section~\ref{sec:publishing-a-package} for details. \item[\fbox{\code{sourceDirs}}] A list of directories inside this package where the source code is located. When the package is compiled, these directories are put at the front of the Curry load path. If this field is not specified, \code{src} is used as the single source directory. \item[\fbox{\code{exportedModules}}] A list of modules intended for use by consumers of the package. These are the modules compared by the \code{cypm diff} command (and tested by the \code{cypm test} command if a list of test modules is not provided). Note that modules not in this list are still accessible to consumers of the package. \item[\fbox{\code{configModule}}] A module name into which some information about the package configuration (location of the package directory, name of the executable, see below) is written when the package is installed. This could be useful if the package needs some data files stored in this package during run time. For instance, a possible specification could be as follows: % \begin{lstlisting} { ..., "configModule": "CPM.PackageConfig", ... } \end{lstlisting} % In this case, the package configuration is written into the Curry file \code{src/CPM/PackageConfig.curry}. \item[\fbox{\code{executable}}] A JSON object specifying the name of the executable and the main module if this package contains also an executable application. The name of the executable must be defined (with key \code{name}) whereas the name of the main module (key \code{main}) is optional. If the latter is missing, CPM assumes that the main module is \code{Main}. Furthermore, the executable specification can also contain options for various Curry compilers. The options must be a JSON object consisting of compiler names as keys and an option string for the compiler. For instance, a possible specification could be as follows: % \begin{lstlisting} { ..., "executable": { "name": "cypm", "main": "CPM.Main", "options": { "kics2" : ":set rts -T" } } } \end{lstlisting} % If a package contains an \code{executable} specification, the command \code{cypm install} also compiles the main module and installs the executable in the \code{bin} install directory of CPM (see Section~\ref{sec:config} for details). \item[\fbox{\code{executables}}] It is also possible to specify more than one executable in package which will be installed by the command \code{cypm install}. In this case, one can use \code{executables} instead of \code{executable}. The value of \code{executables} is an array of JSON objects as used as \code{executable} values. For instance, a possible specification could be % \begin{lstlisting} { ..., "executables": [ { "name": "compiler", "main": "Compiler.Main" }, { "name": "repl", "main": "REPL.Main" } ] } \end{lstlisting} \item[\fbox{\code{testsuite}}] A JSON object specifying a test suite for this package. This object contains a directory (with key \code{src-dir}) in which the tests are executed. Furthermore, the test suite must also define a list of modules to be tested (with key \code{modules}). For instance, a possible test suite specification could be as follows: % \begin{lstlisting} { ..., "testsuite": { "src-dir": "test", "modules": [ "testDataConversion", "testIO" ] } } \end{lstlisting} % All these modules are tested with CurryCheck by the command \code{cypm test}. If no test suite is defined, all (exported) modules are tested in the directory \code{src}. A test suite can also contain a field \code{options} which defines a string of options passed to the call to CurryCheck. If a test suite contains a specific test script instead modules to be tested with CurryCheck, then one can specify the name of this test script in the field \code{script}. In this case, this script is executed in the test directory (with the possible \code{options} value added). The script should return the exit code \code{0} if the test is successful, otherwise a non-zero exit code. Note that one has to specify either a (non-empty) list of modules or a test script name in a test suite, but not both. One can also specify several test suites for a package. In this case, the \code{testsuite} value is an array of JSON objects as described above. For instance, a test suite specification for tests in the directories \code{test} and \code{examples} could be as follows: % \begin{lstlisting} { ..., "testsuite": [ { "src-dir": "test", "options": "-v", "script": "test.sh" }, { "src-dir": "examples", "options": "-m80", "modules": [ "Nats", "Ints" ] } ] } \end{lstlisting} \item[\fbox{\code{documentation}}] A JSON object specifying the name of the directory which contains the sources of the documentation (e.g., a manual) of the package, the main file of the documentation, and an optional command to generate the documentation. For instance, a possible specification could be as follows: % \begin{lstlisting} { ..., "documentation": { "src-dir": "docs", "main" : "manual.tex", "command": "pfdlatex -output-directory=OUTDIR manual.tex" } ... } \end{lstlisting} % In this case, the directory \code{docs} contains the sources of the manual and \code{manual.tex} is its main file which will be processed with the specified command. Occurrences of the string \code{OUTDIR} in the command string will be replaced by the actual documentation directory (see description of the command \code{cypm doc}). If the command is omitted, the following commands are used (and you have to ensure that these programs are installed): \begin{itemize} \item If the main file has the extension \code{.tex}, e.g., \code{manual.tex}, the command is \begin{lstlisting} pdflatex -output-directory=OUTDIR manual.tex \end{lstlisting} and it will be executed twice. \item If the main file has the extension \code{.md}, e.g., \code{manual.md}, the command is \begin{lstlisting} pandoc manual.md -o OUTDIR/manual.pdf \end{lstlisting} \end{itemize} \end{description} % In order to get a compact overview over all metadata fields, we show an example of a package specification where all fields are used: % \begin{lstlisting} { "name": "PACKAGE_NAME", "version": "0.0.1", "author": "YOUR NAME ", "maintainer": [ "ANOTHER NAME ", "FURTHER NAME " ], "synopsis": "A ONE-LINE SUMMARY ABOUT THE PACKAGE", "description": "A MORE DETAILED SUMMARY ABOUT THE PACKAGE", "category": [ "Category1", "Category2" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "copyright": "COPYRIGHT INFORMATION", "homepage": "THE URL OF THE WEB SITE OF THE PACKAGE", "bugReports": "EMAIL OR BUG TRACKER URL FOR REPORTING BUGS", "repository": "THE (GIT) URL OF THE WEB SITE REPOSITORY", "dependencies": { "PACKAGE1" : ">= 0.0.1, < 1.5.0", "PACKAGE2" : "~1.2.3", "PACKAGE3" : ">= 2.1.4, < 3.0.0 || >= 4.0.0", "PACKAGE2" : "^2.1.3", }, "compilerCompatibility": { "pakcs": ">= 1.14.0, < 2.0.0", "kics2": ">= 0.5.0, < 2.0.0" }, "sourceDirs" : [ "src", "include" ], "exportedModules": [ "Module1", "Module2" ], "configModule": "ConfigPackage", "executable": { "name": "NAME_OF_BINARY", "main": "Main", "options": { "kics2" : ":set rts -T", "pakcs" : ":set printdepth 100" } }, "testsuite": [ { "src-dir": "src", "options": "-m80", "modules": [ "Module1", "Module2" ] }, { "src-dir": "examples", "options": "-v", "script" : "test.sh" } ], "documentation": { "src-dir": "docs", "main" : "manual.tex", "command": "pfdlatex -output-directory=OUTDIR manual.tex" }, "source": { "git": "URL OF THE GIT REPOSITORY", "tag": "$\$$version" } } \end{lstlisting} \clearpage \section{Error Recovery} \label{sec:recovery} There might occur situations when your package or repository is in an inconsistent state, e.g., when you manually changed some internal files or such files have been inadvertently changed or deleted, or a package is broken due to an incomplete download. Since CPM checks these files, CPM might exit with an error message that something is wrong. In such cases, it might be a good idea to clean up your package file system. Here are some suggestions how to do this: \begin{description} \item[\code{cypm clean}]~\\ This command cleans the current package from generated auxiliary files (see Section~\ref{sec:cmd-reference}). Then you can re-install the package and packages on which it depends by the command \code{cypm install}. \item[\code{rm -rf \$HOME/.cpm/packages}] ~\\ This cleans all packages which have been previously installed in the global package cache (see Section~\ref{sec:internals}). Such an action might be reasonable in case of some download failure. After clearing the global package cache, all necessary packages are downloaded again when they are needed. \item[\code{rm -rf \$HOME/.cpm/index}] ~\\ This removes the central package index of CPM (see Section~\ref{sec:internals}). You can simply re-install the newest version of this index by the command \code{cypm update}. \end{description} \newpage \begin{thebibliography}{1} \bibitem{AntoyHanus18FLOPS} S.~Antoy and M.~Hanus. \newblock Equivalence Checking of Non-deterministic Operations. \newblock In {\em Proc. of the 14th International Symposium on Functional and Logic Programming (FLOPS 2018)}, pp. 149--165. Springer LNCS 10818, 2018. \bibitem{BacciEtAl12} G.~Bacci, M.~Comini, M.A. Feli{\'u}, and A.~Villanueva. \newblock Automatic Synthesis of Specifications for First Order {Curry}. \newblock In {\em Principles and Practice of Declarative Programming (PPDP'12)}, pp. 25--34. ACM Press, 2012. \bibitem{Hanus16LOPSTR} M.~Hanus. \newblock {CurryCheck}: Checking Properties of {Curry} Programs. \newblock In {\em Proceedings of the 26th International Symposium on Logic-Based Program Synthesis and Transformation (LOPSTR 2016)}, pp. 222--239. Springer LNCS 10184, 2017. \bibitem{Hanus17ICLP} M.~Hanus. \newblock Semantic Versioning Checking in a Declarative Package Manager. \newblock In {\em Technical Communications of the 33rd International Conference on Logic Programming (ICLP 2017)}, OpenAccess Series in Informatics (OASIcs), pp. 6:1--6:16. Schloss Dagstuhl - Leibniz-Zentrum fuer Informatik, 2017. \end{thebibliography} \end{document} % LocalWords: CPM versioning curry-tools-v3.3.0/cpm/misc/000077500000000000000000000000001377556325500157415ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/misc/MeasureNestingDepth.curry000066400000000000000000000127231377556325500227520ustar00rootroot00000000000000module MeasureNestingDepth where import System.Directory import Debug.Trace import Data.List import Curry.Compiler.Distribution import System.FilePath import AbstractCurry.Types import AbstractCurry.Select import AbstractCurry.Files sysLibPath = case curryCompiler of "pakcs" -> installDir "lib" "kics" -> installDir "src" "lib" "kics2" -> installDir "lib" _ -> error "unknown curryCompiler" main = do putStrLn "Reading all standard libary modules..." mods <- readAllStandardModules putStrLn "Calculating depths..." depths <- return $ concatMap (typeDepths mods . snd) mods orderedDepths <- return $ sortBy (\a b -> snd a >= snd b) depths putStrLn $ "The following are the 40 type with the deepest level of nesting " ++ "out of all " ++ (show $ length depths) ++ " types." putStrLn $ show $ take 40 orderedDepths typeDepths :: [(String, CurryProg)] -> CurryProg -> [(QName, Int)] typeDepths progs (CurryProg _ _ ts _ _) = zip (map typeName ts) (map (typeDepth [] progs) ts) typeDepth :: [QName] -> [(String, CurryProg)] -> CTypeDecl -> Int typeDepth seen progs (CType n _ _ cs) = if n `elem` seen then 0 else 1 + (foldl max 0 $ map (typeConsDepth (n:seen) progs) cs) typeDepth seen progs (CTypeSyn n _ _ e) = if n `elem` seen then 0 else 1 + (typeExprDepth (n:seen) progs e) typeDepth seen progs (CNewType n _ _ c) = if n `elem` seen then 0 else 1 + (typeConsDepth (n:seen) progs c) typeConsDepth :: [QName] -> [(String, CurryProg)] -> CConsDecl -> Int typeConsDepth seen progs (CCons _ _ es) = foldl max 0 $ map (typeExprDepth seen progs) es typeConsDepth seen progs (CRecord _ _ fs) = foldl max 0 $ map fieldDepth fs where fieldDepth (CField _ _ e) = typeExprDepth seen progs e typeExprDepth :: [QName] -> [(String, CurryProg)] -> CTypeExpr -> Int typeExprDepth _ _ (CTVar _) = 0 typeExprDepth seen progs (CFuncType e1 e2) = max (typeExprDepth seen progs e1) (typeExprDepth seen progs e2) typeExprDepth seen progs e@(CTCons n@(mod, _) es) = typeDepth seen progs ity where ty = case predefinedType n of Nothing -> case lookup mod progs of Nothing -> error $ "Module " ++ mod ++ " not found" Just p -> case find ((== n) . typeName) $ types p of Nothing -> error $ "Type " ++ (show n) ++ " not found in module " ++ mod Just x -> x Just x -> x ity = instantiateType e ty instantiateType :: CTypeExpr -> CTypeDecl -> CTypeDecl instantiateType (CTCons _ es) (CType nt v vs cs) = CType nt v vs ics where ics = map (instantiateConstructor $ zip vs es) cs instantiateType _ a@(CTypeSyn _ _ _ _) = a instantiateType _ a@(CNewType _ _ _ _) = a instantiateConstructor :: [(CTVarIName, CTypeExpr)] -> CConsDecl -> CConsDecl instantiateConstructor vs (CCons n v es) = CCons n v $ map (\e -> foldl (flip replaceVar) e vs) es instantiateConstructor vs (CRecord n v fs) = CRecord n v $ map instantiateField fs where instantiateField (CField n' v' e) = CField n' v' $ foldl (flip replaceVar) e vs replaceVar :: (CTVarIName, CTypeExpr) -> CTypeExpr -> CTypeExpr replaceVar (b, e) (CTVar a) | a == b = e | otherwise = CTVar a replaceVar v (CFuncType e1 e2) = CFuncType (replaceVar v e1) (replaceVar v e2) replaceVar v (CTCons n es) = CTCons n $ map (replaceVar v) es readAllStandardModules :: IO [(String, CurryProg)] readAllStandardModules = do entries <- getDirectoryContents sysLibPath mods <- mapIO (readMods "" sysLibPath) $ filter (not . isIrrelevant) entries return $ concat mods where readMods :: String -> String -> String -> IO [(String, CurryProg)] readMods prefix base f = do isDir <- doesDirectoryExist $ base f if isDir then do entries <- getDirectoryContents $ base f mods <- mapIO (readMods (prefixIt prefix f) $ base f) $ filter (not . isIrrelevant) entries return $ concat mods else do callFrontendWithParams ACY (setQuiet True defaultParams) $ stripCurrySuffix $ prefixIt prefix f prog <- readCurry $ prefixIt prefix f return [(stripCurrySuffix $ prefixIt prefix f, prog)] prefixIt prefix m | prefix == "" = m | otherwise = prefix ++ "." ++ m isIrrelevant :: String -> Bool isIrrelevant d = "." `isPrefixOf` d || (takeExtensions d /= "" && takeExtensions d /= ".curry") || d == "dist" || d == "Makefile" predefinedType :: (String, String) -> Maybe CTypeDecl predefinedType x = case x of ("Prelude", "[]") -> Just $ CType ("Prelude", "[]") Public [(0, "a")] [ CCons ("Prelude", "[]") Public [] , CCons ("Prelude", ":") Public [CTVar (0, "a"), CTCons ("Prelude", "[]") [CTVar (0, "a")]]] ("Prelude", "(,)") -> Just $ CType ("Prelude", "(,)") Public [(0, "a"), (1, "b")] [ CCons ("Prelude", "(,)") Public [CTVar (0, "a"), CTVar (1, "b")]] ("Prelude", "(,,)") -> Just $ CType ("Prelude", "(,,)") Public [(0, "a"), (1, "b"), (2, "c")] [ CCons ("Prelude", "(,,)") Public [CTVar (0, "a"), CTVar (1, "b"), CTVar (2, "c")]] ("Prelude", "(,,,)") -> Just $ CType ("Prelude", "(,,,)") Public [(0, "a"), (1, "b"), (2, "c"), (3, "d")] [ CCons ("Prelude", "(,,,)") Public [CTVar (0, "a"), CTVar (1, "b"), CTVar (2, "c"), CTVar (3, "d")]] ("Prelude", "(,,,,)") -> Just $ CType ("Prelude", "(,,,,)") Public [(0, "a"), (1, "b"), (2, "c"), (3, "d"), (4, "e")] [ CCons ("Prelude", "(,,,,)") Public [CTVar (0, "a"), CTVar (1, "b"), CTVar (2, "c"), CTVar (3, "d"), CTVar (4, "e")]] ("Prelude", "()") -> Just $ CType ("Prelude", "()") Public [] [CCons ("Prelude", "()") Public []] _ -> Nothing curry-tools-v3.3.0/cpm/misc/extract_npm_packages.rb000066400000000000000000000122571377556325500224570ustar00rootroot00000000000000# This script reads specifications from a copy of the npm package index that # needs to be running in a local CouchDB instance. It extracts all versions of # a fixed list of packages (see EXTRACT_PACKAGES) and all versions of all # transitive dependencies of those packages. The extracted specifications are # written to package.json files in a cpm index directory structure. Dependency # constraints and version numbers are translated if possible. Some constructs # that are not recognized by cpm are simply replaced by approximations while # others will lead to the package version being excluded from the index # entirely. require 'couchrest' require 'json' require 'parslet' if ARGV.length < 1 puts "Please specify an output directory!" exit end out_dir = ARGV[0] EXTRACT_PACKAGES = [ 'express', 'karma', 'chalk', 'request', 'express-session', 'pm2' ] class DependencySpec < Parslet::Parser rule(:space) { match('\s').repeat(1) } rule(:space?) { space.maybe } rule(:pre) { str('-').maybe >> match('[a-zA-Z]') >> match('[a-zA-Z0-9]').repeat } rule(:version) { str('*') | match('[0-9x]').repeat(1).as(:maj) >> (str('.') >> match('[0-9x]').repeat(1)).maybe.as(:min) >> (str('.') >> match('[0-9x]').repeat(1)).maybe.as(:pat) >> pre.maybe.as(:pre) } rule(:disjunction) { (conjunction >> (space? >> str('||') >> space? >> conjunction).repeat).maybe.as(:conjs) } rule(:conjunction) { (comparison >> (space? >> comparison).repeat).maybe.as(:comps) } rule(:comparison) { range.as(:range) | lte.as(:lte) | lt.as(:lt) | gte.as(:gte) | gt.as(:gt) | semver.as(:semver) | caret.as(:caret) | eq.as(:eq) | version.as(:bare) } rule(:range) { version.as(:ver1) >> space? >> str('-') >> space? >> version.as(:ver2) } rule(:lte) { str('<=') >> space? >> version.as(:ver) } rule(:lt) { str('<') >> space? >> version.as(:ver) } rule(:gte) { str('>=') >> space? >> version.as(:ver) } rule(:gt) { str('>') >> space? >> version.as(:ver) } rule(:eq) { str('=') >> space? >> version.as(:ver) } rule(:semver) { str('~') >> space? >> version.as(:ver) } rule(:caret) { str('^') >> space? >> version.as(:ver) } root(:disjunction) end def format_version_bare(v) if v == '*' ">= 0.0.0" elsif !v[:min] ">= #{v[:maj]}.0.0" elsif v[:min] == '.x' ">= #{v[:maj]}.0.0, < #{v[:maj].to_i + 1}.0.0" elsif v[:pat] == '.x' ">= #{v[:maj]}#{v[:min]}.0, < #{v[:maj]}#{v[:min].to_i + 1}.0" elsif !v[:pat] "#{v[:maj]}#{v[:min]}.0" elsif !v[:pre] "#{v[:maj]}#{v[:min]}#{v[:pat]}" else "#{v[:maj]}#{v[:min]}#{v[:pat]}#{v[:pre]}" end end def format_version(v) if v == '*' "0.0.0" elsif !v[:min] "#{v[:maj]}.0.0" elsif v[:min] == 'x' "#{v[:maj]}.0.0" elsif v[:pat] == '.x' "#{v[:maj]}#{v[:min]}.0" elsif !v[:pat] "#{v[:maj]}#{v[:min]}.0" elsif !v[:pre] "#{v[:maj]}#{v[:min]}#{v[:pat]}" else "#{v[:maj]}#{v[:min]}#{v[:pat]}#{v[:pre]}" end end class CpmTrans < Parslet::Transform rule(:lte => simple(:x)) { "<= #{x}" } rule(:lt => simple(:x)) { "< #{x}" } rule(:gte => simple(:x)) { ">= #{x}" } rule(:gt => simple(:x)) { "> #{x}" } rule(:semver => simple(:x)) { "~> #{x}" } rule(:caret => simple(:x)) { ">= #{x}" } rule(:eq => simple(:x)) { "= #{x}" } rule(:bare => subtree(:v)) { format_version_bare(v) } rule(:ver => subtree(:v)) { format_version(v) } rule(:range => subtree(:x)) { ">= #{x[:ver1]}, < #{x[:ver2]}" } rule(:conjs => subtree(:x)) { if x.is_a?(Array) x.join(' || ') else x end } rule(:comps => subtree(:x)) { if x.is_a?(Array) x.join(', ') else x end } end server = CouchRest.new db = server.database('registry') packages = {} def fetch_package(db, pkg_name, packages) semver_re = /\d+\.\d+\.\d+(\-[a-zA-Z0-9]*)?/ print '.' if packages.key? pkg_name return end pkg = db.get(pkg_name) if !pkg return end packages[pkg_name] = [] pkg[:versions].each do |ver, spec| if ver !~ semver_re next end packages[pkg_name] << spec (spec['dependencies'] || {}).each do |dep, constraint| fetch_package db, dep, packages end end end EXTRACT_PACKAGES.each do |pkg| fetch_package db, pkg, packages end puts puts "Total packages: #{packages.length}" puts "Total package versions: #{packages.collect { |k, v| v.length }.inject(0, :+)}" print "Writing to #{out_dir}..." def translate_dependency_spec(d) CpmTrans.new.apply(DependencySpec.new.parse(d)) end def translate_dependencies(deps) Hash[deps.collect do |k, v| begin [k, translate_dependency_spec(v)] rescue [k, ">= 0.0.0"] end end] end packages.each do |name, versions| if !Dir.exists?(File.join(out_dir, name)) Dir.mkdir File.join(out_dir, name) end versions.each do |version| if !Dir.exists?(File.join(out_dir, name, version['version'])) Dir.mkdir File.join(out_dir, name, version['version']) end File.open(File.join(out_dir, name, version['version'], 'package.json'), 'w') do |f| f.write(JSON.dump( name: version['name'], version: version['version'], author: 'test', synopsis: 'test', dependencies: translate_dependencies(version['dependencies'] || {}) )) end end end puts 'DONE' curry-tools-v3.3.0/cpm/src/000077500000000000000000000000001377556325500155755ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/src/CPM/000077500000000000000000000000001377556325500162145ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/src/CPM/AbstractCurry.curry000066400000000000000000000126731377556325500221030ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This module contains helper functions for dealing with AbstractCurry. In --- particular, it contains functions that can read modules from a package and --- its dependencies with all dependencies available to the Curry frontend. -------------------------------------------------------------------------------- module CPM.AbstractCurry ( loadPathForPackage , readAbstractCurryFromPackagePath , readAbstractCurryFromDeps , transformAbstractCurryInDeps , applyModuleRenames ) where import Data.List ( intercalate, nub ) import System.FilePath ( (), (<.>), takeFileName, replaceExtension ) import System.Process import AbstractCurry.Files ( readAbstractCurryFile, writeAbstractCurryFile ) import AbstractCurry.Pretty ( showCProg ) import AbstractCurry.Select ( imports ) import AbstractCurry.Transform import AbstractCurry.Types import System.CurryPath ( sysLibPath, inCurrySubdir, modNameToPath , inCurrySubdirModule, lookupModuleSource ) import System.FrontendExec ( FrontendTarget (..), FrontendParams (..) , defaultParams, callFrontendWithParams , setQuiet, setFullPath ) import CPM.ErrorLogger import qualified CPM.PackageCache.Runtime as RuntimeCache import CPM.Package (Package, loadPackageSpec, sourceDirsOf) --- Returns the load path for a package stored in some directory --- w.r.t. the dependent packages. --- --- @param - pkg - the package --- @param - pkgDir - the directory containing this package --- @param - deps - the resolved dependencies of the package --- @return the full load path for modules in the package or dependent packages loadPathForPackage :: Package -> String -> [Package] -> [String] loadPathForPackage pkg pkgDir deps = (map (pkgDir ) (sourceDirsOf pkg) ++ RuntimeCache.dependencyPathsSeparate deps pkgDir) --- Returns the full load path for a package stored in some directory. --- --- @param - pkg - the package --- @param - pkgDir - the directory containing this package --- @param - deps - the resolved dependencies of the package --- @return the full load path for modules in the package or dependent packages fullLoadPathForPackage :: Package -> String -> [Package] -> [String] fullLoadPathForPackage pkg pkgDir deps = loadPathForPackage pkg pkgDir deps ++ sysLibPath -- here we assume that the system libs are identical for each Curry system --- Reads an AbstractCurry module from a package. --- --- @param - dir the package's directory --- @param - deps the resolved dependencies of the package --- @param - mod the module to read readAbstractCurryFromPackagePath :: Package -> String -> [Package] -> String -> IO CurryProg readAbstractCurryFromPackagePath pkg pkgDir deps modname = do let loadPath = fullLoadPathForPackage pkg pkgDir deps let params = setQuiet True (setFullPath loadPath defaultParams) callFrontendWithParams ACY params modname src <- lookupModuleSource loadPath modname let acyName = case src of Nothing -> error $ "Module not found: " ++ modname Just (_, file) -> replaceExtension (inCurrySubdirModule modname file) ".acy" readAbstractCurryFile acyName >>= return . addPrimTypes where -- work-around for missing Prelude.Char|Int|Float declarations: addPrimTypes p@(CurryProg mname imports dfltdecl clsdecls instdecls typedecls funcdecls opdecls) | mname == pre && primType "Int" `notElem` typedecls = CurryProg mname imports dfltdecl clsdecls instdecls (map primType ["Int","Float","Char"] ++ typedecls) funcdecls opdecls | otherwise = p where pre = "Prelude" primType n = CType ("Prelude",n) Public [] [] [] --- Reads an AbstractCurry module from a package or one of its dependencies. --- --- @param dir - the package's directory --- @param deps - the resolved dependencies of the package --- @param mod - the module to read readAbstractCurryFromDeps :: String -> [Package] -> String -> ErrorLogger CurryProg readAbstractCurryFromDeps pkgDir deps modname = do pkg <- loadPackageSpec pkgDir liftIOEL $ readAbstractCurryFromPackagePath pkg pkgDir deps modname --- Applies a transformation function to a module from a package or one of its --- dependencies and writes the modified module to a file in Curry form. --- --- @param dir - the package's directory --- @param deps - the resolved dependencies of the package --- @param f - the transformation function --- @param mod - the module to transform --- @param dest - the destination file for the transformed module transformAbstractCurryInDeps :: String -> [Package] -> (CurryProg -> CurryProg) -> String -> String -> ErrorLogger () transformAbstractCurryInDeps pkgDir deps transform modname destFile = do acy <- readAbstractCurryFromDeps pkgDir deps modname liftIOEL $ writeFile destFile $ showCProg (transform acy) --- Renames all references to some modules in a Curry program. --- --- @param mods - a map from old to new module names --- @param prog - the program to modify applyModuleRenames :: [(String, String)] -> CurryProg -> CurryProg applyModuleRenames names prog = updCProg maybeRename (map maybeRename) id id id id id id (updQNamesInCProg rnm prog) where maybeRename n = case lookup n names of Just n' -> n' Nothing -> n rnm mn@(mod, n) = case lookup mod names of Just mod' -> (mod', n) Nothing -> mn curry-tools-v3.3.0/cpm/src/CPM/Config.curry000066400000000000000000000312761377556325500205200ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module defines the data type for CPM's configuration options, the --- default values for all options, and functions for reading the user's .cpmrc --- file and merging its contents into the default options. ------------------------------------------------------------------------------ module CPM.Config ( Config ( Config, packageInstallDir, binInstallDir, repositoryDir , appPackageDir, packageIndexURLs, packageTarFilesURLs , homePackageDir, curryExec , compilerVersion, compilerBaseVersion ) , readConfigurationWith, defaultConfig , showConfiguration, showCompilerVersion ) where import Data.Char ( toUpper ) import System.Directory ( doesDirectoryExist, createDirectoryIfMissing , getHomeDirectory, doesFileExist ) import qualified Curry.Compiler.Distribution as Dist import System.FilePath ( (), isAbsolute ) import Data.Maybe ( mapMaybe ) import Data.List ( split, splitOn, intercalate, intersperse ) import Control.Monad ( when ) import System.IOExts ( evalCmd ) import Data.PropertyFile ( readPropertyFile ) import System.Path ( getFileInPath ) import CPM.ErrorLogger import CPM.FileUtil ( ifFileExists ) import CPM.Helpers ( strip ) --- The default URL prefix to the directory containing tar files of all packages packageTarFilesDefaultURLs :: [String] packageTarFilesDefaultURLs = ["https://www-ps.informatik.uni-kiel.de/~cpm/PACKAGES"] --- The default location of the central package index. packageIndexDefaultURLs :: [String] packageIndexDefaultURLs = map (++"/INDEX.tar.gz") packageTarFilesDefaultURLs ++ ["https://git.ps.informatik.uni-kiel.de/curry-packages/cpm-index.git"] -- If you have an ssh access to git.ps.informatik.uni-kiel.de: --["ssh://git@git.ps.informatik.uni-kiel.de:55055/curry-packages/cpm-index.git"] --- Data type containing the main configuration of CPM. data Config = Config { --- The directory where locally installed packages are stored packageInstallDir :: String --- The directory where executable of locally installed packages are stored , binInstallDir :: String --- Directory where the package repository is stored , repositoryDir :: String --- Directory where the application packages are stored (cmd 'install') , appPackageDir :: String --- URLs tried for downloading the package index , packageIndexURLs :: [String] --- URL prefixes to the directory containing tar files of all packages , packageTarFilesURLs :: [String] --- The directory where the default home package is stored , homePackageDir :: String --- The executable of the Curry system used to compile and check packages , curryExec :: String --- The compiler version (name,major,minor,rev) used to compile packages , compilerVersion :: (String,Int,Int,Int) --- The version of the base libraries used by the compiler , compilerBaseVersion :: String } --- CPM's default configuration values. These are used if no .cpmrc file is found --- or a new value for the option is not specified in the .cpmrc file. defaultConfig :: Config defaultConfig = Config { packageInstallDir = "$HOME/.cpm/packages" , binInstallDir = "$HOME/.cpm/bin" , repositoryDir = "$HOME/.cpm/index" , appPackageDir = "" , packageIndexURLs = packageIndexDefaultURLs , packageTarFilesURLs = packageTarFilesDefaultURLs , homePackageDir = "" , curryExec = Dist.installDir "bin" Dist.curryCompiler , compilerVersion = ( Dist.curryCompiler , Dist.curryCompilerMajorVersion , Dist.curryCompilerMinorVersion , Dist.curryCompilerRevisionVersion ) , compilerBaseVersion = Dist.baseVersion } --- Shows the configuration. showConfiguration :: Config -> String showConfiguration cfg = unlines [ "Compiler version : " ++ showCompilerVersion cfg , "Compiler base version : " ++ compilerBaseVersion cfg , "CURRY_BIN : " ++ curryExec cfg , "REPOSITORY_PATH : " ++ repositoryDir cfg , "PACKAGE_INSTALL_PATH : " ++ packageInstallDir cfg , "BIN_INSTALL_PATH : " ++ binInstallDir cfg , "APP_PACKAGE_PATH : " ++ appPackageDir cfg , "HOME_PACKAGE_PATH : " ++ homePackageDir cfg , "PACKAGE_INDEX_URL : " ++ intercalate "|" (packageIndexURLs cfg) , "PACKAGE_TARFILES_URL : " ++ intercalate "|" (packageTarFilesURLs cfg) ] --- Shows the compiler version in the configuration. showCompilerVersion :: Config -> String showCompilerVersion cfg = let (cname,cmaj,cmin,crev) = compilerVersion cfg in cname ++ ' ' : showVersionNumer (cmaj,cmin,crev) --- Shows a version consisting of major/minor,revision number. showVersionNumer :: (Int,Int,Int) -> String showVersionNumer (maj,min,rev) = show maj ++ "." ++ show min ++ "." ++ show rev --- Sets an existing compiler executable in the configuration. --- Try to use the predefined CURRYBIN value. --- If it is an absolute path name but does not exists, --- try to find the executable "curry" in the path. setCompilerExecutable :: Config -> IO Config setCompilerExecutable cfg = do let exec = curryExec cfg if isAbsolute exec then ifFileExists exec (return cfg) (findExecutable "curry") else findExecutable exec where findExecutable exec = getFileInPath exec >>= maybe (error $ "Executable '" ++ exec ++ "' not found in path!") (\absexec -> return cfg { curryExec = absexec }) --- Sets the `appPackageDir` depending on the compiler version. setAppPackageDir :: Config -> IO Config setAppPackageDir cfg | null (appPackageDir cfg) = do homedir <- getHomeDirectory let cpmdir = homedir ".cpm" (cname,cmaj,cmin,crev) = compilerVersion cfg cmpname = cname ++ "_" ++ showVersionNumer (cmaj,cmin,crev) return cfg { appPackageDir = cpmdir "apps_" ++ cmpname } | otherwise = return cfg --- Sets the `homePackageDir` depending on the compiler version. setHomePackageDir :: Config -> IO Config setHomePackageDir cfg | null (homePackageDir cfg) = do homedir <- getHomeDirectory let cpmdir = homedir ".cpm" (cname,cmaj,cmin,crev) = compilerVersion cfg cvname = cname ++ "-" ++ showVersionNumer (cmaj,cmin,crev) homepkgdir = cpmdir cvname ++ "-homepackage" return cfg { homePackageDir = homepkgdir } | otherwise = return cfg --- Sets the correct compiler version in the configuration. setCompilerVersion :: Config -> ErrorLogger Config setCompilerVersion cfg0 = do cfg <- liftIOEL $ setCompilerExecutable cfg0 if curryExec cfg == Dist.installDir "bin" Dist.curryCompiler then return cfg { compilerVersion = currVersion , compilerBaseVersion = Dist.baseVersion } else do (sname,svers,sbver) <- getCompilerVersion (curryExec cfg) let cname = strip sname cvers = strip svers bvers = strip sbver (majs:mins:revs:_) = split (=='.') cvers logDebug $ unwords ["Compiler version:",cname,cvers] logDebug $ "Base lib version: " ++ bvers return cfg { compilerVersion = (cname, read majs, read mins, read revs) , compilerBaseVersion = bvers } where getCompilerVersion currybin = do logDebug $ "Getting version information from " ++ currybin (r,s,e) <- liftIOEL $ evalCmd currybin ["--compiler-name","--numeric-version","--base-version"] "" if r>0 then error $ "Cannot determine compiler version:\n" ++ e else case lines s of [sname,svers,sbver] -> return (sname,svers,sbver) _ -> do logDebug $ "Query version information again..." (c1,sname,e1) <- liftIOEL $ evalCmd currybin ["--compiler-name"] "" (c2,svers,e2) <- liftIOEL $ evalCmd currybin ["--numeric-version"] "" (c3,sbver,e3) <- liftIOEL $ evalCmd currybin ["--base-version"] "" when (c1 > 0 || c2 > 0 || c3 > 0) $ error $ "Cannot determine compiler version:\n" ++ unlines (filter (not . null) [e1,e2,e3]) return (sname,svers,sbver) currVersion = (Dist.curryCompiler, Dist.curryCompilerMajorVersion, Dist.curryCompilerMinorVersion , Dist.curryCompilerRevisionVersion) --- Reads the .cpmrc file from the user's home directory (if present) and --- merges its contents and some given default settings (first argument) --- into the configuration used by CPM. --- Resolves the $HOME variable after merging and creates --- any missing directories. May return an error using `Left`. readConfigurationWith :: [(String,String)] -> ErrorLogger (Either String Config) readConfigurationWith defsettings = do home <- liftIOEL $ getHomeDirectory let configFile = home ".cpmrc" exfile <- liftIOEL $ doesFileExist configFile settingsFromFile <- liftIOEL $ if exfile then readPropertyFile configFile >>= return . stripProps else return [] let mergedSettings = mergeConfigSettings defaultConfig (settingsFromFile ++ stripProps defsettings) case mergedSettings of Left e -> return $ Left e Right s0 -> do s1 <- liftIOEL $ replaceHome s0 s2 <- setCompilerVersion s1 s3 <- liftIOEL $ setAppPackageDir s2 s4 <- liftIOEL $ setHomePackageDir s3 liftIOEL $ createDirectories s4 return $ Right s4 replaceHome :: Config -> IO Config replaceHome cfg = do homeDir <- getHomeDirectory return $ cfg { packageInstallDir = replaceHome' homeDir (packageInstallDir cfg) , binInstallDir = replaceHome' homeDir (binInstallDir cfg) , repositoryDir = replaceHome' homeDir (repositoryDir cfg) , appPackageDir = replaceHome' homeDir (appPackageDir cfg) } where replaceHome' h s = concat $ intersperse h $ splitOn "$HOME" s createDirectories :: Config -> IO () createDirectories cfg = do createDirectoryIfMissing True (packageInstallDir cfg) createDirectoryIfMissing True (binInstallDir cfg) createDirectoryIfMissing True (repositoryDir cfg) createDirectoryIfMissing True (appPackageDir cfg) --- Merges configuration options from a configuration file or argument options --- into a configuration record. May return an error using Left. --- --- @param cfg - the configuration record to merge into --- @param opts - the options to merge mergeConfigSettings :: Config -> [(String, String)] -> Either String Config mergeConfigSettings cfg props = applyEither setters cfg where setters = map maybeApply props maybeApply (k, v) = case lookup k keySetters of Nothing -> \_ -> Left $ "Unknown .cpmrc property: " ++ k ++ "\n\n" ++ "The following .cpmrc properties are allowed:\n" ++ unlines (map fst keySetters) Just s -> \c -> Right $ s v c --- Removes leading and trailing whitespaces from option keys and values --- and transforms option keys to uppercase where underscores are removed. --- --- @param opts - the options stripProps :: [(String, String)] -> [(String, String)] stripProps = map (\(a,b) -> ((map toUpper $ filter (/='_') $ strip a), strip b)) --- A map from option names to functions that will update a configuration --- record with a value for that option. keySetters :: [(String, String -> Config -> Config)] keySetters = [ ("APPPACKAGEPATH" , \v c -> c { appPackageDir = v }) , ("BININSTALLPATH" , \v c -> c { binInstallDir = v }) , ("CURRYBIN" , \v c -> c { curryExec = v }) , ("HOMEPACKAGEPATH" , \v c -> c { homePackageDir = v }) , ("PACKAGEINDEXURL" , \v c -> c { packageIndexURLs = breakURLs v }) , ("PACKAGETARFILESURL" , \v c -> c { packageTarFilesURLs = breakURLs v }) , ("PACKAGEINSTALLPATH" , \v c -> c { packageInstallDir = v }) , ("REPOSITORYPATH" , \v c -> c { repositoryDir = v }) ] where breakURLs = splitOn "|" --- Sequentially applies a list of functions that transform a value to a value --- of that type (i.e. a fold). Each function can error out with a Left, in --- which case no further applications are done and the Left is returned from --- the overall application of applyEither. --- --- @param fs - the list of functions --- @param v - the initial value applyEither :: [a -> Either c a] -> a -> Either c a applyEither [] z = Right z applyEither (f:fs) z = case f z of Left err -> Left err Right z' -> applyEither fs z' ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/src/CPM/Diff/000077500000000000000000000000001377556325500170645ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/src/CPM/Diff/API.curry000066400000000000000000000344461377556325500205760ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This module contains functions that can compare the API of one version of a --- package to another. -------------------------------------------------------------------------------- module CPM.Diff.API ( compareModulesFromPackages , compareModulesFromPackageAndDir , compareModulesInDirs , compareApiModule , getBaseTemp , Differences , Difference (..) , showDifferences ) where import System.Directory ( getTemporaryDirectory ) import System.FilePath ( () ) import Data.List ( nub ) import Data.Maybe ( listToMaybe, catMaybes ) import Prelude hiding ( empty ) import AbstractCurry.Types ( CurryProg (..), CFuncDecl (..), CTypeDecl (..) , COpDecl (..), QName, CFixity (..) , CVisibility (..)) import AbstractCurry.Pretty import AbstractCurry.Select ( functions, funcName, types, typeName ) import Text.Pretty ( pPrint, text, (<+>), vcat, empty, red, ($$) ) import CPM.AbstractCurry ( readAbstractCurryFromPackagePath ) import CPM.Config ( Config ) import CPM.ErrorLogger import CPM.FileUtil ( copyDirectory, recreateDirectory, tempDir ) import CPM.Package ( Package, Version, packageId, loadPackageSpec , exportedModules) import CPM.PackageCache.Global as GC import CPM.PackageCopy ( resolveAndCopyDependencies ) import CPM.Repository ( Repository ) getBaseTemp :: IO String getBaseTemp = do tmpDir <- tempDir let tmp = tmpDir "diff" recreateDirectory tmp return tmp --- Compares two versions of a package from the global package cache. --- --- @param cfg - the CPM configuration --- @param repo - the central package index --- @param gc - the global package cache --- @param nameA - the name of package version A --- @param verA - the version of package version A --- @param nameB - the name of package version B --- @param verB - the version of package version B --- @param onlyMods - a list of modules to compare compareModulesFromPackages :: Config -> Repository -> GC.GlobalCache -> String -> Version -> String -> Version -> Maybe [String] -> ErrorLogger [(String, Differences)] compareModulesFromPackages cfg repo gc nameA verA nameB verB onlyMods = do baseTmp <- liftIOEL getBaseTemp pkgA <- GC.tryFindPackage gc nameA verA pkgB <- GC.tryFindPackage gc nameB verB GC.copyPackage cfg pkgA baseTmp GC.copyPackage cfg pkgB baseTmp compareModulesInDirs cfg repo gc (baseTmp packageId pkgA) (baseTmp packageId pkgB) onlyMods --- Compares a package version from a directory to a package version from the --- global package cache. --- --- @param cfg - the CPM configuration --- @param repo - the central package index --- @param gc - the global package cache --- @param dirA - the directory containing package version A --- @param nameB - the name of package version B --- @param verB - the version of package version B --- @param onlyMods - a list of modules to compare compareModulesFromPackageAndDir :: Config -> Repository -> GC.GlobalCache -> String -> String -> Version -> Maybe [String] -> ErrorLogger [(String, Differences)] compareModulesFromPackageAndDir cfg repo gc dirA nameB verB onlyMods = do baseTmp <- liftIOEL getBaseTemp pkgB <- GC.tryFindPackage gc nameB verB pkgA <- loadPackageSpec dirA GC.copyPackage cfg pkgB baseTmp liftIOEL $ copyDirectory dirA (baseTmp packageId pkgA) compareModulesInDirs cfg repo gc (baseTmp packageId pkgA) (baseTmp packageId pkgB) onlyMods --- Compares package versions from two directories. --- --- @param cfg - the CPM configuration --- @param repo - the central package index --- @param gc - the global package cache --- @param dirA - the directory containing package version A --- @param dirB - the directory containing package version B --- @param onlyMods - a list of modules to compare compareModulesInDirs :: Config -> Repository -> GC.GlobalCache -> String -> String -> Maybe [String] -> ErrorLogger [(String, Differences)] compareModulesInDirs cfg repo gc dirA dirB onlyMods = loadPackageSpec dirA >>= \pkgA -> loadPackageSpec dirB >>= \pkgB -> resolveAndCopyDependencies cfg repo gc dirA >>= \depsA -> resolveAndCopyDependencies cfg repo gc dirB >>= \depsB -> let cmpmods = nub (exportedModules pkgA ++ exportedModules pkgB) in if null cmpmods then logInfo "No exported modules to compare" >> return [] else do diffs <- liftIOEL $ mapM (compareApiModule pkgA dirA depsA pkgB dirB depsB) cmpmods let modsWithDiffs = zip cmpmods diffs return $ case onlyMods of Nothing -> modsWithDiffs Just ms -> filter ((`elem` ms) . fst) modsWithDiffs --- Compares a single module from two package versions. --- --- @param pkgA - version A of the package --- @param dirA - the directory containing version A of the package --- @param depsA - the resolved dependencies of version A of the package --- @param pkgB - version B of the package --- @param dirB - the directory containing version B of the package --- @param depsB - the resolved dependencies of version B of the package --- @param mod - the name of the module compareApiModule :: Package -> String -> [Package] -> Package -> String -> [Package] -> String -> IO Differences compareApiModule pkgA dirA depsA pkgB dirB depsB mod = if mod `elem` exportedModules pkgA then if mod `elem` exportedModules pkgB then readAbstractCurryFromPackagePath pkgA dirA depsA mod >>= \prog1 -> readAbstractCurryFromPackagePath pkgB dirB depsB mod >>= \prog2 -> let funcDiffs = diffFuncsFiltered funcIsPublic prog1 prog2 typeDiffs = diffTypesFiltered typeIsPublic prog1 prog2 opDiffs = diffOpsFiltered (\_ _ -> True) prog1 prog2 in return $ (Nothing, funcDiffs, typeDiffs, opDiffs) else return $ (Just $ Addition mod, [], [], []) else return $ (Just $ Removal mod, [], [], []) --- Differences between two versions of a package. First component is present --- if the module is missing in one of the package versions. The other --- components list the differences if the module is present in both versions. type Differences = ( Maybe (Difference String) , [Difference CFuncDecl] , [Difference CTypeDecl] , [Difference COpDecl] ) --- A single difference between two versions of a module. data Difference a = Addition a | Removal a | Change a a --- Prints a list of differences to the user. --- --- @param diffs - the list of differences --- @param verA - version A of the package --- @param verB - version B of the package showDifferences :: [Differences] -> Version -> Version -> String showDifferences diffs verA verB = pPrint $ vcat (map showDifferences' diffs) where jump = versionJump verA verB showDifferences' (modDiff, funcDiffs, typeDiffs, opDiffs) = (modText modDiff) $$ (vcat $ funcTexts funcDiffs) $$ (vcat $ typeTexts typeDiffs) $$ (vcat $ opTexts opDiffs) showViolation (Addition _) = if jump == Patch then red $ text "Adding features in a patch version is a violation of semantic versioning." else empty showViolation (Removal _) = if jump /= Major then red $ text "Removing features in a patch or minor version is a violation of semantic versioning." else empty showViolation (Change _ _) = if jump /= Major then red $ text "Changing APIs in a patch or minor version is a violation of semantic versioning." else empty funcTexts funcDiffs = map (\f -> (text $ showFuncDifference f) <+> (showViolation f)) funcDiffs typeTexts typeDiffs = map (\f -> (text $ showTypeDifference f) <+> (showViolation f)) typeDiffs opTexts opDiffs = map (\f -> (text $ showOpDifference f) <+> (showViolation f)) opDiffs modText modDiff = case modDiff of Nothing -> empty Just d -> case d of Addition m -> (text $ "Added module " ++ m) <+> (showViolation d) Removal m -> (text $ "Removed module " ++ m) <+> (showViolation d) Change _ _ -> text $ "This should not appear" --- A jump between two versions. data VersionJump = Major | Minor | Patch | None deriving Eq --- Calculate the jump between two versions. versionJump :: Version -> Version -> VersionJump versionJump (majA, minA, patA, _) (majB, minB, patB, _) = if majA /= majB then Major else if minA /= minB then Minor else if patA /= patB then Patch else None --- Renders a function difference to a string. showFuncDifference :: Difference CFuncDecl -> String showFuncDifference (Addition f) = "Added " ++ (showFuncDecl f) showFuncDifference (Removal f) = "Removed " ++ (showFuncDecl f) showFuncDifference (Change a b) = "Change " ++ (showFuncDecl a) ++ " to " ++ (showFuncDecl b) --- Renders a function declaration to a string. showFuncDecl :: CFuncDecl -> String showFuncDecl (CFunc (_, n) _ _ t _) = n ++ " :: " ++ (pPrint $ ppCQualTypeExpr defaultOptions t) showFuncDecl (CmtFunc _ (_, n) _ _ t _) = n ++ " :: " ++ (pPrint $ ppCQualTypeExpr defaultOptions t) --- Renders a type difference to a string. showTypeDifference :: Difference CTypeDecl -> String showTypeDifference (Addition f) = "Added " ++ (showTypeDecl f) showTypeDifference (Removal f) = "Removed " ++ (showTypeDecl f) showTypeDifference (Change a b) = "Changed " ++ (showTypeDecl a) ++ " to " ++ (showTypeDecl b) --- Renders a type declaration to a string. showTypeDecl :: CTypeDecl -> String showTypeDecl (CType (_, n) _ _ cs _) = "data " ++ n ++ " (" ++ (show $ length cs) ++ " constructors)" showTypeDecl (CTypeSyn (_, n) _ _ t) = "type " ++ n ++ " = " ++ (pPrint $ ppCTypeExpr defaultOptions t) showTypeDecl (CNewType (_, n) _ _ _ _) = "newtype " ++ n --- Renders an operator difference to a string. showOpDifference :: Difference COpDecl -> String showOpDifference (Addition f) = "Added " ++ showOpDecl f showOpDifference (Removal f) = "Removed " ++ showOpDecl f showOpDifference (Change a b) = "Changed " ++ showOpDecl a ++ " to " ++ showOpDecl b --- Renders an operator declaration to a string. showOpDecl :: COpDecl -> String showOpDecl (COp (_, n) CInfixOp a) = "infix " ++ (show a) ++ " " ++ n showOpDecl (COp (_, n) CInfixlOp a) = "infixl " ++ (show a) ++ " " ++ n showOpDecl (COp (_, n) CInfixrOp a) = "infixr " ++ (show a) ++ " " ++ n --- Compares all functions in two modules that match the given predicate. diffFuncsFiltered :: (CurryProg -> CFuncDecl -> Bool) -> CurryProg -> CurryProg -> [Difference CFuncDecl] diffFuncsFiltered = mkDiff funcEq functions funcName --- Compares all type declarations in two modules that match the given --- predicate. diffTypesFiltered :: (CurryProg -> CTypeDecl -> Bool) -> CurryProg -> CurryProg -> [Difference CTypeDecl] diffTypesFiltered = mkDiff typeEq types typeName --- Compares all operator declarations in two modules that match the given --- predicate. diffOpsFiltered :: (CurryProg -> COpDecl -> Bool) -> CurryProg -> CurryProg -> [Difference COpDecl] diffOpsFiltered = mkDiff opEq ops opName --- Is a function public? funcIsPublic :: CurryProg -> CFuncDecl -> Bool funcIsPublic _ (CFunc _ _ Public _ _) = True funcIsPublic _ (CFunc _ _ Private _ _) = False funcIsPublic _ (CmtFunc _ _ _ Public _ _) = True funcIsPublic _ (CmtFunc _ _ _ Private _ _) = False --- Is a type public? typeIsPublic :: CurryProg -> CTypeDecl -> Bool typeIsPublic _ (CType _ Public _ _ _) = True typeIsPublic _ (CType _ Private _ _ _) = False typeIsPublic _ (CTypeSyn _ Public _ _) = True typeIsPublic _ (CTypeSyn _ Private _ _) = False typeIsPublic _ (CNewType _ Public _ _ _) = True typeIsPublic _ (CNewType _ Private _ _ _) = False --- Creates a function that can compare elements in two versions of a module. --- --- @param eq - a function that checks if two elements are equal --- @param selector - a function that selects the elements to be compared from --- a CurryProg --- @param name - a function that selects the name of an element mkDiff :: (a -> a -> Bool) -> (CurryProg -> [a]) -> (a -> QName) -> ((CurryProg -> a -> Bool) -> CurryProg -> CurryProg -> [Difference a]) mkDiff eq selector name = \p b a -> let as = filter (p a) $ selector a bs = filter (p b) $ selector b findDifference f = case listToMaybe $ filter ((== (name f)) . name) bs of Nothing -> Just $ Removal f Just f' -> if f `eq` f' then Nothing else Just $ Change f f' additions = filter (not . (flip elem) (map name as) . name) bs in catMaybes (map findDifference as) ++ (map Addition additions) --- Are two functions equal? funcEq :: CFuncDecl -> CFuncDecl -> Bool funcEq (CFunc _ a1 v1 t1 _) (CFunc _ a2 v2 t2 _) = a1 == a2 && v1 == v2 && t1 == t2 funcEq (CmtFunc _ _ a1 v1 t1 _) (CmtFunc _ _ a2 v2 t2 _) = a1 == a2 && v1 == v2 && t1 == t2 funcEq (CFunc _ a1 v1 t1 _) (CmtFunc _ _ a2 v2 t2 _) = a1 == a2 && v1 == v2 && t1 == t2 funcEq (CmtFunc _ _ a1 v1 t1 _) (CFunc _ a2 v2 t2 _) = a1 == a2 && v1 == v2 && t1 == t2 --- Are two type declarations equal? (We ignore `deriving` clauses) typeEq :: CTypeDecl -> CTypeDecl -> Bool typeEq (CType _ v1 tvs1 cs1 _) (CType _ v2 tvs2 cs2 _) = v1 == v2 && tvs1 == tvs2 && cs1 == cs2 typeEq (CTypeSyn _ v1 tvs1 e1) (CTypeSyn _ v2 tvs2 e2) = v1 == v2 && tvs1 == tvs2 && e1 == e2 typeEq (CNewType _ v1 tvs1 c1 _) (CNewType _ v2 tvs2 c2 _) = v1 == v2 && tvs1 == tvs2 && c1 == c2 typeEq (CType _ _ _ _ _) (CTypeSyn _ _ _ _) = False typeEq (CType _ _ _ _ _) (CNewType _ _ _ _ _) = False typeEq (CTypeSyn _ _ _ _) (CType _ _ _ _ _) = False typeEq (CTypeSyn _ _ _ _) (CNewType _ _ _ _ _) = False typeEq (CNewType _ _ _ _ _) (CType _ _ _ _ _) = False typeEq (CNewType _ _ _ _ _) (CTypeSyn _ _ _ _) = False --- Are two operator declarations equal? opEq :: COpDecl -> COpDecl -> Bool opEq (COp _ f1 a1) (COp _ f2 a2) = f1 == f2 && a1 == a2 --- Select all operator declarations from a CurryProg. ops :: CurryProg -> [COpDecl] ops (CurryProg _ _ _ _ _ _ _ os) = os --- Get the name of an operator declaration. opName :: COpDecl -> QName opName (COp n _ _) = n curry-tools-v3.3.0/cpm/src/CPM/Diff/Behavior.curry000066400000000000000000001716351377556325500217260ustar00rootroot00000000000000------------------------------------------------------------------------------- --- This module contains functions that compare the behavior of two versions of --- a package. --- --- For this purpose, copies of these packages and a main "comparison" --- module (with name "Compare") are generated in the temporary --- directory `/tmp/CPM/bdiff` and then CurryCheck is executed on `Compare`. -------------------------------------------------------------------------------- module CPM.Diff.Behavior ( ComparisonInfo (..) , getBaseTemp , genCurryCheckProgram , diffBehavior , preparePackageDirs , preparePackageAndDir , preparePackages , findFunctionsToCompare ) where import System.Directory ( createDirectory, doesDirectoryExist, getTemporaryDirectory ) import System.FilePath ( (), joinPath ) import System.Environment ( getEnv, setEnv, unsetEnv ) import Data.Char ( isAlphaNum ) import Data.List ( intercalate, intersect, nub, splitOn, isPrefixOf , isInfixOf, find, delete, (\\), nubBy ) import Data.Maybe ( isJust, fromJust, fromMaybe, listToMaybe ) import Control.Monad import AbstractCurry.Build import AbstractCurry.Pretty ( defaultOptions, ppCTypeExpr, showCProg ) import AbstractCurry.Select ( publicFuncNames, funcName, functions, funcArity , funcType, argTypes, typeName, types, tconsOfType , tconsArgsOfType, resultType, isIOType , typeOfQualType ) import AbstractCurry.Transform (updCFuncDecl) import AbstractCurry.Types ( CurryProg (..), CFuncDecl (..), CVisibility (..) , CTypeExpr (..), CPattern (..), CExpr (..) , CTypeDecl (..), CConsDecl (..), CFieldDecl (..) , CVarIName, QName) import Analysis.Types ( Analysis ) import Analysis.ProgInfo ( ProgInfo, emptyProgInfo, combineProgInfo , lookupProgInfo) import Analysis.Termination ( productivityAnalysis, Productivity(..) ) import Analysis.TypeUsage ( typesInValuesAnalysis ) import CASS.Server ( analyzeGeneric ) import System.CurryPath ( lookupModuleSource ) import Text.Pretty ( pPrint, text, indent, vcat, (<+>), (<$$>) ) import CPM.AbstractCurry ( readAbstractCurryFromDeps, loadPathForPackage ) import CPM.Config ( Config (curryExec) ) import CPM.Diff.API as APIDiff import CPM.Diff.CurryComments (readComments, getFuncComment) import CPM.Diff.Rename (prefixPackageAndDeps) import CPM.ErrorLogger import CPM.FileUtil ( copyDirectory, recreateDirectory, inDirectory , joinSearchPath, tempDir ) import CPM.Package ( Package, Version, name, version, showVersion, packageId , exportedModules, loadPackageSpec) import CPM.PackageCache.Global as GC import CPM.PackageCopy (resolveAndCopyDependencies) import CPM.Repository (Repository) -- What this module does (and how) -- =============================== -- -- This module compares two package versions using CurryCheck/EasyCheck. Each -- function that can be tested (the criteria for what makes a function testable -- are listed below), is compared using a EasyCheck property test equating both -- versions of the function. A function is considered testable, if -- -- - it is present in both versions of the module AND -- - its type is unchanged between both versions of the module AND -- - it is public AND -- - its argument types are either all types from the Curry standard library or -- they are the same in both versions of the module (including types in -- package dependencies) AND -- - the function is not marked with a do-not-checked pragma -- -- To test a function, we have to generate a new Curry program containing a test -- that calls both versions of the function (from the old and from the new -- version of the package) and compares the results. Since we have to use both -- versions of the package from within the same Curry program, we have to rename -- their modules to be able to import both into the same program. Renaming the -- modules also means renaming all references to the modules. And since the -- package's dependencies can also change between different versions, we have to -- rename all modules in all transitive dependencies as well. When renaming the -- modules, we simply prefix them with the version of the original package (i.e. -- the transitive dependencies get the same prefix as the original package). If -- we have package versions 1.0.0 and 1.1.0 and our module is called -- `Test.Functions`, then we will rename the from version 1.0.0 to -- `V_1_0_0_Test.Functions` and the one from version 1.1.0 to -- `V_1_1_0_Test.Functions`. -- -- We can now import both module versions and call functions from both versions -- in the same Curry program. We still have a problem with property tests that -- are parameterized over a data type present in one of the packages or one of -- its dependencies: -- -- ``` -- test_sayHello :: SayHello.MyType -> Test.Prop.Prop -- test_sayHello x0 = V_1_0_0_SayHello.sayHello x0 <~> V_1_1_0_SayHello.sayHello x0 -- ``` -- -- In this scenario, the parameter type cannot remain `SayHello.MyType`, since -- we renamed both versions of the module and they each have their own version -- of the type, `V_1_0_0_SayHello.MyType` and `V_1_1_0_SayHello.MyType`. If we -- choose one of the renamed types, we cannot give it to the function from the -- other version of the module as-is. So we generate translator functions that -- can translate one version of the data type into the other, using -- `genTranslatorFunction`. -- -- The comments in this module refer to version A and version B of the module -- and/or package. Which version is which (e.g. whether A is the smaller -- version) is irrelevant. --- Contains information from the package preparation (moving to temp directory --- and renaming). data ComparisonInfo = ComparisonInfo { infPackageA :: Package --- A version of package , infPackageB :: Package --- B version of package , infDirA :: String --- Directory where renamed A version is stored , infDirB :: String --- Directory where renamed B version is stored , infSourceDirA :: String --- Directory where original A version is stored , infSourceDirB :: String --- Directory where original B version is stored , infPrefixA :: String --- Prefix for modules in A version , infPrefixB :: String --- Prefix for modules in B version , infModMapA :: [(String, String)] --- Map from old to new module names, ver A , infModMapB :: [(String, String)] --- Map from old to new module names, ver B } --- Create temporary directory for the behavior diff. createBaseTemp :: IO String createBaseTemp = do tmpDir <- getTemporaryDirectory let tmp = tmpDir "CPM" "bdiff" recreateDirectory tmp return tmp --- Get temporary directory for the behavior diff. getBaseTemp :: IO String getBaseTemp = do tmpDir <- getTemporaryDirectory return $ tmpDir "CPM" "bdiff" --- This message is printed before CurryCheck is executed. infoText :: String infoText = unlines [ "Running behavior diff where the raw output of CurryCheck is shown." , "The test operations are named after the operations they compare." , "If a test fails, their implementations semantically differ." ] --- Compare the behavior of two package versions using CurryCheck. --- --- @param cfg - the CPM configuration --- @param repo - the central package index --- @param gc - the global package cache --- @param info - the comparison info obtained from preparePackageDirs --- @param groundequiv - test ground equivalence only? --- @param useanalysis - use program analysis to filter non-term. operations? --- @param mods - a list of modules to compare diffBehavior :: Config -> Repository -> GC.GlobalCache -> ComparisonInfo -> Bool -> Bool -> Maybe [String] -> ErrorLogger () diffBehavior cfg repo gc info groundequiv useanalysis cmods = do baseTmp <- liftIOEL getBaseTemp (acyCache, loadpath, funcs, removed) <- findFunctionsToCompare cfg repo gc (infSourceDirA info) (infSourceDirB info) useanalysis cmods let filteredFuncs = maybe funcs (\mods -> filter ((`elem` mods) . fst . funcName . snd) funcs) cmods filteredNames = map snd filteredFuncs logDebug ("Filtered operations to be checked: " ++ showFuncNames filteredNames) case funcs of [] -> liftIOEL (printRemoved removed >> return ()) _ -> do liftIOEL $ do putStrLn infoText printRemoved removed putStrLn $ "Comparing operations " ++ showFuncNames filteredNames ++ "\n" genCurryCheckProgram cfg repo gc filteredFuncs info groundequiv acyCache loadpath callCurryCheck cfg info baseTmp where printRemoved removed = if null removed then return () else putStrLn (renderRemoved removed) >> putStrLn "" --- Renders the list of functions that were excluded from the comparison along --- with reasons for their exclusion. renderRemoved :: [(CFuncDecl, FilterReason)] -> String renderRemoved rs = pPrint $ text "The following operations are not compared:" <$$> vcat (map renderReason rs) where renderReason (f, r) = indent 4 $ (text $ showQName (funcName f)) <+> text "-" <+> reasonText r reasonText NoReason = text "Unknown reason" reasonText Diffing = text "Different function types or function missing" reasonText NonMatchingTypes = text "Some types inside the function type differ" reasonText HighArity = text "Arity too high" reasonText IOAction = text "IO action" reasonText NoCompare = text "Marked NOCOMPARE" reasonText FuncArg = text "Takes functions as arguments" reasonText NonTerm = text "Possibly non-terminating" --- Runs CurryCheck on the generated program. callCurryCheck :: Config -> ComparisonInfo -> String -> ErrorLogger () callCurryCheck cfg info baseTmp = do oldPath <- liftIOEL $ getEnv "CURRYPATH" let currybin = curryExec cfg let currypath = infDirA info ++ ":" ++ infDirB info liftIOEL $ setEnv "CURRYPATH" currypath logDebug $ "Run `curry check Compare' in `" ++ baseTmp ++ "' with" logDebug $ "CURRYPATH=" ++ currypath ecode <- inDirectoryEL baseTmp $ showExecCmd (currybin ++ " check Compare") liftIOEL $ setEnv "CURRYPATH" oldPath logDebug "CurryCheck finished" if ecode==0 then return () else logError "CurryCheck detected behavior error!" --- Generates a program containing CurryCheck tests that will compare the --- behavior of the given functions. The program will be written to the --- `Compare.curry` file in the behavior diff temp directory. genCurryCheckProgram :: Config -> Repository -> GC.GlobalCache -> [(Bool,CFuncDecl)] -> ComparisonInfo -> Bool -> ACYCache -> [String] -> ErrorLogger () genCurryCheckProgram cfg repo gc prodfuncs info groundequiv acyCache loadpath = do baseTmp <- liftIOEL $ getBaseTemp let translatorGenerator = uncurry $ genTranslatorFunction cfg repo gc info (_, transMap) <- foldM translatorGenerator (acyCache, emptyTrans) translateTypes let (limittypes,testFunctions) = unzip (map (genTestFunction info groundequiv transMap) prodfuncs) let transFunctions = transFuncs transMap let limittconss = nub (concatMap tconsOfType (concat limittypes)) let limittcmods = nub (map fst limittconss) -- get the declarations of all types which require limit functions: (_, limittdecls) <- foldM addLimitType (acyCache,[]) limittconss typeinfos <- analyzeModules "recursive type" typesInValuesAnalysis loadpath limittcmods let limitFunctions = concatMap (genLimitFunction typeinfos) limittdecls prog = simpleCurryProg "Compare" imports [] (concat testFunctions ++ transFunctions ++ (if groundequiv then limitFunctions else [])) [] let prodops = map snd (filter fst prodfuncs) liftIOEL $ unless (null prodops) $ putStrLn $ "Productive operations (currently not fully supported for all types):\n" ++ showFuncNames prodops ++ "\n" liftIOEL $ writeFile (baseTmp "Compare.curry") (progcmts ++ "\n" ++ showCProg prog ++ "\n") return () where addLimitType (acy,tdecls) qn = findTypeInModules cfg repo gc info acy qn >>= \ (acy',tdecl) -> return (acy', tdecl:tdecls) progcmts = unlines $ map ("-- "++) [ "This file contains properties to compare packages" , packageId (infPackageA info) ++ " and " ++ packageId (infPackageB info) ++ "." , "" , "It should be processed by 'curry check Compare' with setting" , "export CURRYPATH=" ++ infDirA info ++ ":" ++ infDirB info ] allReferencedTypes = nub ((concat $ map (argTypes . typeOfQualType . funcType . snd) prodfuncs) ++ map (resultType . typeOfQualType . funcType . snd) prodfuncs) translateTypes = filter (needToTranslatePart info) allReferencedTypes mods = map (fst . funcName . snd) prodfuncs modsA = map (\mod -> (infPrefixA info) ++ "_" ++ mod) mods modsB = map (\mod -> (infPrefixB info) ++ "_" ++ mod) mods imports = modsA ++ modsB ++ ["Test.Prop"] --- Generates functions to limit the result depth of values of --- the given data type. genLimitFunction :: ProgInfo [QName] -> CTypeDecl -> [CFuncDecl] genLimitFunction typeinfos tdecl = case tdecl of CType tc _ tvs consdecls _ -> [stCmtFunc ("Limit operation for type " ++ tcname) (transCTCon2Limit tc) (length tvs + 2) Private (foldr (~>) (limitFunType (applyTC tc (map CTVar tvs))) (map (limitFunType . CTVar) tvs)) (cdecls2rules tc tvs consdecls)] _ -> error $ "Cannot generate limit function for type " ++ tcname where tcname = showQName (typeName tdecl) limitFunType texp = baseType ("Nat","Nat") ~> texp ~> texp var2limitfun (i,ti) = (i,"lf"++ti) cdecls2rules tc tvs cdecls = if null cdecls then [simpleRule [CPVar (0,"_"), CPVar (1,"x")] (CVar (1,"x"))] else concatMap (cdecl2rules tvs (nullaryConsOf cdecls)) cdecls where nullaryConsOf [] = error $ "Cannot generate limit operation for types " ++ "without nullary constructors: " ++ showQName tc nullaryConsOf (CCons qc _ [] : _ ) = qc nullaryConsOf (CCons _ _ (_:_) : cs) = nullaryConsOf cs nullaryConsOf (CRecord _ _ _ : cs) = nullaryConsOf cs cdecl2rules tvs tnull (CCons qc _ texps) = let lfunargs = map (CPVar . var2limitfun) tvs argvars = map (\i -> (i,"x"++show i)) [0 .. length texps - 1] isRecursive t = t `elem` fromMaybe [] (lookupProgInfo t typeinfos) isRecursiveCons = any isRecursive (concatMap tconsOfType texps) in (if isRecursiveCons then [simpleRule (lfunargs ++ [CPComb ("Nat","Z") [], CPComb qc (map CPVar argvars)]) (applyF tnull [])] else []) ++ [simpleRule (lfunargs ++ [if isRecursiveCons then CPComb ("Nat","S") [CPVar (0,"n")] else CPVar (0,"n"), CPComb qc (map CPVar argvars)]) (applyF qc (map (\ (te,v) -> applyE (type2LimOp te) [CVar (0,"n"), CVar v]) (zip texps argvars)))] cdecl2rules _ _ (CRecord qc _ _) = error $ "Cannot generate limit operation for record field " ++ showQName qc type2LimOp texp = case texp of CTVar tv -> CVar (var2limitfun tv) CFuncType _ _ -> error "type2LimOp: cannot generate limit operation for function type" _ -> maybe (error "type2LimOp: cannot generate limit operation for type application") (\ (tc,ts) -> applyF (transCTCon2Limit tc) (map type2LimOp ts)) (tconsArgsOfType texp) --- Generates a test function to compare two versions of the given function. --- If the argument and result types must be transformed between types --- of the two different version, also auxiliary operations are generated --- for the equivalence test. --- If the function is productive, we also return the result type of --- the function in order to generate "limit" functions for this type. genTestFunction :: ComparisonInfo -> Bool -> TransMap -> (Bool, CFuncDecl) -> ([CTypeExpr], [CFuncDecl]) genTestFunction info groundequiv tm (isprod,f) = (if isprod && groundequiv then [newResultTypeA] else [], if groundequiv then [stCmtFunc ("Check ground equivalence of operation " ++ fmod ++ "." ++ fname ++ if isprod then " up to a depth limit" else "") (modName, testName ++ "_GroundEquiv") (realArity f) Private newType [if isprod then let limitvar = (100,"limit") in simpleRule (if isprod then CPVar limitvar : vars else vars) (applyF (easyCheckMod "<~>") [applyE (type2LimitFunc newResultTypeA) [CVar limitvar, callA], applyE (type2LimitFunc newResultTypeA) [CVar limitvar, callB]]) else simpleRule vars (applyF (easyCheckMod "<~>") [callA, callB])] ] else [stFunc testName1 (realArity f) Private (replaceResultType newType newResultTypeB) [simpleRule vars callA] ,stFunc testName2 (realArity f) Private (replaceResultType newType newResultTypeB) [simpleRule vars callB] ,stCmtFunc ("Check equivalence of operation " ++ fmod ++ "." ++ fname) (modName, testName ++ "_Equivalent") 0 Private (baseType (easyCheckMod "Prop")) [simpleRule [] (applyF (easyCheckMod "<=>") [constF testName1, constF testName2])]] ) where (fmod,fname) = funcName f modName = "Compare" both fun (a, b) = (fun a, fun b) testName = "test_" ++ combineTuple (both (replace' '.' '_') $ (fmod, encodeCurryId fname)) "_" testName1 = (modName, testName++"_1") testName2 = (modName, testName++"_2") vars = pVars (realArity f) modA = infPrefixA info ++ "_" ++ fmod modB = infPrefixB info ++ "_" ++ fmod instantiatedFunc = instantiateBool $ typeOfQualType $ funcType f newResultTypeA = mapTypes (infModMapA info) (instantiateBool (resultType (typeOfQualType (funcType f)))) newResultTypeB = mapTypes (infModMapB info) (instantiateBool (resultType (typeOfQualType (funcType f)))) newType = let ftype = mapTypes (infModMapA info) $ genTestFuncType f in if isprod then baseType ("Nat","Nat") ~> ftype else ftype returnTransform = case findTrans tm (resultType $ instantiatedFunc) of Nothing -> id Just tr -> \t -> applyF (modName, tr) [t] -- Since we use the data types from the A version in type of the generated -- test function, we transform the parameters in the call of the B version of -- the tested function using the translator functions from the TransMap. As we -- already have translator functions from data type version A to B, we will -- translate the result of the A function using these functions. The -- comparison of function results will thus be done on the B version of the -- types, while the parameter generation will be done on the A version. callA = returnTransform $ applyF (modA, fname) $ map (\(CPVar v) -> CVar v) vars callB = applyF (modB, fname) $ map transformedVar $ zip (argTypes $ instantiatedFunc) vars transformedVar (texp,exp) = case (texp,exp) of (CTVar _, CPVar v) -> CVar v (CFuncType _ _, CPVar v) -> CVar v (_, CPVar v) -> maybe (CVar v) (\_ -> case findTrans tm texp of Just n -> applyF (modName, n) [CVar v] Nothing -> CVar v) (tconsArgsOfType texp) _ -> error "CPM.Diff.Behavior.transformedVar: This case should be impossible to reach" -- encode a Curry identifier into an alphanum form: encodeCurryId :: String -> String encodeCurryId [] = [] encodeCurryId (c:cs) | isAlphaNum c || c == '_' = c : encodeCurryId cs | otherwise = let oc = ord c in int2hex (oc `div` 16) : int2hex (oc `mod` 16) : encodeCurryId cs where int2hex i = if i<10 then chr (ord '0' + i) else chr (ord 'A' + i - 10) --- Checks if any part of the given type needs to be translated using a --- translator function. needToTranslatePart :: ComparisonInfo -> CTypeExpr -> Bool needToTranslatePart _ (CTVar _) = False needToTranslatePart info (CFuncType e1 e2) = needToTranslatePart info e1 || needToTranslatePart info e2 needToTranslatePart info (CTApply e1 e2) = needToTranslatePart info e1 || needToTranslatePart info e2 needToTranslatePart info (CTCons n) = isMappedType info n --- Checks if the module of the given type is one of the mapped modules, i.e. --- one that is present in two versions. isMappedType :: ComparisonInfo -> (String, String) -> Bool isMappedType info (mod, _) = isJust $ lookup mod (infModMapA info) --- The TransMap contains a map of type expressions to translator function --- names, as well as the next translator function number and a list of the --- translator functions themselves. data TransMap = TransMap [(CTypeExpr, String)] Int [CFuncDecl] --- An empty TransMap. emptyTrans :: TransMap emptyTrans = TransMap [] 0 [] --- Adds an entry to the TransMap. Note that this does not add the --- function itself. Use `addFunc` to add the function. addEntry :: TransMap -> CTypeExpr -> (TransMap, String) addEntry (TransMap m n fs) e = (TransMap ((e, "tt_" ++ show n) : m) (n + 1) fs, "tt_" ++ show n) --- Adds a translator function to the list of functions in the TransMap. addFunc :: TransMap -> CFuncDecl -> TransMap addFunc (TransMap m n fs) f = TransMap m n (f:fs) --- Finds the name of the translator function for a type expression, if it --- exists. findTrans :: TransMap -> CTypeExpr -> Maybe String findTrans (TransMap m _ _) e = lookup e m --- Gets all translator functions from a TransMap. transFuncs :: TransMap -> [CFuncDecl] transFuncs (TransMap _ _ fs) = fs --- Get type declarations for some types that are namespaced to the Prelude --- module, but whose type declarations are not actually contained in the --- Prelude module. predefinedType :: (String, String) -> Maybe CTypeDecl predefinedType x = case x of ("Prelude", "[]") -> Just $ CType ("Prelude", "[]") Public [(0, "a")] [ simpleCCons ("Prelude", "[]") Public [] , simpleCCons ("Prelude", ":") Public [CTVar (0, "a"), listType (CTVar (0, "a"))]] [] ("Prelude", "(,)") -> Just $ CType ("Prelude", "(,)") Public [(0, "a"), (1, "b")] [ simpleCCons ("Prelude", "(,)") Public [CTVar (0, "a"), CTVar (1, "b")]] [] ("Prelude", "(,,)") -> Just $ CType ("Prelude", "(,,)") Public [(0, "a"), (1, "b"), (2, "c")] [ simpleCCons ("Prelude", "(,,)") Public [CTVar (0, "a"), CTVar (1, "b"), CTVar (2, "c")]] [] ("Prelude", "(,,,)") -> Just $ CType ("Prelude", "(,,,)") Public [(0, "a"), (1, "b"), (2, "c"), (3, "d")] [ simpleCCons ("Prelude", "(,,,)") Public [CTVar (0, "a"), CTVar (1, "b"), CTVar (2, "c"), CTVar (3, "d")]] [] _ -> Nothing --- The ACYCache caches the AbstractCurry representations of Curry modules, --- specific to the directory it is stored in (to support multiple versions of a --- module). data ACYCache = ACYCache [(String, [(String, CurryProg)])] --- An empty ACYCache. emptyACYCache :: ACYCache emptyACYCache = ACYCache [] --- Finds a module inside an ACYCache, regardless of its directory. findModule :: String -> ACYCache -> Maybe CurryProg findModule mod (ACYCache ps) = case lookup mod ps of Nothing -> Nothing Just ms -> listToMaybe $ map snd ms --- Finds a module inside the ACYCache that was read from a specific directory. findModuleDir :: String -> String -> ACYCache -> Maybe CurryProg findModuleDir dir mod (ACYCache ps) = case lookup mod ps of Nothing -> Nothing Just ms -> lookup dir ms --- Adds a module to the ACYCache without a directory. addModule :: String -> CurryProg -> ACYCache -> ACYCache addModule mod p (ACYCache ps) = case lookup mod ps of Just _ -> ACYCache ps Nothing -> ACYCache $ (mod, [("", p)]):ps --- Adds a module to the ACYCache with a directory. addModuleDir :: String -> String -> CurryProg -> ACYCache -> ACYCache addModuleDir dir mod p (ACYCache ps) = case lookup mod ps of Just ms -> case lookup dir ms of Just _ -> ACYCache ps Nothing -> ACYCache $ (mod, (dir, p):ms):(delete (mod, ms) ps) Nothing -> ACYCache $ (mod, [(dir, p)]):ps --- Generate a translator function for a type expression. Expects a CTCons. --- --- @param cfg current CPM configuration --- @param repo package repository --- @param gc the global package cache --- @param info information about the current comparison --- @param tm the map of translator functions --- @param e the type expression to generate a translator for genTranslatorFunction :: Config -> Repository -> GC.GlobalCache -> ComparisonInfo -> ACYCache -> TransMap -> CTypeExpr -> ErrorLogger (ACYCache, TransMap) genTranslatorFunction cfg repo gc info acy tm texp = -- TODO: generate also translation functions for functional types. -- This requires type translator in both directions but currently -- we generate only one direction. -- For instance, to translate a function A->B into A'->B': -- (A->B)2(A'->B') f = \x -> B2B' (f (A'2A x)) let (mod, n) = maybe (error $ "CPM.Diff.Behavior.genTranslatorFunction: " ++ "cannot generate type translation function for type:\n" ++ pPrint (ppCTypeExpr defaultOptions texp)) fst (tconsArgsOfType texp) in -- Don't generate another translator if there already is one for the current -- type. if isJust $ findTrans tm t' then return (acy, tm) else findTypeInModules cfg repo gc info acy (mod,n) >>= -- We want to work on the constructors with all type variables instantiated -- with the types from the type that we're supposed to build a translator for. \(acy', typeDecl) -> (return $ instantiate typeDecl t') >>= -- Add the entry at this point to make sure that it's available when we -- generate the other translators and if we need to call it recursively later -- on. \instTypeDecl -> (return $ addEntry tm t') >>= \(tm', name) -> foldM (uncurry $ genTranslatorFunction cfg repo gc info) (acy', tm') (transExprs instTypeDecl) >>= \(acy'', tm'') -> let aType = prefixMappedTypes (infPrefixA info) t' bType = prefixMappedTypes (infPrefixB info) t' fType = CFuncType aType bType fName = ("Compare", name) mapIfNeeded modMap m = if isMappedType info (m, "") then fromJust $ lookup m modMap else m mapIfNeededA = mapIfNeeded (infModMapA info) mapIfNeededB = mapIfNeeded (infModMapB info) transformer (i,te) = case te of CTVar _ -> CVar (i, "x" ++ show i) CFuncType _ _ -> CVar (i, "x" ++ show i) _ -> case findTrans tm'' te of Nothing -> CVar (i, "x" ++ show i) Just tn -> applyF ("Compare", tn) [CVar (i, "x" ++ show i)] ruleForCons (CCons (m, cn) _ es) = simpleRule [pattern] call where pattern = CPComb (mapIfNeededA m, cn) (pVars (length es)) -- Apply constructor from B, calling translator functions if neccessary. call = applyF (mapIfNeededB m, cn) $ map transformer $ zip (take (length es) [0..]) es ruleForCons (CRecord (m, cn) _ fs) = simpleRule [pattern] call where pattern = CPComb (mapIfNeededA m, cn) (pVars (length fs)) call = applyF (mapIfNeededB m, cn) $ map transformer $ zip (take (length fs) [0..]) (map (\(CField _ _ es) -> es) fs) synRule e = simpleRule [CPVar (0, "x0")] call where call = transformer (0, e) in case instTypeDecl of CType _ _ _ cs _ -> return $ (acy'', addFunc tm'' (stFunc fName 1 Public fType (map ruleForCons cs))) CTypeSyn _ _ _ e -> return $ (acy'', addFunc tm'' (stFunc fName 1 Public fType [synRule e])) CNewType _ _ _ c _ -> return $ (acy'', addFunc tm'' (stFunc fName 1 Public fType [ruleForCons c])) where -- Since our test functions always use polymorphic types instantiated to Bool, -- we generate our translator functions for Bool-instantiated types as well. t' = instantiateBool texp -- Finds all type expressions in the instantiated constructors that contain -- types that need to be translated. transExprs cs = filter (needToTranslatePart info) $ nub $ extractExprs cs extractExprs (CType _ _ _ es _) = concat $ map extractExprsCons es extractExprs (CTypeSyn _ _ _ e) = [e] extractExprs (CNewType _ _ _ c _) = extractExprsCons c extractExprsCons (CCons _ _ es) = es extractExprsCons (CRecord _ _ fs) = map (\(CField _ _ es) -> es) fs -- Recursively prefixes those types which are present in two versions. prefixMappedTypes pre (CTCons (mod', n')) = if isMappedType info (mod', n') then CTCons (pre ++ "_" ++ mod', n') else CTCons (mod', n') prefixMappedTypes _ (CTVar v) = CTVar v prefixMappedTypes pre (CFuncType e1 e2) = CFuncType (prefixMappedTypes pre e1) (prefixMappedTypes pre e2) prefixMappedTypes pre (CTApply e1 e2) = CTApply (prefixMappedTypes pre e1) (prefixMappedTypes pre e2) -- Finds the type declaration for a given qualified type constructor. -- If the module is not in the ACYCache, it is read and added to the cache. findTypeInModules :: Config -> Repository -> GC.GlobalCache -> ComparisonInfo -> ACYCache -> QName -> ErrorLogger (ACYCache, CTypeDecl) findTypeInModules cfg repo gc info acy (mod,n) = case predefinedType (mod, n) of Just ty -> return (acy, ty) Nothing -> (case findModule mod acy of Just p -> return $ p Nothing -> resolveAndCopyDependencies cfg repo gc (infSourceDirA info) >>= \deps -> readAbstractCurryFromDeps (infSourceDirA info) deps mod >>= return) >>= \prog -> case filter ((== n) . snd . typeName) (types prog) of [] -> fail $ "No type defined '" ++ n ++ "' in module '" ++ mod ++ "'" (x:_) -> return (addModule mod prog acy, x) --- Replaces type variables with their expression in the map if there is one, --- leaves them alone otherwise. maybeReplaceVar :: [(CVarIName, CTypeExpr)] -> CTypeExpr -> CTypeExpr maybeReplaceVar vm (CTVar v) = case lookup v vm of Nothing -> CTVar v Just e' -> e' maybeReplaceVar _ (CTCons n) = CTCons n maybeReplaceVar vm (CFuncType e1 e2) = CFuncType (maybeReplaceVar vm e1) (maybeReplaceVar vm e2) maybeReplaceVar vm (CTApply e1 e2) = CTApply (maybeReplaceVar vm e1) (maybeReplaceVar vm e2) --- Instantiates all constructors of a type declaration with the types from a --- constructor type expression. Type variables that are not used in the --- constructor referenced by the type expression remain as they are. instantiate :: CTypeDecl -> CTypeExpr -> CTypeDecl instantiate tdecl texp = case texp of CTVar _ -> error "CPM.Diff.Behavior.instantiate: Cannot instantiate CTVar" CFuncType _ _ -> error "CPM.Diff.Behavior.instantiate: Cannot instantiate CFuncType" _ -> maybe (error "CPM.Diff.Behavior.instantiate: Cannot instantiate CTApply") (\ (_,texps) -> instantiate' tdecl texps) (tconsArgsOfType texp) where instantiate' (CType n v vs cs d) es = CType n v vs (map cons cs) d where varMap = zip vs es cons (CCons n' v' es') = CCons n' v' $ map (maybeReplaceVar varMap) es' cons (CRecord n' v' fs') = CRecord n' v' $ map maybeReplaceField fs' maybeReplaceField (CField n'' v'' e) = CField n'' v'' $ maybeReplaceVar varMap e instantiate' (CTypeSyn n v vs e) es = CTypeSyn n v vs $ maybeReplaceVar varMap e where varMap = zip vs es instantiate' (CNewType n v vs c d) es = CNewType n v vs (cons c) d where varMap = zip vs es cons (CCons n' v' es') = CCons n' v' $ map (maybeReplaceVar varMap) es' cons (CRecord n' v' fs') = CRecord n' v' $ map maybeReplaceField fs' maybeReplaceField (CField n'' v'' e) = CField n'' v'' $ maybeReplaceVar varMap e --- Recursively transforms the module names of all type constructors in a --- type expression into new module names according to a mapping of --- module names. mapTypes :: [(String,String)] -> CTypeExpr -> CTypeExpr mapTypes mmap (CFuncType a b) = CFuncType (mapTypes mmap a) (mapTypes mmap b) mapTypes mmap (CTApply a b) = CTApply (mapTypes mmap a) (mapTypes mmap b) mapTypes _ v@(CTVar _) = v mapTypes mmap (CTCons (m, n)) = case lookup m mmap of Nothing -> CTCons (m, n) Just m' -> CTCons (m', n) realArity :: CFuncDecl -> Int realArity (CFunc _ _ _ t _) = arityOfType (typeOfQualType t) realArity (CmtFunc _ _ _ _ t _) = arityOfType (typeOfQualType t) arityOfType :: CTypeExpr -> Int arityOfType (CFuncType _ b) = 1 + arityOfType b arityOfType (CTVar _) = 0 arityOfType (CTCons _) = 0 arityOfType (CTApply _ _) = 0 -- Wrap an expression of a given type with a call to a corresponding -- depth-limit function: type2LimitFunc :: CTypeExpr -> CExpr type2LimitFunc texp = case texp of CTVar _ -> error "type2LimitFunc: cannot generate limit operation for type variable" CFuncType _ _ -> error "type2LimitFunc: cannot generate limit operation for function type" _ -> maybe (error "type2LimitFunc: cannot generate limit operation for type application") (\ (tc,ts) -> applyF (transCTCon2Limit tc) (map type2LimitFunc ts)) (tconsArgsOfType texp) -- Translate a type constructor name to the name of the corresponding limit -- operation: transCTCon2Limit :: QName -> QName transCTCon2Limit (_,tcn) = ("Compare", "limit" ++ trans tcn) where trans n | n=="[]" = "List" | n=="()" = "Unit" | "(," `isPrefixOf` n = "Tuple" ++ show (length n - 1) | otherwise = n --- Qualify a name by `Test.Prop` module: easyCheckMod :: String -> QName easyCheckMod n = ("Test.Prop", n) --- Generates a function type for the test function by replacing the result --- type with `Test.Prop.Prop`. Also instantiates polymorphic types to --- Bool. genTestFuncType :: CFuncDecl -> CTypeExpr genTestFuncType f = replaceResultType t (baseType (easyCheckMod "Prop")) where t = instantiateBool $ typeOfQualType $ funcType f --- Instantiates all type variables in a type expression to `Prelude.Bool`. instantiateBool :: CTypeExpr -> CTypeExpr instantiateBool (CTVar _) = boolType instantiateBool (CTCons n) = CTCons n instantiateBool (CTApply a b) = CTApply (instantiateBool a) (instantiateBool b) instantiateBool (CFuncType a b) = CFuncType (instantiateBool a) (instantiateBool b) --- Replaces the result type of a function type. replaceResultType :: CTypeExpr -> CTypeExpr -> CTypeExpr replaceResultType (CFuncType a (CTVar _)) z = CFuncType a z replaceResultType (CFuncType a (CTCons _)) z = CFuncType a z replaceResultType (CFuncType a (CTApply _ _)) z = CFuncType a z replaceResultType (CFuncType a b@(CFuncType _ _)) z = CFuncType a (replaceResultType b z) replaceResultType (CTVar _) z = z replaceResultType (CTCons _) z = z replaceResultType (CTApply _ _) z = z combineTuple :: (String, String) -> String -> String combineTuple (a, b) s = a ++ s ++ b showQName :: QName -> String showQName qn = combineTuple qn "." showFuncNames :: [CFuncDecl] -> String showFuncNames = intercalate ", " . map (showQName . funcName) replace' :: Eq a => a -> a -> [a] -> [a] replace' _ _ [] = [] replace' o n (x:xs) | x == o = n : replace' o n xs | otherwise = x : replace' o n xs ------------------------------------------------------------------------------ --- Finds a list of functions that can be compared. At the moment, this uses the --- functionality from `CPM.Diff.API` to compare the public interfaces of both --- module versions and find the functions that have not changed between --- versions. --- --- @param cfg the CPM configuration --- @param repo the current repository --- @param gc the global package cache --- @param dirA the directory of the A version of the package --- @param dirB the directory of the B version of the package --- @param useanalysis - use program analysis to filter non-term. operations? --- @param mods - the modules to compare (if Nothing, compare exported modules) --- @return a tuple consisting of an ACYCache, a list of functions to --- be compared (with a flag which is true if they are productive, --- might be non-terminating but can be compared level-wise), --- and a list of non-comparable functions with a reason findFunctionsToCompare :: Config -> Repository -> GC.GlobalCache -> String -> String -> Bool -> Maybe [String] -> ErrorLogger (ACYCache, [String], [(Bool,CFuncDecl)], [(CFuncDecl, FilterReason)]) findFunctionsToCompare cfg repo gc dirA dirB useanalysis onlymods = do pkgA <- loadPackageSpec dirA pkgB <- loadPackageSpec dirB depsA <- resolveAndCopyDependencies cfg repo gc dirA let cmods = intersect (exportedModules pkgA) (exportedModules pkgB) let mods = maybe cmods (intersect cmods) onlymods if null mods then logInfo "No exported modules to compare" >> return (emptyACYCache,[],[],[]) else do logInfo ("Comparing modules: "++ intercalate " " mods) diffs <- APIDiff.compareModulesInDirs cfg repo gc dirA dirB (Just mods) (acy, allFuncs) <- findAllFunctions dirA dirB pkgA depsA emptyACYCache mods logDebug ("All public functions: " ++ showFuncNames allFuncs) let areDiffThenFilter = thenFilter allFuncs Diffing let areHighArityThenFilter = thenFilter allFuncs HighArity let areIOActionThenFilter = thenFilter allFuncs IOAction let areNoCompareThenFilter = thenFilter allFuncs NoCompare let areNonMatchingThenFilter = thenFilter allFuncs NonMatchingTypes let haveFuncArgThenFilter = thenFilter allFuncs FuncArg (emptyFilter ((liftFilter $ filterDiffingFunctions diffs) acy allFuncs) `areDiffThenFilter` liftFilter filterHighArity `areHighArityThenFilter` liftFilter filterIOAction `areIOActionThenFilter` filterNoCompare dirA dirB depsA `areNoCompareThenFilter` filterNonMatchingTypes dirA dirB depsA `areNonMatchingThenFilter` filterFuncArg dirA dirB depsA `haveFuncArgThenFilter` liftFilter id ) >>= terminationFilter pkgA dirA depsA useanalysis --- Filters out functions which are possibly non-terminating and --- non-productive, and mark productive functions so that they are --- tested not by standard equality. terminationFilter :: Package -> String -> [Package] -> Bool -> (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]) -> ErrorLogger (ACYCache, [String], [(Bool,CFuncDecl)], [(CFuncDecl, FilterReason)]) terminationFilter _ _ _ False (a,fs,rm) = return (a, [], map (\f->(False,f)) fs, rm) terminationFilter pkgA dirA depsA True (acy, funcs, rm) = do let currypath = loadPathForPackage pkgA dirA depsA mods = nub (map (fst . funcName) funcs) ainfo <- analyzeModules "productivity" productivityAnalysis currypath mods -- compute functions which should be definitely compared (due to TERMINATE -- or PRODUCTIVE pragmas): modscmts <- liftIOEL $ mapM (getCompare currypath) mods let termfuns = concatMap (\md -> md ("TERMINATE" `isInfixOf`)) modscmts prodfuns = concatMap (\md -> md ("PRODUCTIVE" `isInfixOf`)) modscmts logDebug ("Functions marked with TERMINATE: " ++ showFuncNames termfuns) >> return () logDebug ("Functions marked with PRODUCTIVE: " ++ showFuncNames prodfuns) >> return () let infoOf f = fromMaybe Looping (lookupProgInfo (funcName f) ainfo) ntfuncs = filter (\f -> infoOf f == Looping && f `notElem` termfuns && f `notElem` prodfuns) funcs return (acy, currypath, map (\f -> (not (infoOf f == Terminating || f `elem` termfuns), f)) (funcs \\ ntfuncs), rm ++ map (\f -> (f,NonTerm)) ntfuncs) where --- Get functions in a module satisfying a given predicate on pragma comments getCompare currypath modname = do src <- lookupModuleSource currypath modname (_,comments) <- case src of Nothing -> error $ "Module not found: " ++ modname Just (_, file) -> readComments file return (\p -> filter (\f -> let (mn,fn) = funcName f in mn == modname && p (getFuncComment fn comments)) funcs) -- Analyze a list of modules with some static program analysis in a given -- load path. Returns the combined analysis information. -- Raises an error if something goes wrong. analyzeModules :: (Read a, Show a) => String -> Analysis a -> [String] -> [String] -> ErrorLogger (ProgInfo a) analyzeModules ananame analysis currypath mods = do logDebug ("Running " ++ ananame ++ " analysis on modules: " ++ intercalate ", " mods) logDebug ("CURRYPATH=" ++ joinSearchPath currypath) anainfos <- liftIOEL $ mapM (analyzeModule analysis currypath) mods logDebug "Analysis finished" return $ foldr combineProgInfo emptyProgInfo anainfos -- Analyze a module with some static program analysis in a given -- load path. Raises an error if something goes wrong. analyzeModule :: (Read a, Show a) => Analysis a -> [String] -> String -> IO (ProgInfo a) analyzeModule analysis currypath mod = do setEnv "CURRYPATH" (joinSearchPath currypath) aresult <- analyzeGeneric analysis mod unsetEnv "CURRYPATH" either return (\e -> do putStrLn "WARNING: error occurred during analysis:" putStrLn e putStrLn "Ignoring analysis information" return emptyProgInfo) aresult emptyFilter :: ErrorLogger (ACYCache, [CFuncDecl]) -> ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]) emptyFilter st = st >>= \(a, fs) -> return (a, fs, []) --- Reasons why a function can be excluded from the list of functions to be --- compared. data FilterReason = NoReason | HighArity | IOAction | NoCompare | NonMatchingTypes | Diffing | FuncArg | NonTerm --- Chain filter functions and mark the ones removed by the previous filter --- with a given reason. thenFilter :: [CFuncDecl] -> FilterReason -> ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]) -> (ACYCache -> [CFuncDecl] -> ErrorLogger (ACYCache, [CFuncDecl])) -> ErrorLogger (ACYCache, [CFuncDecl], [(CFuncDecl, FilterReason)]) thenFilter allFuncs r st f = st >>= \(a, fs, rm) -> f a fs >>= \(a', fs') -> return (a', fs', rm ++ zip (findMissing rm fs) (repeat r)) where findMissing rm fs = (allFuncs \\ (map fst rm)) \\ fs --- Lifts a simple filter to a filter that executes inside the IO monad and --- takes an ACYCache. liftFilter :: ([CFuncDecl] -> [CFuncDecl]) -> (ACYCache -> [CFuncDecl] -> ErrorLogger (ACYCache, [CFuncDecl])) liftFilter f = \a fs -> return (a, f fs) --- Excludes those functions which take a functional argument, either directly --- or via a nested type. filterFuncArg :: String -> String -> [Package] -> ACYCache -> [CFuncDecl] -> ErrorLogger (ACYCache, [CFuncDecl]) filterFuncArg = filterFuncsDeep checkFunc where checkFunc (CFuncType _ _) = True checkFunc (CTVar _) = False checkFunc (CTCons _) = False checkFunc (CTApply _ _) = False --- Filters functions via a predicate on their argument types. Checks the --- predicates on nested types as well. filterFuncsDeep :: (CTypeExpr -> Bool) -> String -> String -> [Package] -> ACYCache -> [CFuncDecl] -> ErrorLogger (ACYCache, [CFuncDecl]) filterFuncsDeep tpred dirA _ deps acy allFuncs = foldM checkFunc (acy, [], []) allFuncs >>= \(acy', _, fns) -> return (acy', fns) where findType n m = case predefinedType n of Nothing -> find ((== n) . typeName) $ filter isTypePublic $ types m Just ty -> Just ty checkFunc (a, c, fs) f = (foldM checkTypeExpr (a, c, False) $ argTypes $ typeOfQualType $ funcType f) >>= \(a', c', r) -> if r then return (a', c', fs) else return (a', c', f:fs) checkTypeExpr (a, c, r) t@(CFuncType e1 e2) = if t `elem` c then return (a, c, r) else if tpred t then return (a, c, True) else checkTypeExpr (a, c, r) e1 >>= \ (a', c', r') -> checkTypeExpr (a', e1:c', r') e2 >>= \ (a'', c'', r'') -> return (a'', e2:c'', r || r' || r'') checkTypeExpr (a, c, r) t@(CTApply e1 e2) = if t `elem` c then return (a, c, r) else if tpred t then return (a, c, True) else checkTypeExpr (a, c, r) e1 >>= \ (a', c', r') -> checkTypeExpr (a', e1:c', r') e2 >>= \ (a'', c'', r'') -> return (a'', e2:c'', r || r' || r'') checkTypeExpr (a, c, r) (CTVar _) = return (a, c, r) checkTypeExpr (a, c, r) t@(CTCons n@(mod, _)) = if t `elem` c then return (a, c, r) else if tpred t then return (a, c, True) else return (a, c, r) >>= \(a', c', _) -> readCached dirA deps a' mod >>= \(a'', prog) -> case findType n prog of Nothing -> fail $ "Type '" ++ show n ++ "' not found." Just t' -> checkType a'' (t:c') t' >>= \(a''', c'', r'') -> return (a''', c'', r || r'') checkType a ts (CType _ _ _ cs _) = foldM checkCons (a, ts, False) cs checkType a ts (CTypeSyn _ _ _ e) = checkTypeExpr (a, ts, False) e checkType a ts (CNewType _ _ _ c _) = checkCons (a, ts, False) c checkCons (a, ts, r) (CCons _ _ es) = foldM checkTypeExpr (a, ts, r) es checkCons (a, ts, r) (CRecord _ _ fs) = let es = map (\(CField _ _ e) -> e) fs in foldM checkTypeExpr (a, ts, r) es --- Filters out functions marked with the NOCOMPARE pragma. filterNoCompare :: String -> String -> [Package] -> ACYCache -> [CFuncDecl] -> ErrorLogger (ACYCache, [CFuncDecl]) filterNoCompare dirA dirB _ a fs = liftIOEL $ do allCommentsA <- mapM (readComments . modPath dirA) modules allCommentsB <- mapM (readComments . modPath dirB) modules let commentsA = funcsWithComments $ zip modules allCommentsA let commentsB = funcsWithComments $ zip modules allCommentsB return (a, filter (not . noCompare commentsA commentsB) fs) where modules = nub $ map (fst . funcName) fs modPath dir mod = dir "src" joinPath (splitOn "." mod) ++ ".curry" -- Zip up all functions with their respective comments. funcsWithComments cmts = zip fs (map (getFuncComment' cmts) fs) getFuncComment' cmts f = let mname = fst $ funcName f lname = snd $ funcName f in case lookup mname cmts of Nothing -> "" Just cs -> getFuncComment lname $ snd cs noCompare cmtsA cmtsB f = noCompare' cmtsA f || noCompare' cmtsB f -- Check if NOCOMPARE is mentioned in the comments noCompare' cmts f = case lookup f cmts of Nothing -> False Just c -> "NOCOMPARE" `isInfixOf` c --- Removes all functions that have more than five arguments (currently the --- maximum number of parameters that CurryCheck supports in property tests). filterHighArity :: [CFuncDecl] -> [CFuncDecl] filterHighArity = filter ((<= 5) . length . argTypes . typeOfQualType . funcType) --- Removes all IO actions since they cannot be compared as --- properties in CurryCheck. filterIOAction :: [CFuncDecl] -> [CFuncDecl] filterIOAction = filter (not . isIOType . resultType . typeOfQualType . funcType) --- Removes all functions that have a diff associated with their name from the --- given list of functions. --- --- @param fs the functions to filter --- @param ds a list of pairs of module names and diffs filterDiffingFunctions :: [(String, Differences)] -> [CFuncDecl] -> [CFuncDecl] filterDiffingFunctions diffs allFuncs = nub $ concatMap filterModule modules where modules = nub $ map (fst . funcName) allFuncs diffsForModule mod = case lookup mod diffs of Nothing -> [] Just (_, funcDiffs, _, _) -> map funcDiffName funcDiffs funcDiffName (Addition f) = funcName f funcDiffName (Removal f) = funcName f funcDiffName (Change _ f) = funcName f filterModule mod = filter (not . (`elem` (diffsForModule mod)) . funcName) (funcsForModule mod) funcsForModule mod = filter ((== mod) . fst . funcName) allFuncs --- Excludes those functions whose types do not match in both versions. Checks --- nested types. filterNonMatchingTypes :: String -> String -> [Package] -> ACYCache -> [CFuncDecl] -> ErrorLogger (ACYCache, [CFuncDecl]) filterNonMatchingTypes dirA dirB deps acyCache allFuncs = foldM funcTypesCompatible (acyCache, [], []) allFuncs >>= \(acy, _, fns) -> return (acy, fns) where allTypes f = let ft = typeOfQualType (funcType f) in (resultType ft) : (argTypes ft) onlyCons = filter isConsType funcTypesCompatible (a, seen, fs) f = (foldM typesCompatible (a, seen, True) $ onlyCons $ allTypes f) >>= \(a', seen', c) -> if c then return (a', seen', f:fs) else return (a', seen', fs) typesCompatible (a, seen, r) t = case lookup t seen of Just b -> return (a, seen, b && r) Nothing -> typesEqual t dirA dirB deps a [] >>= \(a', r') -> return (a', ((t, r'):seen), r' && r) --- Compares the declarations of types mentioned in a type expression --- recursively. Returns False if the types are different. typesEqual :: CTypeExpr -> String -> String -> [Package] -> ACYCache -> [CTypeExpr] -> ErrorLogger (ACYCache, Bool) typesEqual texp dirA dirB deps acyCache checked = maybe (fail $ "typesEqual not called on type constructor: " ++ show texp) (return . fst) (tconsArgsOfType texp) >>= \n -> let (mod,_) = n in if texp `elem` checked then return (acyCache, True) else readCached dirA deps acyCache mod >>= \(acy',modA) -> readCached dirB deps acy' mod >>= \(acy'', modB) -> let typeA = findType n modA typeB = findType n modB in typesEqual' typeA typeB acy'' where findType n m = case predefinedType n of Nothing -> find ((== n) . typeName) $ filter isTypePublic $ types m Just ty -> Just ty typesEqual' :: Maybe CTypeDecl -> Maybe CTypeDecl -> ACYCache -> ErrorLogger (ACYCache, Bool) typesEqual' (Just (CType n1 v1 tvs1 cs1 _)) (Just (CType n2 v2 tvs2 cs2 _)) acy = if n1 == n2 && v1 == v2 && tvs1 == tvs2 && cs1 == cs2 then foldM (\(a, r) (c1, c2) -> consEqual a c1 c2 >>= \(a', r') -> return (a', r && r')) (acy, True) (zip cs1 cs2) else return (acy, False) typesEqual' (Just (CTypeSyn n1 v1 tvs1 e1)) (Just (CTypeSyn n2 v2 tvs2 e2)) acy = if n1 == n2 && v1 == v2 && tvs1 == tvs2 && e1 == e2 then if isConsType e1 then typesEqual e1 dirA dirB deps acy (texp:checked) else return (acy, True) else return (acy, False) typesEqual' (Just (CNewType n1 v1 tvs1 c1 _)) (Just (CNewType n2 v2 tvs2 c2 _)) acy = if n1 == n2 && v1 == v2 && tvs1 == tvs2 && c1 == c2 then consEqual acy c1 c2 else return (acy, False) typesEqual' (Just (CType _ _ _ _ _)) (Just (CTypeSyn _ _ _ _)) acy = return (acy, False) typesEqual' (Just (CType _ _ _ _ _)) (Just (CNewType _ _ _ _ _)) acy = return (acy, False) typesEqual' (Just (CTypeSyn _ _ _ _)) (Just (CType _ _ _ _ _)) acy = return (acy, False) typesEqual' (Just (CTypeSyn _ _ _ _)) (Just (CNewType _ _ _ _ _)) acy = return (acy, False) typesEqual' (Just (CNewType _ _ _ _ _)) (Just (CType _ _ _ _ _)) acy = return (acy, False) typesEqual' (Just (CNewType _ _ _ _ _)) (Just (CTypeSyn _ _ _ _)) acy = return (acy, False) typesEqual' Nothing (Just _) acy = return (acy, False) typesEqual' (Just _) Nothing acy = return (acy, False) typesEqual' Nothing Nothing acy = return (acy, False) consEqual :: ACYCache -> CConsDecl -> CConsDecl -> ErrorLogger (ACYCache, Bool) consEqual acy (CCons _ _ es1) (CCons _ _ es2) = foldM esEqual (acy, True) (zip es1 es2) where esEqual (a, r) (e1, e2) = if e1 == e2 then if isConsType e1 then typesEqual e1 dirA dirB deps a (texp:checked) else return (acy, r) else return (acy, False) consEqual acy (CRecord _ _ fs1) (CRecord _ _ fs2) = foldM fEqual (acy, True) (zip fs1 fs2) where fEqual (a, r) (f1@(CField _ _ e1), f2@(CField _ _ _)) = if f1 == f2 then if isConsType e1 then typesEqual e1 dirA dirB deps a (texp:checked) else return (acy, r) else return (acy, False) consEqual acy (CCons _ _ _) (CRecord _ _ _) = return (acy, False) consEqual acy (CRecord _ _ _) (CCons _ _ _) = return (acy, False) isTypePublic :: CTypeDecl -> Bool isTypePublic (CType _ v _ _ _) = v == Public isTypePublic (CTypeSyn _ v _ _) = v == Public isTypePublic (CNewType _ v _ _ _) = v == Public isConsType :: CTypeExpr -> Bool isConsType (CTCons _) = True isConsType (CTVar _) = False isConsType (CFuncType _ _) = False isConsType (CTApply t _) = isConsType t ------------------------------------------------------------------------------ --- Reads a module in AbstractCurry form. readCached :: String -> [Package] -> ACYCache -> String -> ErrorLogger (ACYCache, CurryProg) readCached dir deps acyCache mod = case findModuleDir dir mod acyCache of Just p -> return (acyCache, p) Nothing -> do prog <- readAbstractCurryFromDeps dir deps mod return (addModuleDir dir mod prog acyCache, prog) --- Reads all modules of the given package and finds all public functions --- in all of those modules. --- --- @param dirA the directory where copy A of the package is stored --- @param dirB the directory where copy B of the package is stored --- @param pkg the package --- @param deps a list of package dependencies --- @param mods the list of modules to search for public functions findAllFunctions :: String -> String -> Package -> [Package] -> ACYCache -> [String] -> ErrorLogger (ACYCache, [CFuncDecl]) findAllFunctions dirA dirB _ deps acyCache mods = logDebug ("Finding public functions of modules: " ++ intercalate "," mods) >> logDebug ("in package directories " ++ dirA ++ " and " ++ dirB) >> foldM findForMod (acyCache, []) mods >>= \(a, fs) -> return (a, nub fs) where findForMod (acy,fdecls) mod = readCached dirA deps acy mod >>= \(_, progA) -> readCached dirB deps acy mod >>= \(acy'', progB) -> let funcsA = filter isPublic $ functions progA funcsB = filter isPublic $ functions progB in return (acy'', fdecls ++ nubBy (\a b -> funcName a == funcName b) (funcsA ++ funcsB)) --- Checks whether a function is public. isPublic :: CFuncDecl -> Bool isPublic (CFunc _ _ Public _ _) = True isPublic (CFunc _ _ Private _ _) = False isPublic (CmtFunc _ _ _ Public _ _) = True isPublic (CmtFunc _ _ _ Private _ _) = False --- Prepares two packages from the global package cache in two versions for --- comparison by copying them to the temporary directory and building renamed --- versions. --- --- @param cfg the CPM configuration --- @param repo the package repository --- @param gc the global package cache --- @param nameA the name of the first package --- @param verA the version of the first package --- @param nameB the name of the second package --- @param verB the version of the second package preparePackages :: Config -> Repository -> GC.GlobalCache -> String -> Version -> String -> Version -> ErrorLogger ComparisonInfo preparePackages cfg repo gc nameA verA nameB verB = GC.tryFindPackage gc nameA verA >>= \pkgA -> findPackageDir cfg pkgA >>= \dirA -> GC.tryFindPackage gc nameB verB >>= \pkgB -> findPackageDir cfg pkgB >>= \dirB -> preparePackageDirs cfg repo gc dirA dirB --- Prepares two package, one from a directory and one from the global package --- cache. Copies them to a temporary directory and builds renamed versions of --- the packages and all dependencies. --- --- @param cfg the CPM configuration --- @param repo the package repository --- @param gc the global package cache --- @param dirA the directory for the first package --- @param nameB the name of the second package --- @param verB the version of the second package preparePackageAndDir :: Config -> Repository -> GC.GlobalCache -> String -> String -> Version -> ErrorLogger ComparisonInfo preparePackageAndDir cfg repo gc dirA nameB verB = GC.tryFindPackage gc nameB verB >>= \pkgB -> findPackageDir cfg pkgB >>= \dirB -> preparePackageDirs cfg repo gc dirA dirB --- Prepares two packages from two directories for comparison. Copies the --- package files to a temporary directory and creates renamed version of the --- packages and their dependencies. --- --- @param cfg the CPM configuration --- @param repo the package repository --- @param gc the global package cache --- @param dirA the directory containing the first package --- @param dirB the directory containing the second package preparePackageDirs :: Config -> Repository -> GC.GlobalCache -> String -> String -> ErrorLogger ComparisonInfo preparePackageDirs cfg repo gc dirA dirB = do baseTmp <- liftIOEL $ createBaseTemp specA <- loadPackageSpec dirA specB <- loadPackageSpec dirB let versionPrefixA = versionPrefix specA let versionPrefixB = versionPrefix specB let copyDirA = baseTmp ("src_" ++ versionPrefixA) let copyDirB = baseTmp ("src_" ++ versionPrefixB) let destDirA = baseTmp ("dest_" ++ versionPrefixA) let destDirB = baseTmp ("dest_" ++ versionPrefixB) logDebug ("Copying " ++ packageId specA ++ " from " ++ dirA ++ " into " ++ copyDirA) logDebug ("and transforming it into " ++ destDirA) logDebug ("Copying " ++ packageId specB ++ " from " ++ dirB ++ " into " ++ copyDirB) logDebug ("and transforming it into " ++ destDirB) modMapA <- copyAndPrefixPackage cfg repo gc dirA versionPrefixA copyDirA destDirA modMapB <- copyAndPrefixPackage cfg repo gc dirB versionPrefixB copyDirB destDirB return $ ComparisonInfo { infPackageA = specA , infPackageB = specB , infDirA = destDirA , infDirB = destDirB , infSourceDirA = copyDirA , infSourceDirB = copyDirB , infPrefixA = versionPrefixA , infPrefixB = versionPrefixB , infModMapA = modMapA , infModMapB = modMapB } versionPrefix :: Package -> String versionPrefix pkg = "V_" ++ (showVersion' $ version pkg) --- Copies a package from a directory to the temporary directory and creates --- another copy of the package with all its modules and the modules of its --- dependencies prefixed with the given string. --- --- @param cfg the CPM configuration --- @param repo the package repository --- @param gc the global package cache --- @param pkgDir the package directory to copy from --- @param prefix the prefix for the modules --- @param tmpDir the temporary directory to copy the files to --- @param srcDir the temporary directory where the source package is copied --- @param destDir the temporary directory where the prefixed copy is written copyAndPrefixPackage :: Config -> Repository -> GC.GlobalCache -> String -> String -> String -> String -> ErrorLogger [(String, String)] copyAndPrefixPackage cfg repo gc pkgDir prefix srcDir destDir = do liftIOEL $ copyDirectory pkgDir srcDir liftIOEL $ createDirectory destDir prefixPackageAndDeps cfg repo gc srcDir (prefix ++ "_") destDir showVersion' :: Version -> String showVersion' (maj, min, pat, Nothing) = intercalate "_" [show maj, show min, show pat] showVersion' (maj, min, pat, Just pre) = intercalate "_" [show maj, show min, show pat, pre] --- Tries to find the package directory in the global package cache. findPackageDir :: Config -> Package -> ErrorLogger String findPackageDir cfg pkg = do exists <- liftIOEL $ doesDirectoryExist srcDir if not exists then fail $ "Package " ++ (packageId pkg) ++ " not installed" else return srcDir where srcDir = GC.installedPackageDir cfg pkg curry-tools-v3.3.0/cpm/src/CPM/Diff/CurryComments.curry000066400000000000000000000105551377556325500227720ustar00rootroot00000000000000module CPM.Diff.CurryComments ( readComments , SourceLine , getFuncComment ) where import Data.Char import Data.List (isSuffixOf) -- This is adapted from the currydoc source code. --- Reads the pragma comments from a Curry program. --- The first component of the result --- is the comment for the module definition. The second component is a map --- from different source line types to pragma comments on that source line. readComments :: String -> IO (String, [(SourceLine, String)]) readComments filename = do prog <- readFile filename return (groupLines . filter (/= OtherLine) . map classifyLine . lines $ prog) data SourceLine = PragmaCmt String | ModDef | DataDef String | FuncDef String | OtherLine deriving Eq classifyLine :: String -> SourceLine classifyLine line | take 3 line == "{-#" = PragmaCmt (drop 3 line) -- #-} | take 7 line == "module " = ModDef | take 7 line == "import " = ModDef | otherwise = if null id1 then OtherLine else if id1 == "data" || id1 == "type" || id1 == "newtype" then DataDef (getDatatypeName line) else if "'default" `isSuffixOf` id1 then OtherLine else FuncDef id1 where id1 = getFirstId line getDatatypeName = takeWhile isIdChar . dropWhile (== ' ') . dropWhile isIdChar getFirstId :: String -> String getFirstId [] = "" getFirstId (c:cs) | isAlpha c = takeWhile isIdChar (c:cs) | c == '(' = let bracketId = takeWhile (/= ')') cs in if all (`elem` infixIDs) bracketId then bracketId else "" | otherwise = "" isIdChar :: Char -> Bool isIdChar c = isAlphaNum c || c == '_' || c == '\'' infixIDs :: String infixIDs = "~!@#$%^&*+-=<>?./|\\:" groupLines :: [SourceLine] -> (String, [(SourceLine, String)]) groupLines sls = let (modCmts, progCmts) = break (== ModDef) sls in if progCmts == [] then ("", groupProgLines sls) else (concatMap getComment modCmts, groupProgLines (filter (/= ModDef) (tail progCmts))) where getComment src = case src of PragmaCmt cmt -> cmt ++ "\n" _ -> "" groupProgLines :: [SourceLine] -> [(SourceLine, String)] groupProgLines [] = [] groupProgLines (PragmaCmt cmt : sls) = groupComment cmt sls groupProgLines (FuncDef f : sls) = (FuncDef f, "") : skipFuncDefs f sls groupProgLines (DataDef d : sls) = (DataDef d, "") : skipDataDefs d sls groupProgLines (ModDef : sls) = groupProgLines sls groupProgLines (OtherLine : sls) = groupProgLines sls groupComment :: String -> [SourceLine] -> [(SourceLine, String)] groupComment _ [] = [] groupComment cmt (PragmaCmt cmt1 : sls) = groupComment (cmt ++ "\n" ++ cmt1) sls groupComment cmt (FuncDef f : sls) = (FuncDef f, cmt) : skipFuncDefs f sls groupComment cmt (DataDef d : sls) = (DataDef d, cmt) : skipDataDefs d sls groupComment cmt (ModDef : sls) = groupComment cmt sls groupComment cmt (OtherLine : sls) = groupComment cmt sls skipFuncDefs :: String -> [SourceLine] -> [(SourceLine, String)] skipFuncDefs _ [] = [] skipFuncDefs _ (PragmaCmt cmt : sls) = groupProgLines (PragmaCmt cmt : sls) skipFuncDefs _ (DataDef d : sls) = groupProgLines (DataDef d : sls) skipFuncDefs f (FuncDef f1 : sls) = if f == f1 then skipFuncDefs f sls else groupProgLines (FuncDef f1 : sls) skipFuncDefs f (ModDef : sls) = skipFuncDefs f sls skipFuncDefs f (OtherLine : sls) = skipFuncDefs f sls skipDataDefs :: String -> [SourceLine] -> [(SourceLine, String)] skipDataDefs _ [] = [] skipDataDefs _ (PragmaCmt cmt : sls) = groupProgLines (PragmaCmt cmt : sls) skipDataDefs _ (FuncDef f : sls) = groupProgLines (FuncDef f : sls) skipDataDefs d (DataDef d1 : sls) = if d == d1 then skipDataDefs d sls else groupProgLines (DataDef d1 : sls) skipDataDefs d (ModDef : sls) = skipDataDefs d sls skipDataDefs d (OtherLine : sls) = skipDataDefs d sls --- Get the pragma comments for a function from a map from source lines --- to comments. getFuncComment :: String -> [(SourceLine, String)] -> String getFuncComment _ [] = "" getFuncComment fname ((def, cmt):fdcmts) = case def of FuncDef f -> if fname == f then cmt else getFuncComment fname fdcmts _ -> getFuncComment fname fdcmts curry-tools-v3.3.0/cpm/src/CPM/Diff/Rename.curry000066400000000000000000000076411377556325500213710ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- Contains a function that prefixes all modules in a package and all modules --- in all of its transitive dependencies with a given string. -------------------------------------------------------------------------------- module CPM.Diff.Rename (prefixPackageAndDeps) where import System.Directory (doesDirectoryExist, getDirectoryContents, createDirectory) import System.FilePath ((), joinPath, takeDirectory, takeBaseName, takeExtension) import Data.List (splitOn) import CPM.AbstractCurry (transformAbstractCurryInDeps, applyModuleRenames) import CPM.Config (Config) import CPM.ErrorLogger import CPM.Package (Package, loadPackageSpec) import CPM.PackageCache.Runtime as RuntimeCache import CPM.PackageCache.Global as GC import CPM.PackageCopy (resolveAndCopyDependencies) import CPM.Repository (Repository) -- 1. Find all transitive package dependencies. -- 2. Collect all Curry modules in all dependencies in a list with module name -- and actual path on disk. -- 3. Build a map from old module names to prefixed module names. -- 4. Copy each Curry module in the list to its new, prefixed location. If the -- module name contains a dot, then the top-level folder gets the prefix. If -- it contains no dot, then the Curry file itself gets the prefix. Transform -- the Curry module while copying it. --- Prefix all modules in a package and all modules in all of its transitive --- dependencies with a string. --- --- @param cfg - the CPM configuration --- @param repo - the central package index --- @param gc - the global package cache --- @param dir - the directory of the package --- @param prefix - the prefix for all module names --- @param destDir - the destination directory for the modified modules prefixPackageAndDeps :: Config -> Repository -> GC.GlobalCache -> String -> String -> String -> ErrorLogger [(String, String)] prefixPackageAndDeps cfg repo gc dir prefix destDir = do deps <- resolveAndCopyDependencies cfg repo gc dir depMods <- liftIOEL $ (mapM (findAllModulesInPackage . RuntimeCache.cacheDirectory dir) deps) ownMods <- liftIOEL $ findAllModulesInPackage dir let allMods = ownMods ++ concat depMods let modMap = zip (map fst allMods) (map ((prefix ++) . fst) allMods) mapM (copyMod dir deps destDir modMap) allMods return modMap --- Finds all modules in a package. findAllModulesInPackage :: String -> IO [(String, String)] findAllModulesInPackage dir = findMods "" (dir "src") where findMods p d = do entries <- getDirectoryContents d filteredEntries <- return $ filter (\r -> length r >= 1 && head r /= '.') entries curryFiles <- return $ filter ((== ".curry") . takeExtension) filteredEntries directoryFlags <- mapM doesDirectoryExist (map (d ) filteredEntries) directories <- return $ map fst $ filter snd $ zip filteredEntries directoryFlags depMods <- mapM (\d' -> findMods d' (d d')) directories return $ (map (modWithPath p d) curryFiles) ++ concat depMods modWithPath p d m = if p == "" then (takeBaseName m, d m) else (p ++ "." ++ takeBaseName m, d m) --- Copies a module from one directory to another while renaming both the module --- itself as well as any references to other modules inside that module. copyMod :: String -> [Package] -> String -> [(String, String)] -> (String, String) -> ErrorLogger () copyMod origDir deps dest nameMap (name, _) = do liftIOEL $ do dirExists <- doesDirectoryExist (takeDirectory destPath) if dirExists then return () else createDirectory (takeDirectory destPath) transformAbstractCurryInDeps origDir deps (applyModuleRenames nameMap) name destPath where newName = case lookup name nameMap of Nothing -> name Just n' -> n' pathParts = splitOn "." newName destPath = (joinPath (dest:pathParts)) ++ ".curry" curry-tools-v3.3.0/cpm/src/CPM/ErrorLogger.curry000066400000000000000000000170671377556325500215460ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- Contains combinators for chaining IO actions that can fail and log messages. -------------------------------------------------------------------------------- module CPM.ErrorLogger ( ErrorLogger (runErrorLogger) , LogEntry , LogLevel (..), logLevelOf , logAt, getLogLevel, setLogLevel, getWithShowTime, setWithShowTime , logInfo, logDebug, logError, logCritical, showLogEntry, levelGte , putStrELM, putStrLnELM , fromErrorLogger , showExecCmd, execQuietCmd, liftIOEL, tryEL , inDirectoryEL, inTempDirEL ) where import System.IO ( hPutStrLn, stderr ) import System.Process ( exitWith, system ) import System.Directory import CPM.FileUtil import Debug.Profile -- for show run-time import Text.Pretty hiding (empty) -- A value or an error, along with logs. type ErrorLog a = ([LogEntry], Either LogEntry a) --- An error logging IO monad. newtype ErrorLogger a = ErrorLogger { runErrorLogger :: LogLevel -> Bool -> IO ((LogLevel, Bool), ErrorLog a) } --- A log entry. data LogEntry = LogEntry LogLevel String logLevelOf :: LogEntry -> LogLevel logLevelOf (LogEntry ll _) = ll --- A log level. data LogLevel = Quiet | Info | Debug | Error | Critical deriving Eq --------------------------------------------------------------------------- instance Functor ErrorLogger where fmap f e = ErrorLogger $ \l s -> do (st, (msgs, err)) <- runErrorLogger e l s let (glob, _) = st mapM (showLogEntry glob) msgs case err of Left v -> return (st, ([], Left v)) Right a -> return (st, ([], Right (f a))) instance Applicative ErrorLogger where pure = return f <*> v = f >>= \f' -> fmap f' v instance Alternative ErrorLogger where empty = fail "empty" a <|> b = ErrorLogger $ \l s -> do (st, (msgs, a')) <- runErrorLogger a l s let (glob, showTime) = st mapM (showLogEntry glob) msgs case a' of Left _ -> runErrorLogger b glob showTime Right v -> return (st, ([], Right v)) instance Monad ErrorLogger where return a = ErrorLogger $ \l s -> return ((l, s), ([], Right a)) m >>= f = ErrorLogger $ \l s -> do (st, (msgs, err)) <- runErrorLogger m l s let (glob, showTime) = st mapM (showLogEntry glob) msgs case err of Right v -> do (st', (msgs', err')) <- runErrorLogger (f v) glob showTime return $ (st', (msgs', err')) Left e -> return $ (st, ([], Left e)) instance MonadFail ErrorLogger where fail msg = ErrorLogger $ \l s -> return ((l, s), ([logMsg], Left logMsg)) where logMsg = LogEntry Critical msg --- Renders a log entry to stderr. showLogEntry :: LogLevel -> LogEntry -> IO () showLogEntry minLevel (LogEntry lvl msg) = do if levelGte lvl minLevel then mapM_ (\l -> hPutStrLn stderr $ pPrint $ lvlText <+> text l) (lines msg) else return () where lvlText = case lvl of Quiet -> text "QUIET " -- should not occur... Info -> text "INFO " Debug -> green $ text "DEBUG " Critical -> red $ text "CRITICAL " Error -> red $ text "ERROR " --- Compares two log levels. levelGte :: LogLevel -> LogLevel -> Bool levelGte Debug Debug = True levelGte Debug Quiet = False levelGte Debug Info = False levelGte Debug Error = False levelGte Debug Critical = False levelGte Info Debug = True levelGte Info Info = True levelGte Info Quiet = False levelGte Info Error = False levelGte Info Critical = False levelGte Quiet Debug = True levelGte Quiet Quiet = True levelGte Quiet Info = False levelGte Quiet Error = False levelGte Quiet Critical = False levelGte Error Debug = True levelGte Error Info = True levelGte Error Quiet = True levelGte Error Error = True levelGte Error Critical = True levelGte Critical Debug = True levelGte Critical Info = True levelGte Critical Quiet = True levelGte Critical Error = True levelGte Critical Critical = True --- Logs a message at a user-defined level. logAt :: LogLevel -> String -> ErrorLogger () logAt lvl msg = ErrorLogger $ \l wst -> if wst then do runtime <- getProcessInfos >>= return . maybe 0 id . lookup ElapsedTime return ((l, wst), ([LogEntry lvl (showTime runtime ++ 's':' ':msg)], Right ())) else return ((l, wst), ([LogEntry lvl msg], Right ())) where showTime t = show (t `div` 1000) ++ "." ++ show ((t `mod` 1000) `div` 10) --- Logs a message at the info level. logInfo :: String -> ErrorLogger () logInfo = logAt Info --- Logs a message at the debug level. logDebug :: String -> ErrorLogger () logDebug = logAt Debug --- Logs a message at the error level. logError :: String -> ErrorLogger () logError = logAt Error --- Logs a message at the critical level. logCritical :: String -> ErrorLogger () logCritical = logAt Critical --- Prints a string in the `ErrorLogger` monad. putStrELM :: String -> ErrorLogger () putStrELM = liftIOEL . putStr --- Prints a line in the `ErrorLogger` monad. putStrLnELM :: String -> ErrorLogger () putStrLnELM = liftIOEL . putStrLn --- Transforms an error logger action into a standard IO action. --- It shows all messages and, if the result is not available, --- exits with a non-zero code. --- The first argument specifies the logging level for messages. --- If the second argument is true, timings are shown in the messages. fromErrorLogger :: LogLevel -> Bool -> ErrorLogger a -> IO a fromErrorLogger l s a = do ((glob, _), (msgs, err)) <- runErrorLogger a l s mapM (showLogEntry glob) msgs case err of Right v -> return v Left m -> showLogEntry glob m >> exitWith 1 --- Executes a system command and show the command as debug message. showExecCmd :: String -> ErrorLogger Int showExecCmd cmd = logDebug ("Executing: " ++ cmd) >> liftIOEL (system cmd) --- Executes a parameterized system command. --- The parameter is set to `-q` unless the LogLevel is Debug. execQuietCmd :: (String -> String) -> ErrorLogger Int execQuietCmd cmd = logDebug ("Executing: " ++ cmd "") >> ErrorLogger (\l s -> do i <- system $ cmd (if l == Debug then "" else "-q") return ((l, s), ([], Right i))) getLogLevel :: ErrorLogger LogLevel getLogLevel = ErrorLogger $ \ l s -> return ((l, s), ([], Right l)) getWithShowTime :: ErrorLogger Bool getWithShowTime = ErrorLogger $ \ l s -> return ((l, s), ([], Right s)) setLogLevel :: LogLevel -> ErrorLogger () setLogLevel l = ErrorLogger $ \ _ s -> return ((l, s), ([], Right ())) setWithShowTime :: Bool -> ErrorLogger () setWithShowTime s = ErrorLogger $ \ l _ -> return ((l, s), ([], Right ())) liftIOEL :: IO a -> ErrorLogger a liftIOEL ma = ErrorLogger (\l s -> do a <- ma return ((l, s), ([], Right a))) --- Tries to execute an EL action and returns either an error that --- occurred or the value. tryEL :: ErrorLogger a -> ErrorLogger (Either LogEntry a) tryEL a = liftIOEL $ fmap (snd . snd) $ runErrorLogger a Quiet False --- Executes an EL action with the current directory set to a specific --- directory. inDirectoryEL :: String -> ErrorLogger b -> ErrorLogger b inDirectoryEL dir b = do previous <- liftIOEL getCurrentDirectory liftIOEL $ setCurrentDirectory dir b' <- b liftIOEL $ setCurrentDirectory previous return b' --- Executes an EL action with the current directory set to CPM's temporary --- directory. inTempDirEL :: ErrorLogger b -> ErrorLogger b inTempDirEL b = do t <- liftIOEL tempDir exists <- liftIOEL $ doesDirectoryExist t if exists then return () else liftIOEL $ createDirectory t inDirectoryEL t b curry-tools-v3.3.0/cpm/src/CPM/FileUtil.curry000066400000000000000000000130601377556325500210170ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- Some utilities for deailing with files and directories --- for the Curry Package Manager. -------------------------------------------------------------------------------- module CPM.FileUtil ( joinSearchPath , copyDirectory , createSymlink , removeSymlink , isSymlink , linkTarget , copyDirectoryFollowingSymlinks , quote , tempDir , cleanTempDir , inTempDir , inDirectory , recreateDirectory , removeDirectoryComplete , safeReadFile, checkAndGetVisibleDirectoryContents , whenFileExists, ifFileExists ) where import System.Directory ( doesFileExist, doesDirectoryExist , setCurrentDirectory, getDirectoryContents , getTemporaryDirectory, doesDirectoryExist , createDirectory, createDirectoryIfMissing , getAbsolutePath, getCurrentDirectory ) import System.Process ( system, exitWith, getPID ) import System.Environment ( getEnv ) import System.FilePath ( FilePath, replaceFileName, () , searchPathSeparator ) import Data.List ( intercalate, isPrefixOf, splitOn ) import Control.Monad ( when ) import System.IOExts ( evalCmd, readCompleteFile ) --- Joins a list of directories into a search path. joinSearchPath :: [FilePath] -> String joinSearchPath = intercalate [searchPathSeparator] . map emptyPath2Dot where emptyPath2Dot p = if null p then "." else p --- Recursively copies a directory structure. copyDirectory :: String -> String -> IO () copyDirectory src dst = do retCode <- system $ "cp -pR \"" ++ src ++ "\" \"" ++ dst ++ "\"" if retCode /= 0 then error $ "Copy failed with " ++ (show retCode) else return () --- Recursively copies a directory structure following symlinks, i.e. links --- get replaced by copies in the destination. copyDirectoryFollowingSymlinks :: String -> String -> IO () copyDirectoryFollowingSymlinks src dst = do retCode <- system $ "cp -pLR \"" ++ src ++ "\" \"" ++ dst ++ "\"" if retCode /= 0 then error $ "Copy failed with " ++ (show retCode) else return () --- Creates a new symlink. createSymlink :: String -> String -> IO Int createSymlink from to = system $ "ln -s " ++ (quote from) ++ " " ++ (quote to) --- Deletes a symlink. removeSymlink :: String -> IO Int removeSymlink link = system $ "rm " ++ quote link --- Tests whether a file is a symlink. isSymlink :: String -> IO Bool isSymlink link = do (code, _, _) <- evalCmd "readlink" ["-n", link] "" return $ code == 0 --- Gets the target of a symlink. linkTarget :: String -> IO String linkTarget link = do (rc, out, _) <- evalCmd "readlink" ["-n", link] "" if rc == 0 then return $ replaceFileName link out else return "" --- Puts a file argument into quotes to avoid problems with files containing --- blanks. quote :: String -> String quote s = "\"" ++ s ++ "\"" --- Gets a temporary directory for some CPM command. tempDir :: IO String tempDir = do t <- getTemporaryDirectory pid <- getPID return (t "cpm" ++ show pid) --- Removes the temporary directory for some CPM command. cleanTempDir :: IO () cleanTempDir = tempDir >>= removeDirectoryComplete --- Executes an IO action with the current directory set to CPM's temporary --- directory. inTempDir :: IO b -> IO b inTempDir b = do t <- tempDir exists <- doesDirectoryExist t if exists then return () else createDirectory t inDirectory t b --- Executes an IO action with the current directory set to a specific --- directory. inDirectory :: String -> IO b -> IO b inDirectory dir b = do previous <- getCurrentDirectory setCurrentDirectory dir b' <- b setCurrentDirectory previous return b' --- Recreates a directory. Deletes its contents if it already exists. recreateDirectory :: String -> IO () recreateDirectory dir = do removeDirectoryComplete dir createDirectoryIfMissing True dir --- Deletes a directory and its contents, if it exists, otherwise nothing --- is done. removeDirectoryComplete :: String -> IO () removeDirectoryComplete dir = do exists <- doesDirectoryExist dir when exists $ system ("rm -Rf " ++ quote dir) >> return () --- Reads the complete contents of a file and catches any error --- (which is returned). safeReadFile :: String -> IO (Either IOError String) safeReadFile fname = do catch (readCompleteFile fname >>= return . Right) (return . Left) --- Returns the list of all entries in a directory and terminates with --- an error message if the directory does not exist. checkAndGetDirectoryContents :: FilePath -> IO [FilePath] checkAndGetDirectoryContents dir = do exdir <- doesDirectoryExist dir if exdir then getDirectoryContents dir else do putStrLn $ "ERROR: Directory '" ++ dir ++ "' does not exist!" exitWith 1 --- Returns the list of all visible entries in a directory (i.e., not starting --- with '.') and terminates with an error message if the directory --- does not exist. checkAndGetVisibleDirectoryContents :: FilePath -> IO [FilePath] checkAndGetVisibleDirectoryContents dir = checkAndGetDirectoryContents dir >>= return . filter (not . isPrefixOf ".") --- Performs an action when a file exists. whenFileExists :: FilePath -> IO () -> IO () whenFileExists fname act = do exfile <- doesFileExist fname when exfile act --- Performs one of two actions depending on the existence of a file. ifFileExists :: FilePath -> IO a -> IO a -> IO a ifFileExists fname thenact elseact = do exfile <- doesFileExist fname if exfile then thenact else elseact curry-tools-v3.3.0/cpm/src/CPM/Helpers.curry000066400000000000000000000003521377556325500207040ustar00rootroot00000000000000--- Some auxiliary operations that might fit better into system libraries. module CPM.Helpers ( strip ) where import Data.Char ( isSpace ) strip :: String -> String strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace curry-tools-v3.3.0/cpm/src/CPM/LookupSet.curry000066400000000000000000000146041377556325500212340ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module implements the LookupSet datatype. A lookup set is used to store --- and query packages for dependency resolution. It stores the source of a --- package specification alongside the specification itself (e.g. the global --- repository or the local package cache). ------------------------------------------------------------------------------ module CPM.LookupSet ( LookupSource (..) , LookupSet , emptySet , addPackage , findLatestVersion , findAllVersions , findVersion , addPackages , allPackages , lookupSource , setLocallyIgnored ) where import Data.List (sortBy, delete, deleteBy) import Test.Prop import Prelude hiding (empty) import Data.Table.RBTree as Table ( TableRBT, empty, lookup, toList,update ) import CPM.Package ------------------------------------------------------------------------------ data LookupSource = FromRepository | FromLocalCache | FromGlobalCache type PkgMap = TableRBT String [(LookupSource, Package)] data LookupSet = LookupSet PkgMap LookupOptions data LookupOptions = LookupOptions { ignoreLocalVersions :: [String] } --- The empty lookup set. emptySet :: LookupSet emptySet = LookupSet (empty (<=)) defaultOptions defaultOptions :: LookupOptions defaultOptions = LookupOptions [] --- Set the set of packages whose locally installed versions are ignored when --- finding all package versions. setLocallyIgnored :: LookupSet -> [String] -> LookupSet setLocallyIgnored (LookupSet ls o) pkgs = LookupSet ls (o { ignoreLocalVersions = pkgs }) --- Adds multiple packages to a lookup set with the same source. --- --- @param l the set to add to --- @param p the packages to add --- @param s where are the package specs from? addPackages :: LookupSet -> [Package] -> LookupSource -> LookupSet addPackages ls pkgs src = foldl (\l p -> addPackage l p src) ls pkgs allPackages :: LookupSet -> [Package] allPackages (LookupSet ls _) = map snd $ concat $ map snd $ toList ls --- Adds a package to a lookup set. --- --- @param l the set to add to --- @param p the package to add --- @param s where is the package spec from? addPackage :: LookupSet -> Package -> LookupSource -> LookupSet addPackage (LookupSet ls o) pkg src = case Table.lookup (name pkg) ls of Nothing -> LookupSet (update (name pkg) [(src, pkg)] ls) o Just ps -> let ps' = filter ((/= packageId pkg) . packageId . snd) ps in LookupSet (update (name pkg) ((src, pkg):ps') ls) o --- Finds a specific entry (including the source) in the lookup set. --- --- @param l the lookup set --- @param p the package to search for findEntry :: LookupSet -> Package -> Maybe (LookupSource, Package) findEntry (LookupSet ls _) p = maybeHead candidates where allVersions = Table.lookup (name p) ls candidates = case allVersions of Nothing -> [] Just ps -> filter ((packageIdEq p) . snd) ps --- Finds all versions of a package known to the lookup set. Returns the --- packages from the local cache first, and then from other sources. Each --- group is sorted from newest do oldest version. --- --- @param l the lookup set --- @param p the name of the package to search for --- @param pre should pre-release versions be included? findAllVersions :: LookupSet -> String -> Bool -> [Package] findAllVersions (LookupSet ls o) p pre = localSorted' ++ nonLocalSorted where packageVersions = case Table.lookup p ls of Nothing -> [] Just vs -> vs onlyLocal = filter isLocal packageVersions onlyNonLocal = filter (not . isLocal) packageVersions localSorted = sortedByVersion $ preFiltered $ sameName $ ps $ onlyLocal localSorted' = filter (not . (flip elem) (ignoreLocalVersions o) . name) localSorted nonLocalSorted = sortedByVersion $ preFiltered $ sameName $ ps $ onlyNonLocal sortedByVersion = sortBy (\a b -> (version a) `vgt` (version b)) preFiltered = filter filterPre sameName = filter ((== p) . name) filterPre p' = pre || (not . isPreRelease . version) p' isLocal (FromLocalCache, _) = True isLocal (FromGlobalCache, _) = False isLocal (FromRepository, _) = False ps = map snd test_findAllVersions_localBeforeNonLocal :: Prop test_findAllVersions_localBeforeNonLocal = findAllVersions ls "A" False -=- [aLocal, aNonLocal] where aLocal = cPackage "A" (1, 0, 0, Nothing) [] aNonLocal = cPackage "A" (1, 1, 0, Nothing) [] ls = addPackage (addPackage emptySet aLocal FromLocalCache) aNonLocal FromRepository test_findAllVersions_nonLocalIfIgnored :: Prop test_findAllVersions_nonLocalIfIgnored = findAllVersions ls "A" False -=- [aNonLocal] where aLocal = cPackage "A" (1, 0, 0, Nothing) [] aNonLocal = cPackage "A" (1, 1, 0, Nothing) [] ls = setLocallyIgnored (addPackage (addPackage emptySet aLocal FromLocalCache) aNonLocal FromRepository) ["A"] cPackage :: String -> Version -> [Dependency] -> Package cPackage p v ds = emptyPackage { name = p , version = v , author = ["author"] , synopsis = "JSON library for Curry" , dependencies = ds , maintainer = [] , description = Nothing , license = Nothing , licenseFile = Nothing , copyright = Nothing , homepage = Nothing , bugReports = Nothing , repository = Nothing , compilerCompatibility = [] , source = Nothing , exportedModules = [] } cDB :: [Package] -> LookupSet cDB ps = addPackages emptySet ps FromRepository --- Finds the source for a package in the lookup set --- --- @param ls the lookup set --- @param p the package to search for lookupSource :: LookupSet -> Package -> Maybe LookupSource lookupSource ls p = case findEntry ls p of Nothing -> Nothing Just (s, _) -> Just s --- Finds the latest version of a package known to the lookup set. --- --- @param l the lookup set --- @param p the name of the package to search for --- @param pre should pre-release versions be included? findLatestVersion :: LookupSet -> String -> Bool -> Maybe Package findLatestVersion ls p pre = case findAllVersions ls p pre of [] -> Nothing (x:_) -> Just x --- Finds a specific version of a package in the lookup set. --- --- @param l the lookup set --- @param p the name of the package --- @param v the package version findVersion :: LookupSet -> String -> Version -> Maybe Package findVersion ls p v = maybeHead $ filter ((== v) . version) $ findAllVersions ls p True maybeHead :: [a] -> Maybe a maybeHead [] = Nothing maybeHead (x:_) = Just x curry-tools-v3.3.0/cpm/src/CPM/Main.curry000066400000000000000000002333611377556325500201760ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This is the main module of the Curry Package Manager. -------------------------------------------------------------------------------- module CPM.Main ( main ) where import Curry.Compiler.Distribution ( installDir ) import Data.Char ( toLower ) import Data.List ( groupBy, intercalate, isPrefixOf, isSuffixOf , nub, split, sortBy, splitOn ) import Data.Either import Data.Time ( calendarTimeToString, getLocalTime ) import System.Directory ( doesFileExist, getAbsolutePath, doesDirectoryExist , copyFile, createDirectory, createDirectoryIfMissing , getCurrentDirectory, getDirectoryContents , getModificationTime , renameFile, removeFile, setCurrentDirectory ) import System.FilePath ( (), splitSearchPath, replaceExtension , takeExtension, pathSeparator, isPathSeparator ) import System.IO ( hFlush, stdout ) import System.Environment ( getArgs, getEnv, setEnv, unsetEnv ) import System.Process ( exitWith, system, getPID ) import Control.Monad ( when, unless, foldM ) import System.IOExts ( evalCmd, readCompleteFile ) import Prelude hiding ( (<|>) ) import Boxes ( table, render ) import OptParse import System.CurryPath ( addCurrySubdir, stripCurrySuffix ) import System.Path ( fileInPath, getFileInPath ) import Text.CSV ( readCSV, showCSV, writeCSVFile ) import CPM.ErrorLogger import CPM.FileUtil ( cleanTempDir, joinSearchPath, safeReadFile, whenFileExists , inDirectory, recreateDirectory , removeDirectoryComplete, copyDirectory, quote, tempDir ) import CPM.Config ( Config (..) , readConfigurationWith, showCompilerVersion , showConfiguration ) import CPM.PackageCache.Global ( acquireAndInstallPackage , GlobalCache, readGlobalCache, allPackages , checkoutPackage , installFromZip, installedPackageDir , uninstallPackage, packageInstalled ) import CPM.Package import CPM.Package.Helpers ( cleanPackage, getLocalPackageSpec , renderPackageInfo, installPackageSourceTo ) import CPM.Resolution ( isCompatibleToCompiler, showResult ) import CPM.Repository ( Repository, findVersion, listPackages , findAllVersions, findLatestVersion , useUpdateHelp, searchPackages, cleanRepositoryCache , readPackageFromRepository ) import CPM.Repository.Update ( addPackageToRepository, updateRepository ) import CPM.Repository.Select import CPM.PackageCache.Runtime ( dependencyPathsSeparate, writePackageConfig ) import CPM.PackageCopy import CPM.Diff.API as APIDiff import qualified CPM.Diff.Behavior as BDiff import CPM.ConfigPackage ( packagePath, packageVersion ) -- Banner of this tool: cpmBanner :: String cpmBanner = unlines [bannerLine, bannerText, bannerLine] where bannerText = "Curry Package Manager (Version " ++ packageVersion ++ ", 23/12/2020)" bannerLine = take (length bannerText) (repeat '-') main :: IO () main = do args <- getArgs if "-V" `elem` args || "--version" `elem` args then putStrLn $ "Curry Package Manager, version " ++ packageVersion else do parseResult <- return $ parse (unwords args) (optionParser args) "cypm" case parseResult of Left err -> do putStrLn cpmBanner putStrLn err --putStrLn "(use option -h for usage information)" exitWith 1 Right r -> case applyParse r of Left err -> do putStrLn cpmBanner --printUsage "cypm" 80 (optionParser args) putStrLn err exitWith 1 Right opts -> runWithArgs opts runWithArgs :: Options -> IO () runWithArgs opts = do ((ll, _), (msgs, result)) <- runErrorLogger' (optLogLevel opts) (optWithTime opts) $ do logDebug "Reading CPM configuration..." config <- readConfigurationWith (optDefConfig opts) >>= \c -> case c of Left err -> do logError $ "Error reading .cpmrc settings: " ++ err liftIOEL $ exitWith 1 Right c' -> return c' logDebug ("Current configuration:\n" ++ showConfiguration config) case optCommand opts of NoCommand -> fail "NoCommand" Config o -> configCmd o config Update o -> updateCmd o config Compiler o -> curryCmd o config Exec o -> execCmd o config Doc o -> docCmd o config Test o -> testCmd o config Uninstall o -> uninstallCmd o config Deps o -> depsCmd o config PkgInfo o -> infoCmd o config Link o -> linkCmd o config Add o -> addCmd o config New o -> newCmd o List o -> listCmd o config Search o -> searchCmd o config Upgrade o -> upgradeCmd o config Diff o -> diffCmd o config Checkout o -> checkoutCmd o config Install o -> installCmd o config Upload o -> uploadCmd o config Clean -> cleanPackage config Info mapM (showLogEntry ll) msgs let allOk = all (levelGte Info) (map logLevelOf msgs) && either (\le -> levelGte Info (logLevelOf le)) (const True) result exitWith $ if allOk then 0 else 1 where runErrorLogger' a b c = runErrorLogger c a b -- The global options of CPM. data Options = Options { optLogLevel :: LogLevel , optDefConfig :: [(String,String)] , optShowVersion :: Bool , optWithTime :: Bool , optCommand :: Command } -- The default options: no command, no timing, info log level defaultOptions :: Options defaultOptions = Options Info [] False False NoCommand data Command = NoCommand | Config ConfigOptions | Deps DepsOptions | Checkout CheckoutOptions | Install InstallOptions | Uninstall UninstallOptions | PkgInfo InfoOptions | Compiler ExecOptions | Update UpdateOptions | List ListOptions | Search SearchOptions | Upgrade UpgradeOptions | Link LinkOptions | Add AddOptions | Exec ExecOptions | Doc DocOptions | Test TestOptions | Diff DiffOptions | New NewOptions | Clean | Upload UploadOptions data ConfigOptions = ConfigOptions { configAll :: Bool -- show also installed packages? } data DepsOptions = DepsOptions { depsPath :: Bool -- show CURRYPATH only? } data CheckoutOptions = CheckoutOptions { coPackage :: String , coVersion :: Maybe Version , coPrerelease :: Bool } data InstallOptions = InstallOptions { instTarget :: Maybe String , instVersion :: Maybe Version , instPrerelease :: Bool , instExecutable :: Bool , instExecOnly :: Bool } data UninstallOptions = UninstallOptions { uninstPackage :: Maybe String , uninstVersion :: Maybe Version } data InfoOptions = InfoOptions { infoPackage :: Maybe String , infoVersion :: Maybe Version , infoAll :: Bool , infoPlain :: Bool -- plain output, no bold/color } data ListOptions = ListOptions { listVers :: Bool -- list all versions of each package , listSystem :: Bool -- list package compatible with current Curry system , listCSV :: Bool -- list in CSV format , listCat :: Bool -- list all categories } data SearchOptions = SearchOptions { searchQuery :: String -- the term to search for , searchModule :: Bool -- search for some module? , searchExec :: Bool -- search for some executable? } data UpgradeOptions = UpgradeOptions { upgrTarget :: Maybe String } data LinkOptions = LinkOptions { lnkSource :: String } data AddOptions = AddOptions { addPackage :: Bool , addDependency :: Bool , addSource :: String , forceAdd :: Bool } data NewOptions = NewOptions { projectName :: String } data UpdateOptions = UpdateOptions { indexURLs :: [String] -- the URLs of additional index repositories , cleanCache :: Bool -- clean also repository cache? , downloadIndex :: Bool -- download the index repository? , useRepoCache :: Bool -- use repository cache to create repository DB? , writeCSV :: Bool -- write also a CSV file of the repository DB? } data UploadOptions = UploadOptions { setTag :: Bool -- set the tag in the current repository? , forceUpdate :: Bool -- force update if package with same version exists } data ExecOptions = ExecOptions { exeCommand :: String -- the command to be executed } data DocOptions = DocOptions { docDir :: Maybe String -- documentation directory , docModules :: Maybe [String] -- modules to be documented , docReadme :: Bool -- generate README as HTML , docPrograms :: Bool -- generate documentation for programs , docManual :: Bool -- generate manual (if specified) , docGenImports :: Bool -- generate documentation for imported pkgs -- (otherwise, use their standard docs) , docPackageURL :: String -- the URL prefix where all repository -- packages are documented } data TestOptions = TestOptions { testModules :: Maybe [String] -- modules to be tested , testSafe :: Bool -- safe test? (no scripts, no I/O props) , testFile :: String -- file to write test statistics as CSV , testCheckOpts :: [String] -- additional options passed to CurryCheck } data DiffOptions = DiffOptions { diffVersion :: Maybe Version -- version to be compared , diffModules :: Maybe [String] -- modules to be compared , diffAPI :: Bool -- check API equivalence , diffBehavior :: Bool -- test behavior equivalence , diffGroundEqu :: Bool -- test ground equivalence only , diffUseAna :: Bool -- use termination analysis for safe tests } configOpts :: Options -> ConfigOptions configOpts s = case optCommand s of Config opts -> opts _ -> ConfigOptions False depsOpts :: Options -> DepsOptions depsOpts s = case optCommand s of Deps opts -> opts _ -> DepsOptions False checkoutOpts :: Options -> CheckoutOptions checkoutOpts s = case optCommand s of Checkout opts -> opts _ -> CheckoutOptions "" Nothing False installOpts :: Options -> InstallOptions installOpts s = case optCommand s of Install opts -> opts _ -> InstallOptions Nothing Nothing False True False uninstallOpts :: Options -> UninstallOptions uninstallOpts s = case optCommand s of Uninstall opts -> opts _ -> UninstallOptions Nothing Nothing infoOpts :: Options -> InfoOptions infoOpts s = case optCommand s of PkgInfo opts -> opts _ -> InfoOptions Nothing Nothing False False listOpts :: Options -> ListOptions listOpts s = case optCommand s of List opts -> opts _ -> ListOptions False False False False searchOpts :: Options -> SearchOptions searchOpts s = case optCommand s of Search opts -> opts _ -> SearchOptions "" False False upgradeOpts :: Options -> UpgradeOptions upgradeOpts s = case optCommand s of Upgrade opts -> opts _ -> UpgradeOptions Nothing linkOpts :: Options -> LinkOptions linkOpts s = case optCommand s of Link opts -> opts _ -> LinkOptions "" addOpts :: Options -> AddOptions addOpts s = case optCommand s of Add opts -> opts _ -> AddOptions False False "" False newOpts :: Options -> NewOptions newOpts s = case optCommand s of New opts -> opts _ -> NewOptions "" updateOpts :: Options -> UpdateOptions updateOpts s = case optCommand s of Update opts -> opts _ -> UpdateOptions [] True True True False uploadOpts :: Options -> UploadOptions uploadOpts s = case optCommand s of Upload opts -> opts _ -> UploadOptions True False execOpts :: Options -> ExecOptions execOpts s = case optCommand s of Exec opts -> opts _ -> ExecOptions "" docOpts :: Options -> DocOptions docOpts s = case optCommand s of Doc opts -> opts _ -> DocOptions Nothing Nothing True True True False defaultBaseDocURL -- The default URL prefix where all repository packages are documented. -- Can be overwritten with a doc command option. defaultBaseDocURL :: String defaultBaseDocURL = "https://www-ps.informatik.uni-kiel.de/~cpm/DOC" testOpts :: Options -> TestOptions testOpts s = case optCommand s of Test opts -> opts _ -> TestOptions Nothing False "" [] diffOpts :: Options -> DiffOptions diffOpts s = case optCommand s of Diff opts -> opts _ -> DiffOptions Nothing Nothing True True False True readLogLevel :: String -> Either String LogLevel readLogLevel s = case map toLower s of "debug" -> Right Debug "info" -> Right Info "quiet" -> Right Quiet _ -> Left $ "Illegal verbosity value: " ++ s readRcOption :: String -> Either String (String,String) readRcOption s = let (option,value) = break (=='=') s in if null value then Left $ "Error in option definition: '=' missing" else Right $ (option, tail value) readVersion' :: String -> Either String Version readVersion' s = case readVersion s of Nothing -> Left $ "'" ++ s ++ "' is not a valid version" Just v -> Right v applyEither :: [Options -> Either String Options] -> Options -> Either String Options applyEither [] z = Right z applyEither (f:fs) z = case f z of Left err -> Left err Right z' -> applyEither fs z' applyParse :: [Options -> Either String Options] -> Either String Options applyParse fs = applyEither fs defaultOptions (>.>) :: Either String a -> (a -> b) -> Either String b a >.> f = case a of Left err -> Left err Right v -> Right $ f v optionParser :: [String] -> ParseSpec (Options -> Either String Options) optionParser allargs = optParser ( flag (\a -> Right $ a { optShowVersion = True }) ( long "version" <> short "V" <> help "Show version and quit" ) <.> option (\s a -> readLogLevel s >.> \ll -> a { optLogLevel = ll }) ( long "verbosity" <> short "v" <> metavar "LEVEL" <> help "Log level for the application. Valid values: info|debug|quiet" ) <.> option (\s a -> readRcOption s >.> \kv -> a { optDefConfig = optDefConfig a ++ [kv] }) ( long "define" <> short "d" <> metavar "DEFINITION" <> help "Overwrite definition of cpmrc file with 'option=value'." ) <.> flag (\a -> Right $ a { optWithTime = True }) ( long "time" <> short "t" <> help "Show elapsed time with every log output" ) <.> commands (metavar "COMMAND") ( command "config" (help "Show current configuration of CPM") (\a -> Right $ a { optCommand = Config (configOpts a) }) configArgs <|> command "checkout" (help "Checkout a package.") Right (checkoutArgs Checkout) <|> command "install" (help "Install a package with its dependencies.") (\a -> Right $ a { optCommand = Install (installOpts a) }) installArgs <|> command "uninstall" (help "Uninstall a package") (\a -> Right $ a { optCommand = Uninstall (uninstallOpts a) }) uninstallArgs <|> command "deps" (help "Calculate dependencies") (\a -> Right $ a { optCommand = Deps (depsOpts a) }) depsArgs <|> command "clean" (help "Clean the current package") (\a -> Right $ a { optCommand = Clean }) [] <|> command "new" (help "Create a new package") Right newArgs <|> command "update" (help "Update the package index") (\a -> Right $ a { optCommand = Update (updateOpts a) }) updateArgs <|> command "curry" (help "Load package spec and start Curry with correct dependencies.") (\a -> Right $ a { optCommand = Compiler (execOpts a) }) curryArgs <|> command "exec" (help "Execute a command with the CURRYPATH set") (\a -> Right $ a { optCommand = Exec (execOpts a) }) execArgs <|> command "info" (help "Print package information") (\a -> Right $ a { optCommand = PkgInfo (infoOpts a) }) infoArgs <|> command "doc" (help "Generation documentation for current package (with CurryDoc)") (\a -> Right $ a { optCommand = Doc (docOpts a) }) docArgs <|> command "test" (help "Test the current package (with CurryCheck)") (\a -> Right $ a { optCommand = Test (testOpts a) }) testArgs <|> command "diff" (help "Diff the current package against another version") (\a -> Right $ a { optCommand = Diff (diffOpts a) }) diffArgs <|> command "list" (help "List all packages of the repository") (\a -> Right $ a { optCommand = List (listOpts a) }) listArgs <|> command "search" (help "Search the package repository") Right searchArgs <|> command "upgrade" (help "Upgrade one or more packages") (\a -> Right $ a { optCommand = Upgrade (upgradeOpts a) }) upgradeArgs <|> command "link" (help "Link a package to the local cache") Right linkArgs <|> command "add" (help "Add a package (as dependency or to the local repository)") Right addArgs <|> command "upload" (help "Upload current package to package server") (\a -> Right $ a { optCommand = Upload (uploadOpts a) }) uploadArgs ) ) where configArgs = flag (\a -> Right $ a { optCommand = Config (configOpts a) { configAll = True } }) ( short "a" <> long "all" <> help "Show also names of installed packages" <> optional ) depsArgs = flag (\a -> Right $ a { optCommand = Deps (depsOpts a) { depsPath = True } }) ( short "p" <> long "path" <> help "Show value of CURRYPATH only" <> optional ) checkoutArgs cmd = arg (\s a -> Right $ a { optCommand = cmd (checkoutOpts a) { coPackage = s } }) ( metavar "PACKAGE" <> help "The package name" ) <.> arg (\s a -> readVersion' s >.> \v -> a { optCommand = cmd (checkoutOpts a) { coVersion = Just v } }) ( metavar "VERSION" <> help "The package version" <> optional) <.> flag (\a -> Right $ a { optCommand = cmd (checkoutOpts a) { coPrerelease = True } }) ( short "p" <> long "pre" <> help "Try pre-release versions when searching for newest version.") installArgs = arg (\s a -> Right $ a { optCommand = Install (installOpts a) { instTarget = Just s } }) ( metavar "TARGET" <> help "A package name or the path to a file" <> optional) <.> arg (\s a -> readVersion' s >.> \v -> a { optCommand = Install (installOpts a) { instVersion = Just v } }) ( metavar "VERSION" <> help "The package version" <> optional) <.> flag (\a -> Right $ a { optCommand = Install (installOpts a) { instPrerelease = True } }) ( short "p" <> long "pre" <> help "Try pre-release versions when searching for newest version.") <.> flag (\a -> Right $ a { optCommand = Install (installOpts a) { instExecutable = False } }) ( short "n" <> long "noexec" <> help "Do not install executable.") <.> flag (\a -> Right $ a { optCommand = Install (installOpts a) { instExecOnly = True } }) ( short "x" <> long "exec" <> help "Install executable only (do not re-install dependencies).") uninstallArgs = arg (\s a -> Right $ a { optCommand = Uninstall (uninstallOpts a) { uninstPackage = Just s } }) ( metavar "PACKAGE" <> help "The package to be uninstalled" <> optional) <.> arg (\s a -> readVersion' s >.> \v -> a { optCommand = Uninstall (uninstallOpts a) { uninstVersion = Just v } }) ( metavar "VERSION" <> help "The version to be uninstalled" <> optional) newArgs = arg (\s a -> Right $ a { optCommand = New (newOpts a) { projectName = s } }) ( metavar "PROJECT" <> help "The name of the new project" ) curryArgs = rest (\_ a -> Right $ a { optCommand = Compiler (execOpts a) { exeCommand = unwords remargs } }) ( metavar "ARGS" <> help "The options to pass to the compiler" <> optional ) where remargs = tail (snd (break (=="curry") allargs)) updateArgs = option (\s a -> let opts = updateOpts a in Right $ a { optCommand = Update opts { indexURLs = s : indexURLs opts } }) ( short "u" <> long "url" <> metavar "URL" <> help "URL of the central package index" ) <.> flag (\a -> Right $ a { optCommand = Update (updateOpts a) { cleanCache = False } }) ( short "c" <> long "clean" <> help "Do not clean global package cache" ) <.> flag (\a -> Right $ a { optCommand = Update (updateOpts a) { downloadIndex = False } }) ( short "d" <> long "download" <> help "Do not download the global repository index" ) <.> flag (\a -> Right $ a { optCommand = Update (updateOpts a) { useRepoCache = False } }) ( short "n" <> long "nocache" <> help "Do not download global repository cache files" ) <.> flag (\a -> Right $ a { optCommand = Update (updateOpts a) { writeCSV = True } }) ( short "w" <> long "writecsv" <> help "Write also a CSV file of the cache database" ) uploadArgs = flag (\a -> Right $ a { optCommand = Upload (uploadOpts a) { setTag = False } }) ( short "t" <> long "notagging" <> help "Do not tag git repository with current version" ) <.> flag (\a -> Right $ a { optCommand = Upload (uploadOpts a) { forceUpdate = True } }) ( short "f" <> long "force" <> help "Force, i.e., overwrite existing package version" ) execArgs = rest (\_ a -> Right $ a { optCommand = Exec (execOpts a) { exeCommand = unwords remargs } }) ( metavar "CMD" <> help "The command to be executed." <> optional ) where remargs = tail (snd (break (=="exec") allargs)) infoArgs = arg (\s a -> Right $ a { optCommand = PkgInfo (infoOpts a) { infoPackage = Just s } }) ( metavar "PACKAGE" <> help ("The package name. If no name is specified, CPM tries " ++ "to read a package specification in the current directory.") <> optional) <.> arg (\s a -> readVersion' s >.> \v -> a { optCommand = PkgInfo (infoOpts a) { infoVersion = Just v } }) ( metavar "VERSION" <> help ("The package version. If no version is specified, " ++ "CPM uses the latest version of the specified package.") <> optional ) <.> flag (\a -> Right $ a { optCommand = PkgInfo (infoOpts a) { infoAll = True } }) ( short "a" <> long "all" <> help "Show all infos" ) <.> flag (\a -> Right $ a { optCommand = PkgInfo (infoOpts a) { infoPlain = True } }) ( short "p" <> long "plain" <> help "Plain output (no control characters for bold or colors)" <> optional ) docArgs = option (\s a -> Right $ a { optCommand = Doc (docOpts a) { docDir = Just s } }) ( long "docdir" <> short "d" <> help "The documentation directory (default: 'cdoc')" <> optional ) <.> option (\s a -> Right $ a { optCommand = Doc (docOpts a) { docModules = Just $ splitOn "," s } }) ( long "modules" <> short "m" <> help ("The modules to be documented, " ++ "separate multiple modules by comma") <> optional ) <.> flag (\a -> Right $ a { optCommand = Doc (docOpts a) { docManual = False, docPrograms = False } }) ( short "r" <> long "readme" <> help "Generate only README as HTML" <> optional ) <.> flag (\a -> Right $ a { optCommand = Doc (docOpts a) { docManual = False, docReadme = False } }) ( short "p" <> long "programs" <> help "Generate only program documentation (with CurryDoc)" <> optional ) <.> flag (\a -> Right $ a { optCommand = Doc (docOpts a) { docPrograms = False, docReadme = False } }) ( short "t" <> long "text" <> help "Generate only manual (according to package specification)" <> optional ) <.> flag (\a -> Right $ a { optCommand = Doc (docOpts a) { docGenImports = True } }) ( short "f" <> long "full" <> help "Generate full program documentation (i.e., also imported packages)" <> optional ) <.> option (\s a -> Right $ a { optCommand = Doc (docOpts a) { docPackageURL = s } }) ( long "url" <> short "u" <> help ("The URL prefix where all repository packages are " ++ "documented. Default: " ++ defaultBaseDocURL) <> optional ) testArgs = option (\s a -> Right $ a { optCommand = Test (testOpts a) { testModules = Just $ splitOn "," s } }) ( long "modules" <> short "m" <> help "The modules to be tested, separate multiple modules by comma" <> optional ) <.> flag (\a -> Right $ a { optCommand = Test (testOpts a) { testSafe = True } }) ( short "s" <> long "safe" <> help "Safe test mode (no script tests, no I/O tests)" <> optional ) <.> option (\s a -> Right $ a { optCommand = Test (testOpts a) { testFile = s } }) ( long "file" <> short "f" <> help "File to store test statistics in CSV format" <> optional ) <.> option (\s a -> Right $ a { optCommand = Test (testOpts a) { testCheckOpts = s : testCheckOpts (testOpts a) } }) ( long "option" <> short "o" <> help "Option passed to CurryCheck (without prefix '--'!)" <> optional ) diffArgs = arg (\s a -> readVersion' s >.> \v -> a { optCommand = Diff (diffOpts a) { diffVersion = Just v } }) ( metavar "VERSION" <> help ("The other package version. If no version is specified, " ++ "CPM diffs against the latest repository version.") <> optional ) <.> option (\s a -> Right $ a { optCommand = Diff (diffOpts a) { diffModules = Just $ splitOn "," s } }) ( long "modules" <> short "m" <> help "The modules to compare, separate multiple modules by comma" <> optional ) <.> flag (\a -> Right $ a { optCommand = Diff (diffOpts a) { diffAPI = True, diffBehavior = False } }) ( long "api-only" <> short "a" <> help "Diff only the API") <.> flag (\a -> Right $ a { optCommand = Diff (diffOpts a) { diffAPI = False, diffBehavior = True } }) ( long "behavior-only" <> short "b" <> help "Diff only the behavior") <.> flag (\a -> Right $ a { optCommand = Diff (diffOpts a) { diffGroundEqu = True } }) ( long "ground" <> short "g" <> help "Check ground equivalence only when comparing behavior") <.> flag (\a -> Right $ a { optCommand = Diff (diffOpts a) { diffUseAna = False } }) ( long "unsafe" <> short "u" <> help "Do not use automatic termination analysis for safe behavior checking") listArgs = flag (\a -> Right $ a { optCommand = List (listOpts a) { listVers = True } }) ( short "v" <> long "versions" <> help "List all versions" ) <.> flag (\a -> Right $ a { optCommand = List (listOpts a) { listSystem = True } }) ( short "s" <> long "system" <> help "List packages compatible with current compiler" ) <.> flag (\a -> Right $ a { optCommand = List (listOpts a) { listCSV = True } }) ( short "t" <> long "csv" <> help "Show in CSV table format" ) <.> flag (\a -> Right $ a { optCommand = List (listOpts a) { listCat = True } }) ( short "c" <> long "category" <> help "Show all categories" ) searchArgs = flag (\a -> Right $ a { optCommand = Search (searchOpts a) { searchModule = True } }) ( short "m" <> long "module" <> help "Search for an exported module" ) <.> flag (\a -> Right $ a { optCommand = Search (searchOpts a) { searchExec = True } }) ( short "x" <> long "exec" <> help "Search for the name of an executable" ) <.> arg (\s a -> Right $ a { optCommand = Search (searchOpts a) { searchQuery = s } }) ( metavar "QUERY" <> help "The search term" ) upgradeArgs = arg (\s a -> Right $ a { optCommand = Upgrade (upgradeOpts a) { upgrTarget = Just s } }) ( metavar "PACKAGE" <> help "The package to upgrade" <> optional ) linkArgs = arg (\s a -> Right $ a { optCommand = Link (linkOpts a) { lnkSource = s } }) ( metavar "SOURCE" <> help "The directory to link" ) addArgs = flag (\a -> Right $ a { optCommand = Add (addOpts a) { addPackage = True } }) ( short "p" <> long "package" <> help "Add a local package to the local repository" ) <.> flag (\a -> Right $ a { optCommand = Add (addOpts a) { addDependency = True } }) ( short "d" <> long "dependency" <> help "Add only dependency to the current package" ) <.> flag (\a -> Right $ a { optCommand = Add (addOpts a) { forceAdd = True } }) ( short "f" <> long "force" <> help "Force, i.e., overwrite existing package" ) <.> arg (\s a -> Right $ a { optCommand = Add (addOpts a) { addSource = s } }) ( metavar "PACKAGE" <> help "The package name (or directory for option '-p') to be added" ) -- Check if operating system executables we depend on are present on the -- current system. Since this takes some time, it is only checked with -- the `update` command. checkRequiredExecutables :: ErrorLogger () checkRequiredExecutables = do logDebug "Checking whether all required executables can be found..." missingExecutables <- liftIOEL $ checkExecutables listOfExecutables unless (null missingExecutables) $ do logError $ "The following programs could not be found on the PATH " ++ "(they are required for CPM to work):\n" ++ intercalate ", " missingExecutables liftIOEL $ exitWith 1 logDebug "All required executables found." where listOfExecutables = [ "curl" , "git" , "unzip" , "tar" , "cp" , "rm" , "ln" , "readlink" ] checkExecutables :: [String] -> IO [String] checkExecutables executables = do present <- mapM fileInPath executables return $ map fst $ filter (not . snd) (zip executables present) ------------------------------------------------------------------------------ -- `config` command: show current CPM configuration configCmd :: ConfigOptions -> Config -> ErrorLogger () configCmd opts cfg | configAll opts = do repo <- getBaseRepository cfg gc <- readGlobalCache cfg repo liftIOEL $ do putStrLn configS putStrLn "Installed packages:\n" putStrLn $ unwords . sortBy (<=) . map packageId . allPackages $ gc | otherwise = putStrLnELM configS where configS = unlines [cpmBanner, "Current configuration:", "", showConfiguration cfg] ------------------------------------------------------------------------------ -- `update` command: updateCmd :: UpdateOptions -> Config -> ErrorLogger () updateCmd opts cfg = do let cfg' = cfg { packageIndexURLs = indexURLs opts ++ packageIndexURLs cfg } checkRequiredExecutables updateRepository cfg' (cleanCache opts) (downloadIndex opts) (useRepoCache opts) (writeCSV opts) ------------------------------------------------------------------------------ -- `deps` command: depsCmd :: DepsOptions -> Config -> ErrorLogger () depsCmd opts cfg = do specDir <- getLocalPackageSpec cfg "." pkg <- loadPackageSpec specDir checkCompiler cfg pkg if depsPath opts -- show CURRYPATH only? then do loadpath <- getCurryLoadPath cfg specDir putStrLnELM loadpath else do result <- resolveDependencies cfg specDir putStrLnELM (showResult result) ------------------------------------------------------------------------------ -- `info` command: infoCmd :: InfoOptions -> Config -> ErrorLogger () infoCmd (InfoOptions Nothing (Just _) _ _) _ = fail "Must specify package name" infoCmd (InfoOptions Nothing Nothing allinfos plain) cfg = do specDir <- getLocalPackageSpec cfg "." p <- loadPackageSpec specDir liftIOEL $ printInfo cfg allinfos plain p infoCmd (InfoOptions (Just pkgname) Nothing allinfos plain) cfg = do pkgs <- getAllPackageVersions cfg pkgname False case pkgs of [] -> packageNotFoundFailure pkgname ps -> case filter (isCompatibleToCompiler cfg) ps of [] -> let lvers = showVersion (version (head ps)) in compatPackageNotFoundFailure cfg pkgname ("Use 'info " ++ pkgname ++ " " ++ lvers ++ "' to print info about the latest version.") (rp:_) -> do p <- readPackageFromRepository cfg rp liftIOEL $ printInfo cfg allinfos plain p infoCmd (InfoOptions (Just pkgname) (Just v) allinfos plain) cfg = do mbpkg <- getPackageVersion cfg pkgname v case mbpkg of Nothing -> packageNotFoundFailure $ pkgname ++ "-" ++ showVersion v Just rp -> do p <- readPackageFromRepository cfg rp liftIOEL $ printInfo cfg allinfos plain p printInfo :: Config -> Bool -> Bool -> Package -> IO () printInfo cfg allinfos plain pkg = do isinstalled <- packageInstalled cfg pkg putStrLn $ renderPackageInfo allinfos plain isinstalled pkg ------------------------------------------------------------------------------ -- `checkout` command: checkoutCmd :: CheckoutOptions -> Config -> ErrorLogger () checkoutCmd (CheckoutOptions pkgname Nothing pre) cfg = do repo <- getRepoForPackages cfg [pkgname] case findAllVersions repo pkgname pre of [] -> packageNotFoundFailure pkgname ps -> case filter (isCompatibleToCompiler cfg) ps of [] -> compatPackageNotFoundFailure cfg pkgname useUpdateHelp (p:_) -> do acquireAndInstallPackageWithDependencies cfg repo p checkoutPackage cfg p checkoutCmd (CheckoutOptions pkgname (Just ver) _) cfg = do repo <- getRepoForPackages cfg [pkgname] case findVersion repo pkgname ver of Nothing -> packageNotFoundFailure $ pkgname ++ "-" ++ showVersion ver Just p -> do acquireAndInstallPackage cfg p checkoutPackage cfg p installCmd :: InstallOptions -> Config -> ErrorLogger () installCmd (InstallOptions Nothing Nothing _ instexec False) cfg = do pkgdir <- getLocalPackageSpec cfg "." cleanCurryPathCache pkgdir (pkg,_) <- installLocalDependencies cfg pkgdir currypath <- getCurryLoadPath cfg pkgdir writePackageConfig cfg pkgdir pkg currypath when instexec $ installExecutable cfg pkg -- Install executable only: installCmd (InstallOptions Nothing Nothing _ _ True) cfg = do pkgdir <- getLocalPackageSpec cfg "." pkg <- loadPackageSpec pkgdir installExecutable cfg pkg installCmd (InstallOptions (Just pkg) vers pre _ _) cfg = do fileExists <- liftIOEL $ doesFileExist pkg if fileExists then installFromZip cfg pkg else installApp (CheckoutOptions pkg vers pre) cfg installCmd (InstallOptions Nothing (Just _) _ _ _) _ = fail "Must specify package name" --- Installs the application (i.e., binary) provided by a package. --- This is done by checking out the package into CPM's application packages --- cache (default: $HOME/.cpm/app_packages, see APP_PACKAGE_PATH --- in .cpmrc configuration file) and then install this package. --- --- Internal note: the installed package should not be cleaned or removed --- after the installation since its execution might refer (via the --- config module) to some data stored in the package. installApp :: CheckoutOptions -> Config -> ErrorLogger () installApp opts cfg = do let apppkgdir = appPackageDir cfg copname = coPackage opts copkgdir = apppkgdir coPackage opts curdir <- liftIOEL $ getCurrentDirectory liftIOEL $ removeDirectoryComplete copkgdir logDebug $ "Change into directory " ++ apppkgdir inDirectoryEL apppkgdir $ do checkoutCmd opts cfg logDebug $ "Change into directory " ++ copkgdir liftIOEL $ setCurrentDirectory copkgdir pkg <- loadPackageSpec "." if null (executableSpec pkg) then do liftIOEL $ setCurrentDirectory curdir liftIOEL $ removeDirectoryComplete copkgdir fail $ "Package '" ++ name pkg ++ "' has no executable, nothing installed.\n" ++ "Hint: use 'cypm add " ++ copname ++ "' to add new dependency and install it." else installCmd (InstallOptions Nothing Nothing False True False) cfg --- Checks the compiler compatibility. checkCompiler :: Config -> Package -> ErrorLogger () checkCompiler cfg pkg = unless (isCompatibleToCompiler cfg pkg) $ error $ "Current compiler '" ++ showCompilerVersion cfg ++ "' incompatible to package specification!" --- Installs the executable specified in the package in the --- bin directory of CPM (compare .cpmrc). installExecutable :: Config -> Package -> ErrorLogger () installExecutable cfg pkg = do checkCompiler cfg pkg mapM_ (\ (PackageExecutable name mainmod eopts) -> do lvl <- getLogLevel path <- liftIOEL $ getEnv "PATH" logInfo $ "Compiling main module: " ++ mainmod let (cmpname,_,_,_) = compilerVersion cfg cmd = unwords $ [":set", if levelGte Debug lvl then "v1" else "v0" , maybe "" id (lookup cmpname eopts) , ":load", mainmod, ":save", ":quit"] bindir = binInstallDir cfg binexec = bindir name curryCmd (ExecOptions cmd) cfg logInfo $ "Installing executable '" ++ name ++ "' into '" ++ bindir ++ "'" -- renaming might not work across file systems, hence we move: showExecCmd (unwords ["mv", mainmod, binexec]) checkPath path bindir ) (executableSpec pkg) where checkPath path bindir = if bindir `elem` splitSearchPath path then return () else logInfo $ "It is recommended to add '" ++bindir++ "' to your path!" uninstallCmd :: UninstallOptions -> Config -> ErrorLogger () uninstallCmd (UninstallOptions (Just pkgname) (Just ver)) cfg = uninstallPackage cfg pkgname ver --- uninstalls an application (i.e., binary) provided by a package: uninstallCmd (UninstallOptions (Just pkgname) Nothing) cfg = do let copkgdir = appPackageDir cfg pkgname codirexists <- liftIOEL $ doesDirectoryExist copkgdir if codirexists then do pkg <- loadPackageSpec copkgdir uninstallPackageExecutable cfg pkg liftIOEL $ removeDirectoryComplete copkgdir logInfo ("Package '" ++ pkgname ++ "' uninstalled from application package cache.") else fail $ "Cannot find executable installed for package '" ++ pkgname ++ "'." uninstallCmd (UninstallOptions Nothing (Just _)) _ = logError "Please provide a package and version number!" uninstallCmd (UninstallOptions Nothing Nothing) cfg = do pkgdir <- getLocalPackageSpec cfg "." pkg <- loadPackageSpec pkgdir uninstallPackageExecutable cfg pkg uninstallPackageExecutable :: Config -> Package -> ErrorLogger () uninstallPackageExecutable cfg pkg = mapM_ (\ (PackageExecutable name _ _) -> do let binexec = binInstallDir cfg name exf <- liftIOEL $ doesFileExist binexec if exf then do liftIOEL $ removeFile binexec logInfo $ "Executable '" ++ binexec ++ "' removed" else logInfo $ "Executable '" ++ binexec ++ "' not installed") (executableSpec pkg) --- Lists all (compiler-compatible if `lall` is false) packages --- in the given repository. listCmd :: ListOptions -> Config -> ErrorLogger () listCmd (ListOptions lv currysystem csv cat) cfg = do repo <- if cat then getRepositoryWithNameVersionCategory cfg else if currysystem then getRepositoryWithNameVersionSynopsisDeps cfg else getRepositoryWithNameVersionSynopsis cfg let listresult = if cat then renderCats (catgroups repo) else renderPkgs (allpkgs repo) putStrELM listresult where -- all packages (and versions if `lv`) allpkgs repo = concatMap filterPkgVersions (sortBy (\ps1 ps2 -> name (head ps1) <= name (head ps2)) (listPackages repo)) where filterPkgVersions pvs = if lv then pvs else if currysystem then take 1 (filter (isCompatibleToCompiler cfg) pvs) else take 1 pvs -- all categories together with their package names: catgroups repo = let pkgid p = name p -- ++ '-' : showVersionIfCompatible cfg p newpkgs = map (filterCompatPkgs cfg) (listPackages repo) catpkgs = concatMap (\p -> map (\c -> (c, pkgid p)) (category p)) newpkgs nocatps = map pkgid (filter (null . category) newpkgs) in map (\cg -> (fst (head cg), map snd cg)) (groupBy (\ (c1,_) (c2,_) -> c1==c2) (nub $ sortBy (<=) catpkgs)) ++ if null nocatps then [] else [("???", nub $ sortBy (<=) nocatps)] renderPkgs pkgs = let (colsizes,rows) = packageVersionAsTable cfg pkgs True in renderTable colsizes rows renderCats catgrps = let namelen = foldl max 8 $ map (length . fst) catgrps header = [ ["Category", "Packages"] , ["--------", "--------"]] rows = header ++ map (\ (c,ns) -> [c, unwords ns]) catgrps in renderTable [namelen + 2, 78 - namelen] rows renderTable colsizes rows = if csv then showCSV (head rows : drop 2 rows) else unlines [render (table rows colsizes), cpmInfo, useUpdateHelp] --- Returns the first package of a list of packages compatible to the --- current compiler (according to the given configuration). --- If there is no compatible package, returns the first one. filterCompatPkgs :: Config -> [Package] -> Package filterCompatPkgs cfg pkgs = let comppkgs = filter (isCompatibleToCompiler cfg) pkgs in if null comppkgs then head pkgs else head comppkgs -- Format a list of packages by showing their names, synopsis, and versions -- as table rows. Returns also the column sizes. packageVersionAsTable :: Config -> [Package] -> Bool -> ([Int],[[String]]) packageVersionAsTable cfg pkgs withversion = (colsizes, if withversion then rows else map (take 2) rows) where namelen = foldl max 4 $ map (length . name) pkgs colsizes = if withversion then [namelen + 2, 68 - namelen, 10] else [namelen + 2, 78 - namelen] header = [ ["Name", "Synopsis", "Version"] , ["----", "--------", "-------"]] formatPkg p = [name p, synopsis p, showVersionIfCompatible cfg p] rows = header ++ map formatPkg pkgs --- Shows the version of a package if it is compatible with the --- current compiler, otherwise shows the version in brackets. showVersionIfCompatible :: Config -> Package -> String showVersionIfCompatible cfg p = let s = showVersion (version p) in if isCompatibleToCompiler cfg p then s else '(' : s ++ ")" cpmInfo :: String cpmInfo = "Use 'cypm info PACKAGE' for more information about a package." --- Search in all (compiler-compatible) packages in the given repository. searchCmd :: SearchOptions -> Config -> ErrorLogger () searchCmd (SearchOptions q smod sexec) cfg = do let searchaction = if smod then searchExportedModules else if sexec then searchExecutable else searchNameSynopsisModules allpkgs <- searchaction cfg q let results = sortBy (\p1 p2 -> name p1 <= name p2) (map (filterCompatPkgs cfg) (map (sortBy (\a b -> version a `vgt` version b)) (groupBy (\a b -> name a == name b) allpkgs))) (colsizes,rows) = packageVersionAsTable cfg results False putStrELM $ unlines $ if null results then [ "No packages found for '" ++ q ++ "'", useUpdateHelp ] else [ render (table rows colsizes), cpmInfo, useUpdateHelp ] --- `upgrade` command. upgradeCmd :: UpgradeOptions -> Config -> ErrorLogger () upgradeCmd (UpgradeOptions Nothing) cfg = do specDir <- getLocalPackageSpec cfg "." cleanCurryPathCache specDir logInfo "Upgrading all packages" upgradeAllPackages cfg specDir upgradeCmd (UpgradeOptions (Just pkg)) cfg = do specDir <- getLocalPackageSpec cfg "." logInfo $ "Upgrade " ++ pkg upgradeSinglePackage cfg specDir pkg --- `link` command. linkCmd :: LinkOptions -> Config -> ErrorLogger () linkCmd (LinkOptions src) cfg = do specDir <- getLocalPackageSpec cfg "." cleanCurryPathCache specDir logInfo $ "Linking '" ++ src ++ "' into local package cache..." linkToLocalCache cfg src specDir --- `add` command: --- Option `--package`: copy the given package to the repository index --- and package installation directory so that it is available as --- any other package. --- Option `--dependency`: add the package name as a dependency to the --- current package --- No option: like `--package` followed by `install` command addCmd :: AddOptions -> Config -> ErrorLogger () addCmd (AddOptions addpkg adddep pkg force) config | addpkg = addPackageToRepository config pkg force True | adddep = addDependencyCmd pkg force config | otherwise = do addDependencyCmd pkg force config installCmd (installOpts defaultOptions) config useForce :: String useForce = "Use option '-f' or '--force' to overwrite it." --- `add --dependency` command: add the given package as a new --- dependency to the current package. addDependencyCmd :: String -> Bool -> Config -> ErrorLogger () addDependencyCmd pkgname force config = do allpkgs <- getAllPackageVersions config pkgname False case allpkgs of [] -> packageNotFoundFailure pkgname ps -> case filter (isCompatibleToCompiler config) ps of [] -> compatPackageNotFoundFailure config pkgname useUpdateHelp (p:_) -> do pkgdir <- getLocalPackageSpec config "." addDepToLocalPackage (version p) pkgdir where addDepToLocalPackage vers pkgdir = do pkgSpec <- loadPackageSpec pkgdir let depexists = pkgname `elem` dependencyNames pkgSpec newdeps = addDep [[VGte vers, VLt (nextMajor vers)]] (dependencies pkgSpec) newpkg = pkgSpec { dependencies = newdeps } if force || not depexists then do liftIOEL $ writePackageSpec newpkg (pkgdir "package.json") logInfo $ "Dependency '" ++ pkgname ++ " >= " ++ showVersion vers ++ "' added to package '" ++ pkgdir ++ "'" else logCritical $ "Dependency '" ++ pkgname ++ "' already exists!\n" ++ useForce addDep vcs [] = [Dependency pkgname vcs] addDep vcs (Dependency pn pvcs : deps) = if pn == pkgname then Dependency pn vcs : deps else Dependency pn pvcs : addDep vcs deps ------------------------------------------------------------------------------ --- `doc` command: run `curry doc` on the modules provided as an argument --- or, if they are not given, on exported modules (if specified in the --- package), on the main executable (if specified in the package), --- or on all source modules of the package. docCmd :: DocOptions -> Config -> ErrorLogger () docCmd opts cfg = do specDir <- getLocalPackageSpec cfg "." pkg <- loadPackageSpec specDir let docdir = maybe "cdoc" id (docDir opts) packageId pkg absdocdir <- liftIOEL $ getAbsolutePath docdir liftIOEL $ createDirectoryIfMissing True absdocdir when (docReadme opts) $ genPackageREADME pkg specDir absdocdir when (docManual opts) $ genPackageManual pkg specDir absdocdir when (docPrograms opts) $ genDocForPrograms opts cfg absdocdir specDir pkg --- Translate package README file to HTML, if possible (i.e., some README --- file and `pandoc` exists). Two README files are produced: --- `README.html` (standalone document) and `README_I.html` (document --- fragment without header and footer). genPackageREADME :: Package -> String -> String -> ErrorLogger () genPackageREADME _ specDir outputdir = do rmfiles <- getReadmeFiles ispandoc <- liftIOEL $ fileInPath "pandoc" if null rmfiles || not ispandoc then do logInfo $ "'README.html' not generated: " ++ if ispandoc then "no README file found" else "executable 'pandoc' not found" else do let readmefile = head rmfiles formatcmd1 = formatCmd1 readmefile formatcmd2 = formatCmd2 readmefile logDebug $ "Executing command: " ++ formatcmd1 rc1 <- inDirectoryEL specDir $ liftIOEL $ system formatcmd1 logDebug $ "Executing command: " ++ formatcmd2 rc2 <- inDirectoryEL specDir $ liftIOEL $ system formatcmd2 if rc1 == 0 && rc2 == 0 then do -- make them readable: liftIOEL $ system $ unwords ["chmod -f 644 ", quote outfile1, quote outfile2] logInfo $ "'" ++ readmefile ++ "' translated to '" ++ outfile1 ++ "'." else fail $ "Error during execution of commands:\n" ++ formatcmd1 ++ "\n" ++ formatcmd2 where outfile1 = outputdir "README.html" outfile2 = outputdir "README_I.html" getReadmeFiles = do entries <- liftIOEL $ getDirectoryContents specDir return $ filter ("README" `isPrefixOf`) entries formatCmd1 readme = "pandoc -s -t html -o " ++ outfile1 ++ " " ++ readme formatCmd2 readme = "pandoc -t html -o " ++ outfile2 ++ " " ++ readme --- Generate manual according to documentation specification of package. genPackageManual :: Package -> String -> String -> ErrorLogger () genPackageManual pkg specDir outputdir = case documentation pkg of Nothing -> return () Just (PackageDocumentation docdir docmain doccmd) -> do let formatcmd = replaceSubString "OUTDIR" outputdir $ if null doccmd then formatCmd docmain else doccmd if null formatcmd then logInfo $ "Cannot format documentation file '" ++ docmain ++ "' (unknown kind)" else do logDebug $ "Executing command: " ++ formatcmd rc <- inDirectoryEL (specDir docdir) $ liftIOEL $ system formatcmd if rc == 0 then do let outfile = outputdir replaceExtension docmain ".pdf" -- make it readable: liftIOEL $ system ("chmod -f 644 " ++ quote outfile) logInfo $ "Package documentation written to '" ++ outfile ++ "'." else fail $ "Error during execution of command:\n" ++ formatcmd where formatCmd docmain | ".tex" `isSuffixOf` docmain = let formatcmd = "pdflatex -output-directory=\"OUTDIR\" " ++ docmain in formatcmd ++ " && " ++ formatcmd | ".md" `isSuffixOf` docmain = "pandoc " ++ docmain ++ " -o \"OUTDIR" replaceExtension docmain ".pdf" ++ "\"" | otherwise = "" --- Replace every occurrence of the first argument by the second argument --- in a string (third argument). replaceSubString :: String -> String -> String -> String replaceSubString sub newsub s = replString s where sublen = length sub replString [] = [] replString ccs@(c:cs) = if take sublen ccs == sub then newsub ++ replString (drop sublen ccs) else c : replString cs --- Generate program documentation: --- run `curry-doc` on the modules provided as an argument --- or, if they are not given, on exported modules (if specified in the --- package), on the main executable (if specified in the package), --- or on all source modules of the package. genDocForPrograms :: DocOptions -> Config -> String -> String -> Package -> ErrorLogger () genDocForPrograms opts cfg docdir specDir pkg = do abspkgdir <- liftIOEL $ getAbsolutePath specDir checkCompiler cfg pkg let exports = exportedModules pkg mainmods = map (\ (PackageExecutable _ emain _) -> emain) (executableSpec pkg) (docmods,apidoc) <- maybe (if null exports then if null mainmods then (do ms <- liftIOEL $ curryModulesInDir (specDir "src") return (ms,True)) else return (mainmods,False) else return (exports,True)) (\ms -> return (ms,True)) (docModules opts) if null docmods then logInfo "No modules to be documented!" else do currypath <- getCurryLoadPath cfg specDir let pkgurls = path2packages abspkgdir currypath if apidoc then do mapM_ (docModule currypath pkgurls) docmods runDocCmd currypath pkgurls (["--title", apititle, "--onlyindexhtml", docdir] ++ docmods) logInfo ("Documentation generated in '"++docdir++"'") else runDocCmd currypath pkgurls [docdir, head docmods] where apititle = "\"Package " ++ name pkg ++ "\"" getCurryDoc = do mbf <- liftIOEL $ getFileInPath cdbin maybe (do let cpmcurrydoc = binInstallDir cfg cdbin cdex <- liftIOEL $ doesFileExist cpmcurrydoc if cdex then return cpmcurrydoc else fail $ "Executable '" ++ cdbin ++ "' not found!" ) return mbf where cdbin = "curry-doc" docModule currypath uses mod = runDocCmd currypath uses ["--noindexhtml", docdir, mod] runDocCmd currypath uses docparams = do currydoc <- getCurryDoc let useopts = if docGenImports opts then [] else map (\ (d,u) -> "--use "++d++"@"++u) uses cmd = unwords (currydoc : useopts ++ docparams) logInfo $ "Running CurryDoc: " ++ cmd execWithCurryPath (ExecOptions cmd) cfg currypath -- translates a path into a list of package paths and their doc URLs: path2packages absdir path = let dirs = splitSearchPath path importPkgDir = absdir ".cpm" "packages" ++ [pathSeparator] isImportedPackage d = importPkgDir `isPrefixOf` d impPkg2URL p = let (d,_) = break isPathSeparator (drop (length importPkgDir) p) in docPackageURL opts ++ "/" ++ d in map (\ip -> (ip,impPkg2URL ip)) (filter isImportedPackage dirs) ++ if name pkg == "base" then [] -- in order to generate base package documentation else [(installDir "lib", docPackageURL opts ++ "/base-" ++ compilerBaseVersion cfg)] ------------------------------------------------------------------------------ --- `test` command: run `curry-check` on the modules provided as an argument --- or, if they are not provided, on the exported (if specified) --- or all source modules of the package. testCmd :: TestOptions -> Config -> ErrorLogger () testCmd opts cfg = do specDir <- getLocalPackageSpec cfg "." pkg <- loadPackageSpec specDir checkCompiler cfg pkg aspecDir <- liftIOEL $ getAbsolutePath specDir mainprogs <- liftIOEL $ curryModulesInDir (aspecDir "src") let tests = testSuites pkg mainprogs stats <- if null tests then do logInfo "No modules to be tested!" return [] else mapM (execTest aspecDir) tests unless (null (testFile opts)) $ liftIOEL $ combineCSVStatsOfPkg (packageId pkg) (concat stats) (testFile opts) where getCurryCheck = do mbf <- liftIOEL $ getFileInPath ccbin maybe (do let cpmcurrycheck = binInstallDir cfg ccbin ccex <- liftIOEL $ doesFileExist cpmcurrycheck if ccex then return cpmcurrycheck else fail $ "Executable '" ++ ccbin ++ "' not found!" ) return mbf where ccbin = "curry-check" execTest apkgdir (PackageTest dir mods pccopts script) = do currycheck <- getCurryCheck pid <- liftIOEL getPID let csvfile = "TESTRESULT" ++ show pid ++ ".csv" statopts = if null (testFile opts) then [] else ["statfile=" ++ csvfile] tccopts = unwords (map ("--" ++) (testCheckOpts opts ++ statopts) ++ (if testSafe opts then ["--noiotest"] else [])) ccopts = if null tccopts then pccopts else if null pccopts then tccopts else tccopts ++ ' ' : pccopts scriptcmd = "CURRYBIN=" ++ curryExec cfg ++ " && export CURRYBIN && " ++ "." script ++ if null pccopts then "" else ' ' : pccopts checkcmd = currycheck ++ if null ccopts then "" else ' ' : ccopts unless (null mods) $ putStrLnELM $ "Running CurryCheck (" ++ checkcmd ++ ")\n" ++ "(in directory '" ++ dir ++ "', showing raw output) on modules:\n" ++ unwords mods ++ "\n" unless (null script) $ putStrLnELM $ "Executing test script with command:\n" ++ scriptcmd ++ "\n" ++ "(in directory '" ++ dir ++ "', showing raw output):\n" let currysubdir = apkgdir addCurrySubdir dir testcmd = if not (null mods) then unwords (checkcmd : mods) else scriptcmd logDebug $ "Removing directory: " ++ currysubdir showExecCmd (unwords ["rm", "-rf", currysubdir]) inDirectoryEL (apkgdir dir) $ do execWithPkgDir (ExecOptions testcmd) cfg apkgdir if null (testFile opts) || null mods then return [] else do s <- liftIOEL $ readCompleteFile csvfile liftIOEL $ removeFile csvfile return [readCSV s] testSuites spec mainprogs = case testModules opts of Nothing -> maybe (let exports = exportedModules spec in if null exports then if null mainprogs then [] else [PackageTest "src" mainprogs "" ""] else [PackageTest "src" exports "" ""]) (filter allowedTest) (testSuite spec) Just ms -> [PackageTest "src" ms "" ""] where allowedTest (PackageTest _ _ _ scrpt) = not (testSafe opts) || null scrpt -- Combine all CSV statistics (produced by CurryCheck for a package) -- into one file in CSV format by accumulating all numbers and modules. combineCSVStatsOfPkg :: String -> [[[String]]] -> String -> IO () combineCSVStatsOfPkg pkgid csvs outfile = do ltime <- getLocalTime let results = foldr addStats ([], take 6 (repeat 0), "") (map fromCSV csvs) writeCSVFile outfile (showStats (calendarTimeToString ltime) results) where fromCSV rows = let [rc,total,unit,prop,eqv,io,mods] = rows !! 1 in (rows !! 0, map (\s -> read s :: Int) [rc,total,unit,prop,eqv,io], mods) showStats ct (header,nums,mods) = ["Package" : "Check time" : header, pkgid : ct : map show nums ++ [mods]] addStats (header,nums1,mods1) (_,nums2,mods2) = (header, map (uncurry (+)) (zip nums1 nums2), mods1 ++ " " ++ mods2) --- Get the names of all Curry modules contained in a directory. --- Modules in subdirectories are returned as hierarchical modules. curryModulesInDir :: String -> IO [String] curryModulesInDir dir = getModules "" dir where getModules p d = do exdir <- doesDirectoryExist d entries <- if exdir then getDirectoryContents d else return [] let realentries = filter (\f -> length f >= 1 && head f /= '.') entries newprogs = filter (\f -> takeExtension f == ".curry") realentries subdirs <- mapM (\e -> do b <- doesDirectoryExist (d e) return $ if b then [e] else []) realentries >>= return . concat subdirentries <- mapM (\s -> getModules (p ++ s ++ ".") (d s)) subdirs return $ map ((p ++) . stripCurrySuffix) newprogs ++ concat subdirentries diffCmd :: DiffOptions -> Config -> ErrorLogger () diffCmd opts cfg = do specDir <- getLocalPackageSpec cfg "." localSpec <- loadPackageSpec specDir checkCompiler cfg localSpec let localname = name localSpec localv = version localSpec showlocalv = showVersion localv repo <- getRepoForPackageSpec cfg localSpec diffv <- getDiffVersion repo localname if diffv == localv then fail $ "Cannot diff identical package versions " ++ showlocalv else do putStrLnELM $ "Comparing local version " ++ showlocalv ++ " and repository version " ++ showVersion diffv ++ ":\n" installIfNecessary repo localname diffv putStrLnELM "" gc <- readGlobalCache cfg repo diffAPIIfEnabled repo gc specDir localSpec diffv diffBehaviorIfEnabled repo gc specDir localSpec diffv liftIOEL $ cleanTempDir where getDiffVersion repo localname = case diffVersion opts of Nothing -> case findLatestVersion cfg repo localname False of Nothing -> fail $ "No other version of local package '" ++ localname ++ "' compatible to '" ++ showCompilerVersion cfg ++ "' found in package repository." Just p -> return (version p) Just v -> return v installIfNecessary repo pkgname ver = case findVersion repo pkgname ver of Nothing -> packageNotFoundFailure $ pkgname ++ "-" ++ showVersion ver Just p -> acquireAndInstallPackageWithDependencies cfg repo p diffAPIIfEnabled repo gc specDir localSpec diffversion = when (diffAPI opts) $ do putStrLnELM "Running API diff...\n" diffResults <- APIDiff.compareModulesFromPackageAndDir cfg repo gc specDir (name localSpec) diffversion (diffModules opts) let diffOut = APIDiff.showDifferences (map snd diffResults) (version localSpec) diffversion unless (null diffOut) (putStrLnELM diffOut >> putStrLnELM "") diffBehaviorIfEnabled repo gc specDir localSpec diffversion = when (diffBehavior opts) $ do putStrLnELM "Preparing behavior diff...\n" i <- BDiff.preparePackageAndDir cfg repo gc specDir (name localSpec) diffversion BDiff.diffBehavior cfg repo gc i (diffGroundEqu opts) (diffUseAna opts) (diffModules opts) -- Implementation of the `curry` command. curryCmd :: ExecOptions -> Config -> ErrorLogger () curryCmd o cfg = do pkgdir <- getLocalPackageSpec cfg "." pkg <- loadPackageSpec pkgdir checkCompiler cfg pkg execWithPkgDir (ExecOptions $ unwords [curryExec cfg, "--nocypm", exeCommand o]) cfg pkgdir -- Implementation of the `exec` command. execCmd :: ExecOptions -> Config -> ErrorLogger () execCmd o cfg = do pkgdir <- getLocalPackageSpec cfg "." execWithPkgDir o cfg pkgdir execWithPkgDir :: ExecOptions -> Config -> String -> ErrorLogger () execWithPkgDir o cfg specDir = do cp <- getCurryLoadPath cfg specDir execWithCurryPath o cfg cp execWithCurryPath :: ExecOptions -> Config -> String -> ErrorLogger () execWithCurryPath o _ currypath = do logDebug $ "Setting CURRYPATH to " ++ currypath liftIOEL $ setEnv "CURRYPATH" currypath ecode <- showExecCmd (exeCommand o) liftIOEL $ unsetEnv "CURRYPATH" liftIOEL $ unless (ecode==0) (exitWith ecode) computePackageLoadPath :: Config -> String -> ErrorLogger String computePackageLoadPath cfg pkgdir = do logDebug "Computing load path for package..." pkg <- loadPackageSpec pkgdir allpkgs <- resolveAndCopyDependenciesForPackage cfg pkgdir pkg abs <- liftIOEL $ getAbsolutePath pkgdir let srcdirs = map (abs ) (sourceDirsOf pkg) -- remove 'base' package since it is in the compiler libraries: pkgs = filter (\p -> name p /= "base") allpkgs currypath = joinSearchPath (srcdirs ++ dependencyPathsSeparate pkgs abs) liftIOEL $ saveCurryPathToCache cfg pkgdir currypath return currypath --- Implementation of the `new` command: create a new package. newCmd :: NewOptions -> ErrorLogger () newCmd (NewOptions pname) = do exists <- liftIOEL $ doesDirectoryExist pname when exists $ do logError $ "There is already a directory with the new project name.\n" ++ "I cannot create new project!" liftIOEL $ exitWith 1 liftIOEL $ do let emptyAuthor = "YOUR NAME " emptySynopsis = "PLEASE PROVIDE A ONE-LINE SUMMARY ABOUT THE PACKAGE" createDirectory pname let pkgSpec = emptyPackage { name = pname , version = initialVersion , author = [emptyAuthor] , synopsis = emptySynopsis , category = ["Programming"] , dependencies = [] , exportedModules = [] , license = Just "BSD-3-Clause" , licenseFile = Just "LICENSE" } writePackageSpec pkgSpec (pname "package.json") let licenseFile = packagePath "templates" "LICENSE" whenFileExists licenseFile $ copyFile licenseFile (pname "LICENSE") createDirectory (pname "src") let cmain = "Main.curry" mainFile = packagePath "templates" cmain whenFileExists mainFile $ copyFile mainFile (pname "src" cmain) writeFile (pname "README.md") readme writeFile (pname ".gitignore") gitignore putStr $ unlines todo where readme = unlines [pname, take (length pname) (repeat '=')] gitignore = unlines ["*~", ".cpm", ".curry"] todo = [ "A new package in the directory '" ++ pname ++ "' has been created!" , "" , "Please go into this directory and edit the file 'package.json':" , "- enter correct values for the fields 'author', 'synopsis', 'category'" , "- add dependencies in the field 'dependencies'" , "- add further fields (e.g., 'description')" , "- review field 'license' (and adapt file 'LICENSE')" , "" , "Then run 'cypm install' to install all dependencies and" , "put your program code in directory 'src'" , "(where you find a template file 'Main.curry')" , "" , "Run the main program with:" , "> cypm curry :load Main :eval main :quit" ] ------------------------------------------------------------------------------ --- Uploads the current package to the package server. --- If the package has a GIT repository with tag `$version` --- and the option `--notagging` is not given, the package version --- is set as a tag (in the local GIT repository) and then pushed --- to the repostory. --- Then, the current package is tested (as with `cypm test`). --- If the test fails, the package is not uploaded. --- If the test succeeds, an existing locally installed package --- is removed, the package is added to the local copy of the repository, --- and the `package.json` is uploaded via the script specified --- in `uploadURL`. uploadCmd :: UploadOptions -> Config -> ErrorLogger () uploadCmd opts cfg = do specDir <- getLocalPackageSpec cfg "." lpkg <- loadPackageSpec specDir let pkgrepodir = repositoryDir cfg name lpkg showVersion (version lpkg) exrepodir <- liftIOEL $ doesDirectoryExist pkgrepodir if exrepodir && not (forceUpdate opts) then fail "Package version already exists in repository!" else return () inDirectoryEL specDir $ setTagInGitIfNecessary opts lpkg instdir <- liftIOEL tempDir liftIOEL $ recreateDirectory instdir installPkg lpkg instdir let pkgid = packageId lpkg pkg <- loadPackageSpec (instdir pkgid) -- Test package if CurryCheck is installed: mbccfile <- liftIOEL $ getFileInPath "curry-check" ecode <- maybe (return 0) (\_ -> testPackage pkgid instdir) mbccfile if ecode > 0 then do liftIOEL cleanTempDir logCritical "ERROR in package, package not uploaded!" else do logInfo "Uploading package to global repository..." -- remove package possibly existing in global package cache: liftIOEL $ removeDirectoryComplete (installedPackageDir cfg pkg) uploadPackageSpec (instdir pkgid "package.json") addPackageToRepo pkgrepodir (instdir pkgid) pkg liftIOEL $ cleanTempDir logInfo $ "Package '" ++ pkgid ++ "' uploaded" where -- add package to local copy of repository: addPackageToRepo pkgrepodir pkgdir pkg = do exrepodir <- liftIOEL $ doesDirectoryExist pkgrepodir logInfo $ "Create directory: " ++ pkgrepodir liftIOEL $ do createDirectoryIfMissing True pkgrepodir copyFile (pkgdir "package.json") (pkgrepodir "package.json") if exrepodir then updatePackageInRepositoryCache cfg pkg else addPackageToRepositoryCache cfg pkg -- TODO: check url installPkg pkg instdir = case source pkg of Nothing -> fail $ "No source specified for package" Just (Git url rev) -> installPackageSourceTo pkg (Git url rev) instdir _ -> fail $ "No git source with version tag" testPackage pkgid instdir = do curdir <- inDirectoryEL instdir $ liftIOEL $ getCurrentDirectory let bindir = curdir "pkgbin" liftIOEL $ recreateDirectory bindir let cmd = unwords [ -- install possible binaries in bindir: "cypm", "-d bin_install_path="++bindir, "install", "&&" , "export PATH="++bindir++":$PATH", "&&" , "cypm", "test", "&&" , "cypm", "-d bin_install_path="++bindir, "uninstall" ] putStrLnELM $ "Testing package: '" ++ pkgid ++ "' with command:\n" ++ cmd inDirectoryEL (instdir pkgid) $ liftIOEL $ system cmd --- Set the package version as a tag in the local GIT repository and push it, --- if the package source is a GIT with tag `$version`. setTagInGitIfNecessary :: UploadOptions -> Package -> ErrorLogger () setTagInGitIfNecessary opts pkg | not (setTag opts) = return () | otherwise = case source pkg of Just (Git _ (Just VersionAsTag)) -> setTagInGit pkg _ -> return () setTagInGit :: Package -> ErrorLogger () setTagInGit pkg = do let ts = 'v' : showVersion (version pkg) logInfo $ "Tagging current git repository with tag '" ++ ts++ "'" (_,gittag,_) <- liftIOEL $ evalCmd "git" ["tag","-l",ts] "" let deltag = if null gittag then [] else ["git tag -d",ts,"&&"] cmd = unwords $ deltag ++ ["git tag -a",ts,"-m",ts,"&&", "git push --tags -f"] logInfo $ "Execute: " ++ cmd ecode <- liftIOEL $ system cmd if ecode == 0 then return () else fail $ "ERROR in setting the git tag" -- Uploads a package specification stored in a file (first argument, -- like `.../package.json`) with the web script specified by `uploadURL`. uploadPackageSpec :: String -> ErrorLogger () uploadPackageSpec pkgspecfname = do pkgspec <- liftIOEL $ readFile pkgspecfname let curlopts = ["--data-binary", "@-", uploadURL ] logDebug $ unwords ("curl" : curlopts) ++ "\n" ++ pkgspec (rc,out,err) <- liftIOEL $ evalCmd "curl" curlopts pkgspec unless (null out) $ logInfo out if rc == 0 then return () else do logInfo err fail "Adding to global repository failed!" -- URL of cpm-upload script. uploadURL :: String uploadURL = "https://www-ps.informatik.uni-kiel.de/~cpm/cpm-upload.cgi" ------------------------------------------------------------------------------ --- Fail with a "package not found" message. packageNotFoundFailure :: String -> ErrorLogger _ packageNotFoundFailure pkgname = fail $ "Package '" ++ pkgname ++ "' not found in package repository.\n" ++ useUpdateHelp --- Fail with a "compatible package not found" message and a comment compatPackageNotFoundFailure :: Config -> String -> String -> ErrorLogger _ compatPackageNotFoundFailure cfg pkgname helpcmt = fail $ "No version of package '" ++ pkgname ++ "' compatible to '" ++ showCompilerVersion cfg ++ "' found!\n" ++ helpcmt --------------------------------------------------------------------------- -- Caching the current CURRYPATH of a package for faster startup. -- The file `.cpm/CURRYPATH_CACHE` contains the following lines: -- * The CURRYPATH used to load the package -- * The compiler name and major/minor/revision version -- * The version of the base libraries required during package install --- The name of the cache file in a package directory. curryPathCacheFile :: String -> String curryPathCacheFile pkgdir = pkgdir ".cpm" "CURRYPATH_CACHE" --- Saves package CURRYPATH in local cache file in the given package dir. saveCurryPathToCache :: Config -> String -> String -> IO () saveCurryPathToCache cfg pkgdir path = do let cpmdir = pkgdir ".cpm" createDirectoryIfMissing False cpmdir writeFile (curryPathCacheFile pkgdir) (unlines [path, showCompilerVersion cfg, compilerBaseVersion cfg]) --- Gets CURRYPATH of the given package (either from the local cache file --- in the package dir or compute it). getCurryLoadPath :: Config -> String -> ErrorLogger String getCurryLoadPath cfg pkgdir = do mbp <- loadCurryPathFromCache cfg pkgdir maybe (computePackageLoadPath cfg pkgdir) return mbp --- Restores package CURRYPATH from local cache file in the given package dir, --- if it is still up-to-date, i.e., it exists and is newer than the package --- specification. loadCurryPathFromCache :: Config -> String -> ErrorLogger (Maybe String) loadCurryPathFromCache cfg pkgdir = do let cachefile = curryPathCacheFile pkgdir excache <- liftIOEL $ doesFileExist cachefile if excache then do cftime <- liftIOEL $ getModificationTime cachefile pftime <- liftIOEL $ getModificationTime (pkgdir "package.json") if cftime > pftime then do cnt <- liftIOEL $ safeReadFile cachefile let ls = either (const []) lines cnt return $ if consistentCache ls then Just (head ls) else Nothing else return Nothing else return Nothing where consistentCache cls = length cls > 2 && cls!!1 == showCompilerVersion cfg && cls!!2 == compilerBaseVersion cfg --- Cleans the local cache file for CURRYPATH. This might be necessary --- for upgrade/install/link commands. cleanCurryPathCache :: String -> ErrorLogger () cleanCurryPathCache pkgdir = liftIOEL $ do let pathcachefile = curryPathCacheFile pkgdir whenFileExists pathcachefile $ removeFile pathcachefile return () ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/src/CPM/Package.curry000066400000000000000000001241271377556325500206440ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains the data types for a package specification and --- versions as well as functions for reading/showing/comparing package specs --- and package versions. ------------------------------------------------------------------------------ module CPM.Package ( Version, initialVersion, nextMajor, nextMinor , VersionConstraint (..) , CompilerCompatibility (..) , Package (..), emptyPackage , Dependency (..) , execOfPackage , showVersion , replaceVersionInTag , readVersion , packageIdEq , showSourceOfPackage , readVersionConstraint , readVersionConstraints , readPackageSpec , sourceDirsOf , dependencyNames , vlt , vlte , vgt , vgte , isPreRelease , packageId , PackageId (..) , PackageSource (..) , GitRevision (..) , PackageExecutable (..), PackageTest (..), PackageDocumentation (..) , showDependency , showCompilerDependency , showVersionConstraints , loadPackageSpec , writePackageSpec , Conjunction , Disjunction , packageSpecToJSON ) where import Data.Char import Data.Either import Data.List ( intercalate, intersperse, isInfixOf, splitOn ) import System.FilePath ( () ) import System.Directory ( doesFileExist ) import System.IOExts ( readCompleteFile ) import JSON.Data import JSON.Parser import JSON.Pretty ( ppJSON ) import Test.Prop import Prelude hiding ( (<$>), (<*>), (<*), (*>), (<|>), some, empty ) import DetParse import CPM.ErrorLogger --- Data type representin a version number. --- It is a tuple where the components are major, minor, patch, prerelease, --- e.g., 3.1.1-rc5 type Version = (Int, Int, Int, Maybe String) --- The initial version of a new package. initialVersion :: Version initialVersion = (0,0,1,Nothing) --- The next major version of a given version. nextMajor :: Version -> Version nextMajor (maj,_,_,_) = (maj + 1, 0, 0, Nothing) --- The next minor version of a given version. nextMinor :: Version -> Version nextMinor (maj,min,_,_) = (maj, min + 1, 0, Nothing) type Conjunction = [VersionConstraint] type Disjunction = [Conjunction] --- A dependency on another package. The disjunctive normal form of a boolean --- combination of version constraints is represented by a list of lists of --- version constraint. Each inner list of version constraints is a conjunction, --- the outer list is a disjunction. data Dependency = Dependency String Disjunction deriving (Eq,Show) --- A version constraint. --- @cons VExact - versions must match exactly --- @cons VGt - version must be strictly larger than specified version --- @cons VLt - version must be strictly smaller than specified version --- @cons VGte - version must be larger or equal to specified version --- @cons VLte - version must be smaller or equal to specified version --- @cons VMinCompatible - version must be larger or equal and --- within same minor version --- @cons VMajCompatible - version must be larger or equal and --- within same minor version data VersionConstraint = VExact Version | VGt Version | VLt Version | VGte Version | VLte Version | VMinCompatible Version | VMajCompatible Version deriving (Eq,Show) --- Compiler compatibility constraint, takes the name of the compiler (kics2 or --- pakcs), as well as a disjunctive normal form combination of version --- constraints (see Dependency). data CompilerCompatibility = CompilerCompatibility String Disjunction deriving (Eq,Show) --- A package id consisting of the package name and version. data PackageId = PackageId String Version --- The specification to generate an executable from the package. --- It consists of the name of the executable, the name of the main --- module (which must contain an operation `main`), and list --- of options for various compilers (i.e., pairs of compiler name and --- options for this compiler). data PackageExecutable = PackageExecutable String String [(String,String)] deriving (Eq,Show) --- The specification of a single test suite for a package. --- It consists of a directory, a list of modules, options (for CurryCheck), --- and a name of a test script in this directory. --- The test script can be empty, but then a non-empty list of modules must be --- provided. --- This structure specifies a test which is performed in the given directory --- by running CurryCheck on the given list of modules where the option --- string is passed to CurryCheck. data PackageTest = PackageTest String [String] String String deriving (Eq,Show) --- The specification to generate the documentation of the package. --- It consists of the name of the directory containing the documentation, --- a main file (usually, a LaTeX file) containing the documentation, --- and a command to generate the documentation. If the command is missing --- and the main file has the suffix "tex", e.g., "manual.tex", --- the default command is "pdflatex manual.tex". data PackageDocumentation = PackageDocumentation String String String deriving (Eq,Show) --- A source where the contents of a package can be acquired. --- @cons Http - URL to a ZIP file --- @cons Git - URL to a Git repository and an optional revision spec to check --- out --- @cons FileSource - The path to a ZIP file to install. Cannot be specified in --- a package specification file, for internal use only. data PackageSource = Http String | Git String (Maybe GitRevision) | FileSource String deriving (Eq,Show) --- A Git revision. --- @cons Tag - A tag which might contain the string `$version$` which will --- be replaced by the package version --- @cons Ref - A Git 'commitish', i.e. a SHA, a branch name, a tag name etc. --- @cons VersionAsTag - Use the package version prefixed with a 'v' as the tag data GitRevision = Tag String | Ref String | VersionAsTag deriving (Eq,Show) --- The data type for package specifications. data Package = Package { name :: String , version :: Version , author :: [String] , maintainer :: [String] , synopsis :: String , description :: Maybe String , category :: [String] , license :: Maybe String , licenseFile :: Maybe String , copyright :: Maybe String , homepage :: Maybe String , bugReports :: Maybe String , repository :: Maybe String , dependencies :: [Dependency] , compilerCompatibility :: [CompilerCompatibility] , source :: Maybe PackageSource , sourceDirs :: [String] , exportedModules :: [String] , configModule :: Maybe String , executableSpec :: [PackageExecutable] , testSuite :: Maybe [PackageTest] , documentation :: Maybe PackageDocumentation } deriving (Eq,Show) -- A simple Show instance for Package (maybe useful for debugging): --instance Show Package where -- show p = "(Package " ++ -- unwords [name p, showVersion (version p) -- , unwords (map showDependency (dependencies p))] ++ ")" --- An empty package specification. emptyPackage :: Package emptyPackage = Package { name = "" , version = initialVersion , author = [] , maintainer = [] , synopsis = "" , description = Nothing , category = [] , license = Nothing , licenseFile = Nothing , copyright = Nothing , homepage = Nothing , bugReports = Nothing , repository = Nothing , dependencies = [] , compilerCompatibility = [] , source = Nothing , sourceDirs = [] , exportedModules = [] , configModule = Nothing , executableSpec = [] , testSuite = Nothing , documentation = Nothing } --- Returns the names of the executables of the package. --- Returns the empty string if the package has no executable to install. execOfPackage :: Package -> String execOfPackage p = unwords (map (\ (PackageExecutable e _ _) -> e) (executableSpec p)) ------------------------------------------------------------------------------ --- Translates a package to a JSON object. packageSpecToJSON :: Package -> JValue packageSpecToJSON pkg = JObject $ [ ("name", JString $ name pkg) , ("version", JString $ showVersion $ version pkg) ] ++ (case author pkg of [] -> [("author", JString "")] [s] -> [("author", JString s)] xs -> stringListToJSON "author" xs) ++ (case maintainer pkg of [] -> [] [s] -> [ ("maintainer", JString s) ] xs -> stringListToJSON "maintainer" xs) ++ [ ("synopsis", JString $ synopsis pkg) ] ++ maybeStringToJSON "description" (description pkg) ++ stringListToJSON "category" (category pkg) ++ maybeStringToJSON "license" (license pkg) ++ maybeStringToJSON "licenseFile" (licenseFile pkg) ++ maybeStringToJSON "copyright" (copyright pkg) ++ maybeStringToJSON "homepage" (homepage pkg) ++ maybeStringToJSON "bugReports" (bugReports pkg) ++ maybeStringToJSON "repository" (repository pkg) ++ [ ("dependencies", dependenciesToJSON $ dependencies pkg) ] ++ compilerCompatibilityToJSON (compilerCompatibility pkg) ++ maybeSourceToJSON (source pkg) ++ stringListToJSON "sourceDirs" (sourceDirs pkg) ++ stringListToJSON "exportedModules" (exportedModules pkg) ++ maybeStringToJSON "configModule" (configModule pkg) ++ (case executableSpec pkg of [] -> [] [e] -> [("executable", execToJSON e)] es -> [("executables", JArray $ map execToJSON es)]) ++ maybeTestToJSON (testSuite pkg) ++ maybeDocuToJSON (documentation pkg) where dependenciesToJSON deps = JObject $ map dependencyToJSON deps where dependencyToJSON (Dependency p vc) = (p, JString $ showVersionConstraints vc) compilerCompatibilityToJSON deps = if null deps then [] else [("compilerCompatibility", JObject $ map compatToJSON deps)] where compatToJSON (CompilerCompatibility p vc) = (p, JString $ showVersionConstraints vc) maybeSourceToJSON = maybe [] (\src -> [("source", JObject (pkgSourceToJSON src))]) where pkgSourceToJSON (FileSource _) = error "Internal error: FileSource in package specification" pkgSourceToJSON (Http url) = [("http", JString url)] pkgSourceToJSON (Git url mbrev) = [("git", JString url)] ++ maybe [] revToJSON mbrev where revToJSON (Ref t) = [("ref", JString t)] revToJSON (Tag t) = [("tag", JString t)] revToJSON VersionAsTag = [("tag", JString "$version")] execToJSON (PackageExecutable ename emain eopts) = JObject $ [ ("name", JString ename), ("main", JString emain)] ++ exOptsToJSON where exOptsToJSON = if null eopts then [] else [("options", JObject $ map (\ (c,o) -> (c, JString o)) eopts)] maybeTestToJSON = maybe [] (\tests -> [("testsuite", testsToJSON tests)]) where testsToJSON tests = if length tests == 1 then testToJSON (head tests) else JArray $ map testToJSON tests testToJSON (PackageTest dir mods opts script) = JObject $ [ ("src-dir", JString dir) ] ++ (if null opts then [] else [("options", JString opts)]) ++ stringListToJSON "modules" mods ++ (if null script then [] else [("script", JString script)]) maybeDocuToJSON = maybe [] (\ (PackageDocumentation docdir docmain doccmd) -> [("documentation", JObject $ [ ("src-dir", JString docdir) , ("main", JString docmain)] ++ if null doccmd then [] else [("command", JString doccmd)] )]) stringListToJSON fname exps = if null exps then [] else [(fname, JArray $ map JString exps)] maybeStringToJSON fname = maybe [] (\s -> [(fname, JString s)]) --- Writes a basic package specification to a JSON file. --- --- @param pkg the package specification to write --- @param file the file name to write to writePackageSpec :: Package -> String -> IO () writePackageSpec pkg file = writeFile file $ ppJSON $ packageSpecToJSON pkg --- Loads a package specification from a package directory. --- --- @param the directory containing the package.json file loadPackageSpec :: String -> ErrorLogger Package loadPackageSpec dir = do let packageFile = dir "package.json" exfile <- liftIOEL $ doesFileExist packageFile if exfile then do logDebug $ "Reading package specification '" ++ packageFile ++ "'..." contents <- liftIOEL $ readCompleteFile packageFile case readPackageSpec contents of Left err -> fail err Right v -> return v else fail $ "Illegal package: file `" ++ packageFile ++ "' does not exist!" --- Checks whether two package ids are equal, i.e. if their names and versions --- match. --- --- @param p1 the first package --- @param p2 the second package packageIdEq :: Package -> Package -> Bool packageIdEq p1 p2 = name p1 == name p2 && version p1 == version p2 --- Shows the package source in human-readable format. showSourceOfPackage :: Package -> String showSourceOfPackage pkg = case source pkg of Nothing -> "No source specified" Just s -> showSource s where showSource :: PackageSource -> String showSource (Git url rev) = "Git " ++ url ++ showGitRev rev showSource (Http url) = url showSource (FileSource url) = "File " ++ url showGitRev (Just (Ref ref)) = "@" ++ ref showGitRev (Just (Tag tag)) = "@" ++ replaceVersionInTag pkg tag showGitRev (Just VersionAsTag) = "@v" ++ (showVersion $ version pkg) showGitRev Nothing = "" --- Replace the string `$version$` in a tag string by the current version. replaceVersionInTag :: Package -> String -> String replaceVersionInTag pkg = concat . intersperse (showVersion $ version pkg) . splitOn "$version$" --- Less than operator for versions. vlt :: Version -> Version -> Bool vlt (majorA, minorA, patchA, preA) (majorB, minorB, patchB, preB) = major || minor || patch || pre where major = majorA < majorB minor = majorA <= majorB && minorA < minorB patch = majorA <= majorB && minorA <= minorB && patchA < patchB pre = case preA of Nothing -> case preB of Nothing -> patch Just _ -> majorA <= majorB && minorA <= minorB && patchA <= patchB Just a -> case preB of Nothing -> False Just b -> a `ltPre` b ltPre :: String -> String -> Bool ltPre a b | isNumeric a && isNumeric b = (read a :: Int) < read b | isNumeric a = True | isNumeric b = False | otherwise = a `ltShortlex` b isNumeric :: String -> Bool isNumeric = all isDigit ltShortlex :: String -> String -> Bool ltShortlex a b = (length a == length b && a < b) || length a < length b test_shorterPrereleaseIsSmaller :: Prop test_shorterPrereleaseIsSmaller = always $ (0, 0, 0, Just "rc") `vlt` (0, 0, 0, Just "beta") test_numericIsSmallerLeft :: Prop test_numericIsSmallerLeft = always $ (0, 0, 0, Just "1234") `vlt` (0, 0, 0, Just "rc") test_numericIsSmallerRight :: Prop test_numericIsSmallerRight = always $ not $ (0, 0, 0, Just "rc") `vlt` (0, 0, 0, Just "1234") test_numbersAreComparedNumerically :: Prop test_numbersAreComparedNumerically = always $ (0, 0, 0, Just "0003") `vlt` (0, 0, 0, Just "123") --- Less than or equal operator for versions. vlte :: Version -> Version -> Bool vlte a b = a `vlt` b || a == b --- Greater than operator for versions. vgt :: Version -> Version -> Bool vgt (majorA, minorA, patchA, preA) (majorB, minorB, patchB, preB) = major || minor || patch || pre where major = majorA > majorB minor = majorA >= majorB && minorA > minorB patch = majorA >= majorB && minorA >= minorB && patchA > patchB pre = case preA of Nothing -> case preB of Nothing -> patch Just _ -> False Just a -> case preB of Nothing -> False Just b -> a > b --- Greater than or equal operator for versions. vgte :: Version -> Version -> Bool vgte a b = a `vgt` b || a == b --- Is the version a pre-release version? isPreRelease :: Version -> Bool isPreRelease (_, _, _, Nothing) = False isPreRelease (_, _, _, Just _) = True --- Gets the list of source directories of a package. --- It is either the field `sourceDirs` (if non-empty) or `["src"]`. sourceDirsOf :: Package -> [String] sourceDirsOf p = if null (sourceDirs p) then ["src"] else sourceDirs p --- Gets the package names of all dependencies of a package. dependencyNames :: Package -> [String] dependencyNames p = map (\(Dependency s _) -> s) $ dependencies p --- Renders a dependency as a string, including all version constraints. showDependency :: Dependency -> String showDependency (Dependency p vcs) = p ++ showVersionConstraints vcs --- Renders a compiler dependency as a string, including all version --- constraints. showCompilerDependency :: CompilerCompatibility -> String showCompilerDependency (CompilerCompatibility cc vcs) = cc ++ showVersionConstraints vcs --- Renders a list of version constraints in disjunctive normal form. showVersionConstraints :: [[VersionConstraint]] -> String showVersionConstraints = intercalate " || " . map (intercalate ", " . map showVersionConstraint) --- Renders a single version constraint as a string. showVersionConstraint :: VersionConstraint -> String showVersionConstraint (VLt v) = " < " ++ showVersion v showVersionConstraint (VLte v) = " <= " ++ showVersion v showVersionConstraint (VGt v) = " > " ++ showVersion v showVersionConstraint (VGte v) = " >= " ++ showVersion v showVersionConstraint (VExact v) = " = " ++ showVersion v showVersionConstraint (VMinCompatible v) = " ~" ++ showVersion v showVersionConstraint (VMajCompatible v) = " ^" ++ showVersion v --- Renders the id of a package as a string. Package name and version separated --- by a dash. packageId :: Package -> String packageId p = name p ++ "-" ++ showVersion (version p) --- Reads a package spec from a JSON string. readPackageSpec :: String -> Either String Package readPackageSpec s = case parseJSON s of Nothing -> Left "Invalid JSON" Just j -> case j of JObject kv -> packageSpecFromJObject kv _ -> Left "Expected a JSON object." --- Reads a package spec from the key-value-pairs of a JObject. packageSpecFromJObject :: [(String, JValue)] -> Either String Package packageSpecFromJObject kv = mandatoryString "name" kv $ \name -> mandatoryString "version" kv $ \versionS -> getStringOrStringList True "An author" "author" $ \author -> getStringOrStringList False "A maintainer" "maintainer" $ \maintainer -> mandatoryString "synopsis" kv $ \synopsis -> optionalString "description" kv $ \description -> getStringList "A category" "category" $ \categories -> optionalString "license" kv $ \license -> optionalString "licenseFile" kv $ \licenseFile -> optionalString "copyright" kv $ \copyright -> optionalString "homepage" kv $ \homepage -> optionalString "bugReports" kv $ \bugReports -> optionalString "repository" kv $ \repository -> optionalString "configModule" kv $ \configModule -> mustBeVersion versionS $ \version -> getDependencies $ \dependencies -> getSource $ \source -> getStringList "A source directory" "sourceDirs" $ \sourcedirs -> getStringList "An exported module" "exportedModules" $ \exportedModules -> getCompilerCompatibility $ \compilerCompatibility -> getExecutableSpec $ \executable -> getElemList (elemsFromJArray execSpecFromJValue) "executables" $ \executables -> getTestSuite $ \testsuite -> getDocumentationSpec $ \docspec -> Right Package { name = name , version = version , author = author , maintainer = maintainer , synopsis = synopsis , description = description , category = categories , license = license , licenseFile = licenseFile , copyright = copyright , homepage = homepage , bugReports = bugReports , repository = repository , dependencies = dependencies , compilerCompatibility = compilerCompatibility , source = source , sourceDirs = sourcedirs , exportedModules = exportedModules , configModule = configModule , executableSpec = executable ++ executables , testSuite = testsuite , documentation = docspec } where mustBeVersion :: String -> (Version -> Either String a) -> Either String a mustBeVersion s f = case readVersion s of Nothing -> Left $ "'" ++ s ++ "' is not a valid version specification." Just v -> f v getDependencies :: ([Dependency] -> Either String a) -> Either String a getDependencies f = case lookup "dependencies" kv of Nothing -> f [] Just (JObject ds) -> case dependenciesFromJObject ds of Left e -> Left e Right ds' -> f ds' Just (JString _) -> Left $ "Expected an object, got a string" ++ forKey Just (JArray _) -> Left $ "Expected an object, got an array" ++ forKey Just (JNumber _) -> Left $ "Expected an object, got a number" ++ forKey Just JTrue -> Left $ "Expected an object, got 'true'" ++ forKey Just JFalse -> Left $ "Expected an object, got 'false'" ++ forKey Just JNull -> Left $ "Expected an object, got 'null'" ++ forKey where forKey = " for key 'dependencies'" getCompilerCompatibility :: ([CompilerCompatibility] -> Either String a) -> Either String a getCompilerCompatibility f = case lookup "compilerCompatibility" kv of Nothing -> f [] Just (JObject ds) -> case compilerCompatibilityFromJObject ds of Left e -> Left e Right ds' -> f ds' Just (JString _) -> Left $ "Expected an object, got a string" ++ forKey Just (JArray _) -> Left $ "Expected an object, got an array" ++ forKey Just (JNumber _) -> Left $ "Expected an object, got a number" ++ forKey Just JTrue -> Left $ "Expected an object, got 'true'" ++ forKey Just JFalse -> Left $ "Expected an object, got 'false'" ++ forKey Just JNull -> Left $ "Expected an object, got 'null'" ++ forKey where forKey = " for key 'compilerCompatibility'" getSource :: (Maybe PackageSource -> Either String a) -> Either String a getSource f = case lookup "source" kv of Nothing -> f Nothing Just (JObject s) -> case sourceFromJObject s of Left e -> Left e Right s' -> f (Just s') Just (JString _) -> Left $ "Expected an object, got a string" ++ forKey Just (JArray _) -> Left $ "Expected an object, got an array" ++ forKey Just (JNumber _) -> Left $ "Expected an object, got a number" ++ forKey Just JTrue -> Left $ "Expected an object, got 'true'" ++ forKey Just JFalse -> Left $ "Expected an object, got 'false'" ++ forKey Just JNull -> Left $ "Expected an object, got 'null'" ++ forKey where forKey = " for key 'source'" getStringOrStringList :: Bool -> String -> String -> ([String] -> Either String a) -> Either String a getStringOrStringList mandatory keystr key f = case lookup key kv of Nothing -> if mandatory then Left $ "Mandatory field missing: '" ++ key ++ "'" else f [] Just (JArray a) -> case stringsFromJArray keystr a of Left e -> Left e Right e -> f e Just (JString s) -> f [s] Just (JObject _) -> Left $ expectedText ++ "an object" ++ forKey Just (JNumber _) -> Left $ expectedText ++ "a number" ++ forKey Just JTrue -> Left $ expectedText ++ "'true'" ++ forKey Just JFalse -> Left $ expectedText ++ "'false'" ++ forKey Just JNull -> Left $ expectedText ++ "'null'" ++ forKey where forKey = " for key '" ++ key ++ "'" expectedText = "Expected an array, got " getElemList elemsfromarray key f = case lookup key kv of Nothing -> f [] Just (JArray a) -> case elemsfromarray a of Left e -> Left e Right e -> f e Just (JObject _) -> Left $ expectedText ++ "an object" ++ forKey Just (JString _) -> Left $ expectedText ++ "a string" ++ forKey Just (JNumber _) -> Left $ expectedText ++ "a number" ++ forKey Just JTrue -> Left $ expectedText ++ "'true'" ++ forKey Just JFalse -> Left $ expectedText ++ "'false'" ++ forKey Just JNull -> Left $ expectedText ++ "'null'" ++ forKey where forKey = " for key '" ++ key ++ "'" expectedText = "Expected an array, got " getStringList keystr = getElemList (stringsFromJArray keystr) getExecutableSpec :: ([PackageExecutable] -> Either String a) -> Either String a getExecutableSpec f = case lookup "executable" kv of Nothing -> f [] Just (JObject s) -> case execSpecFromJObject s of Left e -> Left e Right s' -> f [s'] Just (JString _) -> Left $ "Expected an object, got a string" ++ forKey Just (JArray _) -> Left $ "Expected an object, got an array" ++ forKey Just (JNumber _) -> Left $ "Expected an object, got a number" ++ forKey Just JTrue -> Left $ "Expected an object, got 'true'" ++ forKey Just JFalse -> Left $ "Expected an object, got 'false'" ++ forKey Just JNull -> Left $ "Expected an object, got 'null'" ++ forKey where forKey = " for key 'executable'" getTestSuite :: (Maybe [PackageTest] -> Either String a) -> Either String a getTestSuite f = case lookup "testsuite" kv of Nothing -> f Nothing Just (JObject s) -> case testSuiteFromJObject s of Left e -> Left e Right s' -> f (Just [s']) Just (JArray a) -> case testSuiteFromJArray a of Left e -> Left e Right s' -> f (Just s') Just (JString _) -> Left $ "Expected an object, got a string" ++ forKey Just (JNumber _) -> Left $ "Expected an object, got a number" ++ forKey Just JTrue -> Left $ "Expected an object, got 'true'" ++ forKey Just JFalse -> Left $ "Expected an object, got 'false'" ++ forKey Just JNull -> Left $ "Expected an object, got 'null'" ++ forKey where forKey = " for key 'testsuite'" getDocumentationSpec :: (Maybe PackageDocumentation -> Either String a) -> Either String a getDocumentationSpec f = case lookup "documentation" kv of Nothing -> f Nothing Just (JObject s) -> case docuSpecFromJObject s of Left e -> Left e Right s' -> f (Just s') Just (JString _) -> Left $ "Expected an object, got a string" ++ forKey Just (JArray _) -> Left $ "Expected an object, got an array" ++ forKey Just (JNumber _) -> Left $ "Expected an object, got a number" ++ forKey Just JTrue -> Left $ "Expected an object, got 'true'" ++ forKey Just JFalse -> Left $ "Expected an object, got 'false'" ++ forKey Just JNull -> Left $ "Expected an object, got 'null'" ++ forKey where forKey = " for key 'documentation'" mandatoryString :: String -> [(String, JValue)] -> (String -> Either String a) -> Either String a mandatoryString k kv f = case lookup k kv of Nothing -> Left $ "Mandatory field missing: '" ++ k ++ "'" Just (JString s) -> f s Just (JObject _) -> Left $ "Expected a string, got an object" ++ forKey Just (JArray _) -> Left $ "Expected a string, got an array" ++ forKey Just (JNumber _) -> Left $ "Expected a string, got a number" ++ forKey Just JTrue -> Left $ "Expected a string, got 'true'" ++ forKey Just JFalse -> Left $ "Expected a string, got 'false'" ++ forKey Just JNull -> Left $ "Expected a string, got 'null'" ++ forKey where forKey = " for key '" ++ k ++ "'" optionalString :: String -> [(String, JValue)] -> (Maybe String -> Either String a) -> Either String a optionalString k kv f = case lookup k kv of Nothing -> f Nothing Just (JString s) -> f (Just s) Just (JObject _) -> Left $ "Expected a string, got an object" ++ forKey Just (JArray _) -> Left $ "Expected a string, got an array" ++ forKey Just (JNumber _) -> Left $ "Expected a string, got a number" ++ forKey Just JTrue -> Left $ "Expected a string, got 'true'" ++ forKey Just JFalse -> Left $ "Expected a string, got 'false'" ++ forKey Just JNull -> Left $ "Expected a string, got 'null'" ++ forKey where forKey = " for key '" ++ k ++ "'" test_specFromJObject_mandatoryFields :: Prop test_specFromJObject_mandatoryFields = is (packageSpecFromJObject obj) (\x -> isLeft x && isInfixOf "name" ((head . lefts) [x])) where obj = [("hello", JString "world")] test_specFromJObject_invalidVersion :: Prop test_specFromJObject_invalidVersion = is (packageSpecFromJObject obj) (\x -> isLeft x && isInfixOf "version" ((head . lefts) [x])) where obj = [ ("name", JString "mypackage"), ("author", JString "test") , ("synopsis", JString "great!"), ("version", JString "1.2.b")] test_specFromJObject_minimalSpec :: Prop test_specFromJObject_minimalSpec = is (packageSpecFromJObject obj) (\x -> isRight x && test x) where obj = [ ("name", JString "mypackage"), ("author", JString "me") , ("synopsis", JString "great!"), ("version", JString "1.2.3")] test x = author p == ["me"] && name p == "mypackage" where p = (head . rights) [x] --- Reads a list of elements (specified by the first argument) --- from a list of JValues. elemsFromJArray :: (JValue -> Either String a) -> [JValue] -> Either String [a] elemsFromJArray readelem a = let elems = map readelem a in if any isLeft elems then Left $ head $ lefts elems else Right $ rights elems --- Reads a list of strings from a list of JValues. stringsFromJArray :: String -> [JValue] -> Either String [String] stringsFromJArray ekind = elemsFromJArray extractString where extractString s = case s of JString s' -> Right s' _ -> Left $ ekind ++ " must be a string" --- Reads the dependency constraints of a package from the key-value-pairs of a --- JObject. dependenciesFromJObject :: [(String, JValue)] -> Either String [Dependency] dependenciesFromJObject kv = if any isLeft dependencies then Left $ intercalate "; " (lefts dependencies) else Right $ rights dependencies where dependencies = map buildDependency kv buildDependency (pkg, JString vc) = case readVersionConstraints vc of Nothing -> Left $ "Invalid constraint '" ++ vc ++ "' for package '" ++ pkg ++ "'" Just v -> Right $ Dependency pkg v buildDependency (_, JObject _) = wrongVersionConstraint buildDependency (_, JArray _) = wrongVersionConstraint buildDependency (_, JNumber _) = wrongVersionConstraint buildDependency (_, JTrue ) = wrongVersionConstraint buildDependency (_, JFalse ) = wrongVersionConstraint buildDependency (_, JNull ) = wrongVersionConstraint wrongVersionConstraint = Left "Version constraint must be a string" --- Reads the compiler compatibility constraints of a package from the --- key-value-pairs of a JObject. compilerCompatibilityFromJObject :: [(String, JValue)] -> Either String [CompilerCompatibility] compilerCompatibilityFromJObject kv = if any isLeft compilerCompats then Left $ intercalate "; " (lefts compilerCompats) else Right $ rights compilerCompats where compilerCompats = map buildCompilerCompat kv buildCompilerCompat (c, JString vc) = case readVersionConstraints vc of Nothing -> Left $ "Invalid constraint '" ++ vc ++ "' for compiler '" ++ c ++ "'" Just v -> Right $ CompilerCompatibility c v buildCompilerCompat (_, JObject _) = wrongVersionConstraint buildCompilerCompat (_, JArray _) = wrongVersionConstraint buildCompilerCompat (_, JNumber _) = wrongVersionConstraint buildCompilerCompat (_, JTrue ) = wrongVersionConstraint buildCompilerCompat (_, JFalse ) = wrongVersionConstraint buildCompilerCompat (_, JNull ) = wrongVersionConstraint wrongVersionConstraint = Left "Version constraint must be a string" --- Read source specification from the key-value-pairs of a JObject. sourceFromJObject :: [(String, JValue)] -> Either String PackageSource sourceFromJObject kv = case lookup "http" kv of Nothing -> case lookup "git" kv of Nothing -> Left $ "Only Git and HTTP supported" Just (JString url) -> case revisionFromJObject kv of Left err -> Left err Right rev -> Right $ Git url rev Just _ -> Left "Git expects url" Just (JString url) -> Right $ Http url Just _ -> Left "HTTP expects url" --- Read Git revision specification from the key-value-pairs of a JObject. revisionFromJObject :: [(String, JValue)] -> Either String (Maybe GitRevision) revisionFromJObject kv = case lookup "tag" kv of Nothing -> case lookup "ref" kv of Nothing -> Right Nothing Just (JString ref) -> Right $ Just $ Ref ref Just _ -> Left "Ref expects string" Just (JString tag) -> if tag == "$version" then Right $ Just $ VersionAsTag else Right $ Just $ Tag tag Just _ -> Left "Tag expects string" --- Reads an executable specification from a list of JValue (a testsuite object). execSpecFromJValue :: JValue -> Either String PackageExecutable execSpecFromJValue s = case s of JObject o -> execSpecFromJObject o _ -> Left "Array element must be a executable object" --- Reads executable specification from the key-value-pairs of a JObject. execSpecFromJObject :: [(String, JValue)] -> Either String PackageExecutable execSpecFromJObject kv = mandatoryString "name" kv $ \name -> optionalString "main" kv $ \main -> case lookup "options" kv of Nothing -> Right $ PackageExecutable name (maybe "Main" id main) [] Just (JObject o) -> case optionsFromObject o of Left e -> Left e Right os -> Right $ PackageExecutable name (maybe "Main" id main) os Just _ -> Left "Expected an object for 'executable>options'" where optionsFromObject o = let os = map (extractString . snd) o in if any isLeft os then Left $ head (lefts os) else Right (zip (map fst o) (map fromRight os)) extractString s = case s of JString s' -> Right s' _ -> Left $ "'executable>options': values must be strings" --- Reads the list of testsuites from a list of JValues (testsuite objects). testSuiteFromJArray :: [JValue] -> Either String [PackageTest] testSuiteFromJArray = elemsFromJArray extractTest where extractTest s = case s of JObject o -> testSuiteFromJObject o _ -> Left "Array element must be a testsuite object" --- Reads a test suite specification from the key-value-pairs of a JObject. testSuiteFromJObject :: [(String, JValue)] -> Either String PackageTest testSuiteFromJObject kv = mandatoryString "src-dir" kv $ \dir -> optionalString "options" kv $ \opts -> optionalString "script" kv $ \scriptval -> let script = maybe "" id scriptval in case getOptStringList (not (null script)) "module" kv of Left e -> Left e Right mods -> if null script && null mods then Left emptyError else if not (null script) && not (null mods) then Left doubleError else Right $ PackageTest dir mods (maybe "" id opts) script where emptyError = "'script' and 'modules' cannot be both empty in 'testsuite'" doubleError = "'script' and 'modules' cannot be both non-empty in 'testsuite'" --- Reads an (optional, if first argument = True) key with a string list value. getOptStringList :: Bool -> String -> [(String, JValue)] -> Either String [String] getOptStringList optional key kv = case lookup (key++"s") kv of Nothing -> if optional then Right [] else Left $ "'"++key++"s' is not provided in 'testsuite'" Just (JArray a) -> stringsFromJArray ("A "++key) a Just (JObject _) -> Left $ expectedText ++ "an object" ++ forKey Just (JString _) -> Left $ expectedText ++ "a string" ++ forKey Just (JNumber _) -> Left $ expectedText ++ "a number" ++ forKey Just JTrue -> Left $ expectedText ++ "'true'" ++ forKey Just JFalse -> Left $ expectedText ++ "'false'" ++ forKey Just JNull -> Left $ expectedText ++ "'null'" ++ forKey where forKey = " for key '" ++ key ++ "s'" expectedText = "Expected an array, got " --- Reads documentation specification from the key-value-pairs of a JObject. docuSpecFromJObject :: [(String, JValue)] -> Either String PackageDocumentation docuSpecFromJObject kv = mandatoryString "src-dir" kv $ \docdir -> mandatoryString "main" kv $ \docmain -> optionalString "command" kv $ \doccmd -> Right $ PackageDocumentation docdir docmain (maybe "" id doccmd) --- Reads a dependency constraint expression in disjunctive normal form into --- a list of lists of version constraints. The inner lists are conjunctions of --- version constraints, the outer list is a disjunction of conjunctions. readVersionConstraints :: String -> Maybe [[VersionConstraint]] readVersionConstraints s = parse pVersionConstraints (dropWhile isSpace s) test_readVersionConstraints_single :: Prop test_readVersionConstraints_single = readVersionConstraints "=1.2.3" -=- Just [[VExact (1, 2, 3, Nothing)]] test_readVersionConstraints_multi :: Prop test_readVersionConstraints_multi = readVersionConstraints "> 1.0.0, < 2.3.0" -=- Just [[VGt (1, 0, 0, Nothing), VLt (2, 3, 0, Nothing)]] test_readVersionConstraints_disjunction :: Prop test_readVersionConstraints_disjunction = readVersionConstraints ">= 4.0.0 || < 3.0.0, > 2.0.0" -=- Just [[VGte (4, 0, 0, Nothing)], [VLt (3, 0, 0, Nothing), VGt (2, 0, 0, Nothing)]] pVersionConstraints :: Parser [[VersionConstraint]] pVersionConstraints = (:) <$> pConjunction <*> (pWhitespace *> char '|' *> char '|' *> pWhitespace *> pVersionConstraints <|> yield []) pConjunction :: Parser [VersionConstraint] pConjunction = (:) <$> pVersionConstraint <*> (pWhitespace *> char ',' *> pWhitespace *> pConjunction <|> yield []) --- Parses a version constraint. readVersionConstraint :: String -> Maybe VersionConstraint readVersionConstraint s = parse pVersionConstraint s test_readVersionConstraint_exact :: Prop test_readVersionConstraint_exact = readVersionConstraint "=1.2.3" -=- (Just $ VExact (1, 2, 3, Nothing)) test_readVersionConstraint_without :: Prop test_readVersionConstraint_without = readVersionConstraint "1.2.3" -=- (Just $ VExact (1, 2, 3, Nothing)) test_readVersionConstraint_invalidVersion :: Prop test_readVersionConstraint_invalidVersion = readVersionConstraint "=4.a.3" -=- Nothing test_readVersionConstraint_invalidConstraint :: Prop test_readVersionConstraint_invalidConstraint = readVersionConstraint "x1.2.3" -=- Nothing test_readVersionConstraint_greaterThan :: Prop test_readVersionConstraint_greaterThan = readVersionConstraint "> 1.2.3" -=- (Just $ VGt (1, 2, 3, Nothing)) test_readVersionConstraint_greaterThanEqual :: Prop test_readVersionConstraint_greaterThanEqual = readVersionConstraint ">= 1.2.3" -=- (Just $ VGte (1, 2, 3, Nothing)) test_readVersionConstraint_lessThan :: Prop test_readVersionConstraint_lessThan = readVersionConstraint "<1.2.3" -=- (Just $ VLt (1, 2, 3, Nothing)) test_readVersionConstraint_lessThanEqual :: Prop test_readVersionConstraint_lessThanEqual = readVersionConstraint "<= 1.2.3" -=- (Just $ VLte (1, 2, 3, Nothing)) test_readVersionConstraint_mincompatible :: Prop test_readVersionConstraint_mincompatible = readVersionConstraint "~1.2.3" -=- (Just $ VMinCompatible (1, 2, 3, Nothing)) test_readVersionConstraint_majcompatible :: Prop test_readVersionConstraint_majcompatible = readVersionConstraint "^1.2.3" -=- (Just $ VMajCompatible (1, 2, 3, Nothing)) pVersionConstraint :: Parser VersionConstraint pVersionConstraint = pConstraint <*> (pWhitespace *> pVersion) pConstraint :: Parser (Version -> VersionConstraint) pConstraint = char '=' *> yield VExact <|> char '>' *> char '=' *> yield VGte <|> char '>' *> yield VGt <|> char '<' *> char '=' *> yield VLte <|> char '<' *> yield VLt <|> char '~' *> yield VMinCompatible <|> char '~' *> char '>' *> yield VMinCompatible -- backward comp. <|> char '^' *> yield VMajCompatible <|> yield VExact pWhitespace :: Parser () pWhitespace = some (char ' ') *> yield () <|> empty --- Shows a version in dotted notation. showVersion :: Version -> String showVersion (maj, min, pat, pre) = majMinPat ++ preRelease where majMinPat = intercalate "." $ map show [maj, min, pat] preRelease = case pre of Just specifier -> "-" ++ specifier Nothing -> "" --- Tries to parse a version string. tryReadVersion :: String -> ErrorLogger Version tryReadVersion s = case readVersion s of Just v -> return v Nothing -> fail $ s ++ " is not a valid version" --- Tries to parse a version string. readVersion :: String -> Maybe Version readVersion s = parse pVersion s pVersion :: Parser Version pVersion = pPureVersion <|> (\(maj, min, pat, _) pre -> (maj, min, pat, Just pre)) <$> pPureVersion <*> (char '-' *> pPreRelease) pPureVersion :: Parser Version pPureVersion = (\maj (min, pat) -> (maj, min, pat, Nothing)) <$> (pNum <* char '.') <*> ((\min pat -> (min, pat)) <$> pNum <* char '.' <*> pNum) pPreRelease :: Parser String pPreRelease = some (check isAscii anyChar) pNum :: Parser Int pNum = (\cs -> foldl1 ((+).(10*)) (map (\c' -> ord c' - ord '0') cs)) <$> some pDigit pDigit :: Parser Char pDigit = check isDigit anyChar curry-tools-v3.3.0/cpm/src/CPM/Package/000077500000000000000000000000001377556325500175475ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/src/CPM/Package/Helpers.curry000066400000000000000000000313041377556325500222400ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This module contains some operations for processing packages, --- like installing package sources, cleaning packages, --- rendering package infos. -------------------------------------------------------------------------------- module CPM.Package.Helpers ( installPackageSourceTo , renderPackageInfo , cleanPackage , getLocalPackageSpec ) where import System.Directory import System.FilePath import System.Process ( getPID ) import Data.List ( isSuffixOf, splitOn, nub ) import Control.Monad import Prelude hiding ( empty ) import System.CurryPath ( addCurrySubdir ) import Text.Pretty hiding ( () ) import CPM.Config ( Config, homePackageDir ) import CPM.ErrorLogger import CPM.FileUtil ( cleanTempDir, inDirectory, inTempDir, quote , removeDirectoryComplete, tempDir, whenFileExists ) import CPM.Helpers ( strip ) import CPM.Package ------------------------------------------------------------------------------ --- Installs the source of the package from the given source location --- into the subdirectory `packageId pkg` of the given directory. installPackageSourceTo :: Package -> PackageSource -> String -> ErrorLogger () --- --- @param pkg - the package specification of the package --- @param source - the source of the package --- @param installdir - the directory where the package subdirectory should be --- installed installPackageSourceTo pkg (Git url rev) installdir = do let pkgDir = installdir pkgid c <- inDirectoryEL installdir $ execQuietCmd cloneCommand if c == 0 then case rev of Nothing -> checkoutGitRef pkgDir "HEAD" Just (Tag tag) -> checkoutGitRef pkgDir (replaceVersionInTag pkg tag) Just (Ref ref) -> checkoutGitRef pkgDir ref Just VersionAsTag -> let tag = "v" ++ (showVersion $ version pkg) in do checkoutGitRef pkgDir tag logInfo $ "Package '" ++ packageId pkg ++ "' installed" else liftIOEL (removeDirectoryComplete pkgDir) >> fail ("Failed to clone repository from '" ++ url ++ "', return code " ++ show c) where pkgid = packageId pkg cloneCommand q = unwords ["git clone", q, quote url, quote $ pkgid] installPackageSourceTo pkg (FileSource zipfile) installdir = installPkgFromFile pkg zipfile (installdir packageId pkg) False installPackageSourceTo pkg (Http url) installdir = do pid <- liftIOEL $ getPID let pkgDir = installdir packageId pkg basepf = "package" ++ show pid pkgfile = if takeExtension url == ".zip" then basepf ++ ".zip" else if ".tar.gz" `isSuffixOf` url then basepf ++ ".tar.gz" else "" if null pkgfile then fail $ "Illegal URL (only .zip or .tar.gz allowed):\n" ++ url else do tmpdir <- liftIOEL tempDir let tmppkgfile = tmpdir pkgfile ll <- getLogLevel c <- inTempDirEL $ showExecCmd $ "curl -f -s " ++ (if ll == Debug then "-S" else "") ++ " -o " ++ tmppkgfile ++ " " ++ quote url if c == 0 then installPkgFromFile pkg tmppkgfile pkgDir True else do liftIOEL cleanTempDir fail $ "`curl` failed with exit status " ++ show c --- Installs a package from a .zip or .tar.gz file into the specified --- package directory. If the last argument is true, the file will be --- deleted after unpacking. installPkgFromFile :: Package -> String -> String -> Bool -> ErrorLogger () installPkgFromFile pkg pkgfile pkgDir rmfile = do let iszip = takeExtension pkgfile == ".zip" absfile <- liftIOEL $ getAbsolutePath pkgfile liftIOEL $ createDirectory pkgDir c <- if iszip then inTempDirEL $ showExecCmd $ "unzip -qq -d " ++ quote pkgDir ++ " " ++ quote absfile else inDirectoryEL pkgDir $ showExecCmd $ "tar -xzf " ++ quote absfile when rmfile (showExecCmd ("rm -f " ++ absfile) >> return ()) liftIOEL cleanTempDir if c == 0 then logInfo $ "Installed " ++ packageId pkg else do liftIOEL $ removeDirectoryComplete pkgDir fail ("Failed to unzip package, return code " ++ show c) --- Checks out a specific ref of a Git repository and deletes --- the Git auxiliary files (i.e., `.git` and `.gitignore`). --- --- @param dir - the directory containing the repo --- @param ref - the ref to check out checkoutGitRef :: String -> String -> ErrorLogger () checkoutGitRef dir ref = do c <- inDirectoryEL dir $ execQuietCmd (\q -> unwords ["git checkout", q, ref]) if c == 0 then liftIOEL removeGitFiles >> return () else liftIOEL (removeDirectoryComplete dir) >> fail ("Failed to check out " ++ ref ++ ", return code " ++ show c) where removeGitFiles = do removeDirectoryComplete (dir ".git") let gitignore = dir ".gitignore" whenFileExists gitignore (removeFile gitignore) ------------------------------------------------------------------------------ --- Cleans auxiliary files in the local package, i.e., the package --- containing the current working directory. cleanPackage :: Config -> LogLevel -> ErrorLogger () cleanPackage cfg ll = do specDir <- getLocalPackageSpec cfg "." pkg <- loadPackageSpec specDir let dotcpm = specDir ".cpm" srcdirs = map (specDir ) (sourceDirsOf pkg) testdirs = map (specDir ) (maybe [] (map (\ (PackageTest m _ _ _) -> m)) (testSuite pkg)) rmdirs = nub (dotcpm : map addCurrySubdir (srcdirs ++ testdirs)) logAt ll $ "Removing directories: " ++ unwords rmdirs showExecCmd (unwords $ ["rm", "-rf"] ++ rmdirs) return () ------------------------------------------------------------------------------ --- Renders information about a package. renderPackageInfo :: Bool -> Bool -> Bool -> Package -> String renderPackageInfo allinfos plain installed pkg = pPrint doc where boldText s = (if plain then id else bold) $ text s maxLen = 12 doc = vcat $ [ heading, rule , if allinfos then instTxt installed else empty , ver, auth, maintnr, synop , cats, deps, compilers, descr ] ++ execspecs ++ if allinfos then [ srcdirs, expmods, cfgmod ] ++ testsuites ++ [ docuspec, src, licns, licfl, copyrt, homepg , reposy, bugrep ] else [] pkgId = packageId pkg heading = text pkgId instTxt i = if i || plain then empty else red $ text "Not installed" rule = text (take (length pkgId) $ repeat '-') ver = fill maxLen (boldText "Version") <+> (text $ showVersion $ version pkg) auth = fill maxLen (boldText "Author") <+> indent 0 (fillSep (map (text . strip) (concatMap (splitOn ",") $ author pkg))) synop = fill maxLen (boldText "Synopsis") <+> indent 0 (fillSep (map text (words (synopsis pkg)))) deps = boldText "Dependencies" <$$> (vcat $ map (indent 4 . text . showDependency) $ dependencies pkg) maintnr = case maintainer pkg of [] -> empty xs -> fill maxLen (boldText "Maintainer") <+> indent 0 (fillSep (map (text . strip) (concatMap (splitOn ",") xs))) cats = if null (category pkg) then empty else fill maxLen (boldText "Category") <+> indent 0 (fillSep (map text (category pkg))) execspecs = map showExec (executableSpec pkg) where showExec (PackageExecutable n m eopts) = if allinfos then boldText "Executable" <$$> indent 4 (boldText "Name " <+> text n) <$$> indent 4 (boldText "Main module " <+> text m) <$$> if null eopts then empty else indent 4 (boldText "Options ") <+> align (vsep (map (\ (c,o) -> text $ c ++ ": " ++ o) eopts)) else fill maxLen (boldText "Executable") <+> text n testsuites = case testSuite pkg of Nothing -> [] Just tests -> map (\ (PackageTest dir mods opts script) -> let check = if null script then "Check" else "Test" in boldText "Test suite" <$$> indent 4 (boldText "Directory " <+> text dir) <$$> (if null script then empty else indent 4 (boldText "Test script " <+> text script)) <$$> (if null opts then empty else indent 4 (boldText (check++" options") <+> text opts)) <$$> (if null mods then empty else indent 4 (boldText "Test modules " <+> align (fillSep (map text mods))))) tests docuspec = case documentation pkg of Nothing -> empty Just (PackageDocumentation docdir docmain doccmd) -> boldText "Documentation" <$$> indent 4 (boldText "Directory " <+> text docdir) <$$> indent 4 (boldText "Main file " <+> text docmain) <$$> if null doccmd then empty else indent 4 (boldText "Command ") <+> text doccmd descr = showParaField description "Description" licns = showLineField license "License" licfl = showLineField licenseFile "License file" copyrt = showParaField copyright "Copyright" homepg = showLineField homepage "Homepage" reposy = showLineField repository "Repository" bugrep = showLineField bugReports "Bug reports" cfgmod = showLineField configModule "Config module" src = maybe empty (\_ -> boldText "Source" <$$> indent 4 (text $ showSourceOfPackage pkg)) (source pkg) srcdirs = if null (sourceDirs pkg) then empty else boldText "Source directories" <$$> indent 4 (fillSep (map text (sourceDirs pkg))) expmods = if null (exportedModules pkg) then empty else boldText "Exported modules" <$$> indent 4 (fillSep (map text (exportedModules pkg))) compilers = if null (compilerCompatibility pkg) then empty else boldText "Compiler compatibility" <$$> (vcat $ map (indent 4 . text . showCompilerDependency) $ compilerCompatibility pkg) showLineField fgetter fname = case fgetter pkg of Nothing -> empty Just s -> boldText fname <$$> indent 4 (text s) showParaField fgetter fname = case fgetter pkg of Nothing -> empty Just s -> boldText fname <$$> indent 4 (fillSep (map text (words s))) ------------------------------------------------------------------------------ --- Tries to find a package specification in the given directory or one of its --- ancestors. If there is no package specifiction in these directories, --- the home package specification (i.e., `~/.cpm/home-package/package.json` --- is returned (and created if it does not exist). --- In order to avoid infinite loops due to cyclic file structures, --- the search is limited to the number of directories occurring in the --- current absolute path. getLocalPackageSpec :: Config -> String -> ErrorLogger String getLocalPackageSpec cfg dir = do adir <- liftIOEL $ getAbsolutePath dir spec <- searchLocalSpec (length (splitPath adir)) dir maybe returnHomePackage return spec where returnHomePackage = do let homepkgdir = homePackageDir cfg homepkgspec = homepkgdir "package.json" specexists <- liftIOEL $ doesFileExist homepkgspec unless (specexists || null homepkgdir) $ do liftIOEL $ createDirectoryIfMissing True homepkgdir let newpkg = emptyPackage { name = snd (splitFileName homepkgdir) , version = initialVersion , author = ["CPM"] , synopsis = "Default home package" , dependencies = [] } liftIOEL $ writePackageSpec newpkg homepkgspec logInfo $ "New empty package specification '" ++ homepkgspec ++ "' generated" return homepkgdir searchLocalSpec m sdir = do existsLocal <- liftIOEL $ doesFileExist $ sdir "package.json" if existsLocal then return (Just sdir) else do logDebug ("No package.json in " ++ show sdir ++ ", trying " ++ show (sdir "..")) parentExists <- liftIOEL $ doesDirectoryExist $ sdir ".." if m>0 && parentExists then searchLocalSpec (m-1) $ sdir ".." else return Nothing ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/src/CPM/PackageCache/000077500000000000000000000000001377556325500204735ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/src/CPM/PackageCache/Global.curry000066400000000000000000000260531377556325500227670ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This module contains functions for accessing and modifying the global --- package cache. -------------------------------------------------------------------------------- module CPM.PackageCache.Global ( GlobalCache , findAllVersions , findNewestVersion , findVersion , packageInstalled , installedPackageDir , readGlobalCache, readInstalledPackagesFromDir , allPackages , copyPackage , installMissingDependencies , acquireAndInstallPackage , acquireAndInstallPackageFromSource , tryFindPackage , missingPackages , installFromZip , checkoutPackage , uninstallPackage , emptyCache ) where import Control.Applicative (when) import Data.Either import Data.List import Data.Maybe (isJust) import System.FilePath import System.Directory import System.IOExts ( readCompleteFile ) import CPM.Config ( Config, packageInstallDir, packageTarFilesURLs ) import CPM.ErrorLogger import CPM.FileUtil ( cleanTempDir, copyDirectory, recreateDirectory , recreateDirectory, inDirectory , removeDirectoryComplete , tempDir, whenFileExists , checkAndGetVisibleDirectoryContents, quote ) import CPM.Package import CPM.Package.Helpers ( installPackageSourceTo ) import CPM.Repository ------------------------------------------------------------------------------ --- The data type representing the global package cache. data GlobalCache = GlobalCache [Package] --- An empty package cache. emptyCache :: GlobalCache emptyCache = GlobalCache [] --- Gets all package specifications from a cache. allPackages :: GlobalCache -> [Package] allPackages (GlobalCache ps) = ps ------------------------------------------------------------------------------ --- Finds all versions of a package in the global package cache. --- --- @param gc - the global package cache --- @param p - the name of the package --- @param pre - include pre-release versions findAllVersions :: GlobalCache -> String -> Bool -> [Package] findAllVersions (GlobalCache ps) p pre = sortBy pkgGt $ filter filterPre $ filter ((== p) . name) ps where filterPre p' = pre || (not . isPreRelease . version) p' --- Compares two packages by their versions. pkgGt :: Package -> Package -> Bool pkgGt a b = version a `vgt` version b --- Finds the newest version of a package. findNewestVersion :: GlobalCache -> String -> Maybe Package findNewestVersion db p = if length pkgs > 0 then Just $ head pkgs else Nothing where pkgs = sortBy pkgGt $ findAllVersions db p False --- Finds a specific version of a package. findVersion :: GlobalCache -> String -> Version -> Maybe Package findVersion (GlobalCache ps) p v = if null hits then Nothing else Just $ head hits where hits = filter ((== v) . version) $ filter ((== p) . name) ps --- Checks whether a package is installed. isPackageInstalled :: GlobalCache -> Package -> Bool isPackageInstalled db p = isJust $ findVersion db (name p) (version p) --- The directory of a package in the global package cache. Does not check --- whether the package is actually installed! installedPackageDir :: Config -> Package -> String installedPackageDir cfg pkg = packageInstallDir cfg packageId pkg --- Checks whether a package is installed in the global cache. packageInstalled :: Config -> Package -> IO Bool packageInstalled cfg pkg = doesDirectoryExist (installedPackageDir cfg pkg) --- Copy a package version to a directory. copyPackage :: Config -> Package -> String -> ErrorLogger () copyPackage cfg pkg dir = do exists <- liftIOEL $ doesDirectoryExist srcDir if not exists then fail $ "Package '" ++ packageId pkg ++ "' not installed" else liftIOEL (copyDirectory srcDir dir) >> return () where srcDir = installedPackageDir cfg pkg --- Acquires a package, either from the global tar file repository --- or from the source specified in its specification, and --- installs it to the global package cache. acquireAndInstallPackage :: Config -> Package -> ErrorLogger () acquireAndInstallPackage cfg pkg = do pkgDirExists <- liftIOEL $ doesDirectoryExist (installedPackageDir cfg pkg) if pkgDirExists then logInfo $ "Package '" ++ packageId pkg ++ "' already installed, skipping" else tryInstallFromURLs (packageTarFilesURLs cfg) where tryInstallFromURLs [] = fail "No URLs for installations" tryInstallFromURLs (url:urls) = do let stdurl = url ++ "/" ++ packageId pkg ++ ".tar.gz" logInfo $ "Installing package from " ++ stdurl err <- tryEL $ installPackageSourceTo pkg (Http stdurl) (packageInstallDir cfg) case err of Left _ -> if null urls then fail downloadError else tryInstallFromURLs urls Right _ -> acquireAndInstallPackageFromSource cfg pkg downloadError = "Package downloading failed. Use option '-v debug' for more infos." --- Acquires a package from the source specified in its specification and --- installs it to the global package cache. acquireAndInstallPackageFromSource :: Config -> Package -> ErrorLogger () acquireAndInstallPackageFromSource cfg reppkg = readPackageFromRepository cfg reppkg >>= \pkg -> case source pkg of Nothing -> fail $ "No source specified for " ++ packageId pkg Just s -> logInfo ("Installing package '" ++ packageId pkg ++ "'...") >> installFromSource cfg pkg s ------------------------------------------------------------------------------ --- Installs a package from the given package source to the global package --- cache. installFromSource :: Config -> Package -> PackageSource -> ErrorLogger () installFromSource cfg pkg pkgsource = do pkgDirExists <- liftIOEL $ doesDirectoryExist pkgDir if pkgDirExists then logInfo $ "Package '" ++ packageId pkg ++ "' already installed, skipping" else logInfo ("Installing package from " ++ showSourceOfPackage pkg) >> installPackageSourceTo pkg pkgsource (packageInstallDir cfg) where pkgDir = installedPackageDir cfg pkg --- Installs a package from a ZIP file to the global package cache. installFromZip :: Config -> String -> ErrorLogger () installFromZip cfg zip = do t <- liftIOEL tempDir liftIOEL $ recreateDirectory (t "installtmp") absZip <- liftIOEL $ getAbsolutePath zip c <- inTempDirEL $ showExecCmd $ "unzip -qq -d installtmp " ++ quote absZip if c == 0 then do pkgSpec <- loadPackageSpec (t "installtmp") logDebug ("ZIP contains " ++ packageId pkgSpec) liftIOEL cleanTempDir installFromSource cfg pkgSpec (FileSource zip) else do liftIOEL cleanTempDir fail "failed to extract ZIP file" --- Installs a package's missing dependencies. installMissingDependencies :: Config -> GlobalCache -> [Package] -> ErrorLogger () installMissingDependencies cfg gc deps = when (length missing > 0) $ do logInfo logmsg mapM_ (acquireAndInstallPackage cfg) missing where missing = filter (not . isPackageInstalled gc) deps logmsg = "Installing missing dependencies " ++ intercalate "," (map packageId missing) --- Filters a list of packages to the ones not installed in the global package --- cache. missingPackages :: GlobalCache -> [Package] -> [Package] missingPackages gc = filter (not . isPackageInstalled gc) --- Checkout a package from the global package cache. checkoutPackage :: Config -> Package -> ErrorLogger () checkoutPackage cfg pkg = do sexists <- liftIOEL $ doesDirectoryExist pkgDir texists <- liftIOEL $ doesDirectoryExist codir if texists then logError $ "Local package directory '" ++ codir ++ "' already exists." else if sexists then do liftIOEL $ copyDirectory pkgDir codir logInfo logmsg else logError $ "Package '" ++ pkgId ++ "' is not installed." where pkgId = packageId pkg pkgDir = installedPackageDir cfg pkg codir = name pkg logmsg = "Package '" ++ pkgId ++ "' checked out into directory '" ++ codir ++ "'." --- Removes a package from the global package cache. uninstallPackage :: Config -> String -> Version -> ErrorLogger () uninstallPackage cfg pkgname ver = do let pkgId = pkgname ++ "-" ++ showVersion ver pkgDir = packageInstallDir cfg pkgId exists <- liftIOEL $ doesDirectoryExist pkgDir if exists then do showExecCmd ("rm -Rf " ++ quote pkgDir) logInfo $ "Package '" ++ pkgId ++ "' uninstalled." else logInfo $ "Package '" ++ pkgId ++ "' is not installed." --- Tries to find a package in the global package cache. tryFindPackage :: GlobalCache -> String -> Version -> ErrorLogger Package tryFindPackage gc name ver = case findVersion gc name ver of Just pkg -> return pkg Nothing -> fail $ "Package " ++ name ++ "-" ++ showVersion ver ++ " could not be found." --- Reads the global package cache. readGlobalCache :: Config -> Repository -> ErrorLogger GlobalCache readGlobalCache config repo = do maybeGC <- readInstalledPackagesFromDir repo $ packageInstallDir config case maybeGC of Left err -> fail $ "Error reading global package cache: " ++ err Right gc -> return gc --- Tries to read package specifications from a GC directory structure. --- If some GC package directory has the same name as a package from --- the repository index, the package specification from the repository --- is used, otherwise (this case should not occur) the package specification --- stored in the directory is read. --- This should result in faster GC loading. readInstalledPackagesFromDir :: Repository -> String -> ErrorLogger (Either String GlobalCache) readInstalledPackagesFromDir repo path = do logDebug $ "Reading global package cache from '" ++ path ++ "'..." pkgPaths <- liftIOEL $ checkAndGetVisibleDirectoryContents path specs <- mapM loadPackageSpecFromDir pkgPaths if null (lefts specs) then do logDebug "Finished reading global package cache" return (Right $ GlobalCache (rights specs)) else return (Left $ intercalate "; " (lefts specs)) where readPackageSpecIO = liftIOEL . fmap readPackageSpec loadPackageSpecFromDir pkgdir = case packageVersionFromFile pkgdir of Nothing -> readPackageSpecFromFile pkgdir Just (pn,pv) -> case CPM.Repository.findVersion repo pn pv of Nothing -> readPackageSpecFromFile pkgdir Just p -> return (Right p) readPackageSpecFromFile pkgdir = do let f = path pkgdir "package.json" logDebug $ "Reading package spec from '" ++ f ++ "'..." spec <- readPackageSpecIO $ readCompleteFile f return $ case spec of Left err -> Left $ err ++ " for file '" ++ f ++ "'" Right v -> Right v packageVersionFromFile :: String -> Maybe (String, Version) packageVersionFromFile fn = let ps = split (=='-') fn l = length ps in if l < 2 then Nothing else case readVersion (last ps) of Nothing -> Nothing Just v -> Just (intercalate "-" (take (l-1) ps), v) ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/src/CPM/PackageCache/Local.curry000066400000000000000000000161471377556325500226240ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This module implements the local package cache. The local package cache is --- located in the .cpm/package_cache of the current package. It contains --- symlinks to all dependencies used by the current package. Package files are --- copied from the local cache to the runtime cache when they need to be used. --- The package manager usually creates symlinks to the global package cache. --- Symlinks to other locations can be used to include modified versions of --- packages that are not yet published to the package repository or installed --- in the global cache. -------------------------------------------------------------------------------- module CPM.PackageCache.Local ( cacheDir , createLinkToGlobalCache , linkPackages , clearCache , createLink , doesLinkPointToGlobalCache , packageDir , isPackageInCache , allPackages ) where import Debug.Trace import System.Directory ( createDirectoryIfMissing, copyFile, getAbsolutePath , getDirectoryContents, doesDirectoryExist , doesFileExist ) import System.FilePath ( () ) import Data.Either ( rights ) import Data.List ( isPrefixOf ) import Control.Monad import System.IOExts ( readCompleteFile ) import CPM.Config ( Config, packageInstallDir ) import CPM.ErrorLogger import CPM.FileUtil ( isSymlink, removeSymlink, createSymlink, linkTarget ) import CPM.Package ( Package, packageId, readPackageSpec ) import CPM.PackageCache.Global ( installedPackageDir ) --- The cache directory of the local package cache. --- --- @param dir the package directory cacheDir :: String -> String cacheDir pkgDir = pkgDir ".cpm" "package_cache" --- Reads all packages specifications from the local package cache. --- --- @param dir the package directory allPackages :: String -> ErrorLogger [Package] allPackages pkgDir = do cacheExists <- liftIOEL $ doesDirectoryExist cdir if cacheExists then do logDebug $ "Reading local package cache from '" ++ cdir ++ "'..." cdircont <- liftIOEL $ getDirectoryContents cdir let pkgDirs = filter (not . isPrefixOf ".") cdircont pkgPaths <- liftIOEL $ mapM removeIfIllegalSymLink $ map (cdir ) pkgDirs let specPaths = map ( "package.json") $ concat pkgPaths specs <- liftIOEL $ mapM (readPackageSpecIO . readCompleteFile) specPaths return $ rights specs else return [] where readPackageSpecIO = fmap readPackageSpec cdir = cacheDir pkgDir removeIfIllegalSymLink target = do dirExists <- doesDirectoryExist target fileExists <- doesFileExist target isLink <- isSymlink target if isLink && (dirExists || fileExists) then return [target] else when isLink (removeSymlink target >> return ()) >> return [] --- Creates a link to a package from the global cache in the local cache. Does --- not overwrite existing links. --- --- @param cfg the current configuration --- @param dir the package directory --- @param gc the global package cache --- @param pkg the package to copy createLinkToGlobalCache :: Config -> String -> Package -> ErrorLogger () createLinkToGlobalCache cfg pkgDir pkg = createLink pkgDir (installedPackageDir cfg pkg) (packageId pkg) False --- Links a list of packages from the global cache into the local cache. Does --- not overwrite existing links. --- --- @param cfg the current configuration --- @param dir the package directory --- @param gc the global package cache --- @param pkgs the list of packages linkPackages :: Config -> String -> [Package] -> ErrorLogger () linkPackages cfg pkgDir pkgs = mapM (createLinkToGlobalCache cfg pkgDir) pkgs >> return () --- Tests whether a link in the local package cache points to a package in the --- global package cache. --- --- @param cfg the current configuration --- @param gc the global package cache --- @param dir the package directory --- @param name the name of the link doesLinkPointToGlobalCache :: Config -> String -> String -> IO Bool doesLinkPointToGlobalCache cfg pkgDir name = do target <- linkTarget link return $ isPrefixOf (packageInstallDir cfg) target where link = (cacheDir pkgDir) name --- Calculates the local package path of the given package --- --- @param dir the package directory --- @param pkg the package packageDir :: String -> Package -> String packageDir pkgDir pkg = (cacheDir pkgDir) (packageId pkg) --- Checks whether a package is in the local cache. --- --- @param dir the package directory --- @param pkg the package isPackageInCache :: String -> Package -> IO Bool isPackageInCache pkgDir pkg = do dirExists <- doesDirectoryExist packageDir' fileExists <- doesFileExist packageDir' return $ dirExists || fileExists where packageDir' = packageDir pkgDir pkg --- Clear the local package cache. --- --- @param dir the package directory clearCache :: String -> ErrorLogger () clearCache pkgDir = do cacheExists <- liftIOEL $ doesDirectoryExist cdir if cacheExists then do pkgDirs <- liftIOEL $ getDirectoryContents cdir mapM deleteIfLink (map (cdir ) $ filter (not . isDotOrDotDot) pkgDirs) return () else return () where cdir = cacheDir pkgDir ensureCacheDir :: String -> IO String ensureCacheDir pkgDir = do createDirectoryIfMissing True (cacheDir pkgDir) return (cacheDir pkgDir) deleteIfLink :: String -> ErrorLogger () deleteIfLink target = do dirExists <- liftIOEL $ doesDirectoryExist target fileExists <- liftIOEL $ doesFileExist target isLink <- liftIOEL $ isSymlink target if dirExists || fileExists then if isLink then liftIOEL (removeSymlink target) >> return () else fail $ "deleteIfLink can only delete links!\n" ++ "Unexpected target: " ++ target else if isLink -- maybe it is a link to some non-existing target then liftIOEL (removeSymlink target) >> return () else return () linkExists :: String -> IO Bool linkExists target = do dirExists <- doesDirectoryExist target fileExists <- doesFileExist target if dirExists || fileExists then isSymlink target else return False isDotOrDotDot :: String -> Bool isDotOrDotDot s = case s of "." -> True ".." -> True _ -> False --- Create a link from a directory into the local package cache. --- --- @param pkgDir the package directory --- @param from the source directory to be linked into the local cache --- @param name the name of the link in the package directory (should be a --- package id) --- @param replace replace existing link? createLink :: String -> String -> String -> Bool -> ErrorLogger () createLink pkgDir from name replace = do liftIOEL $ ensureCacheDir pkgDir exists <- liftIOEL $ linkExists target if exists && not replace then return () else do deleteIfLink target fromabs <- liftIOEL $ getAbsolutePath from rc <- liftIOEL $ createSymlink fromabs target if rc == 0 then return () else fail $ "Failed to create symlink from '" ++ from ++ "' to '" ++ target ++ "', return code " ++ show rc where target = cacheDir pkgDir name curry-tools-v3.3.0/cpm/src/CPM/PackageCache/Runtime.curry000066400000000000000000000124471377556325500232140ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- Contains functions that access and modify the runtime package cache. -------------------------------------------------------------------------------- module CPM.PackageCache.Runtime ( dependencyPathsSeparate , dependencyPaths , copyPackages , cacheDirectory , writePackageConfig ) where import System.FilePath ( (), (<.>), takeDirectory ) import System.Directory ( createDirectoryIfMissing, copyFile, doesFileExist , getDirectoryContents, doesDirectoryExist , getAbsolutePath ) import Data.List ( intercalate, split ) import CPM.Config ( Config, binInstallDir ) import CPM.ErrorLogger import CPM.PackageCache.Global (installedPackageDir) import CPM.Package ( Package, packageId, PackageExecutable(..) , sourceDirsOf, executableSpec, version , configModule, showVersion ) import CPM.FileUtil ( copyDirectoryFollowingSymlinks, recreateDirectory ) import CPM.PackageCache.Local as LocalCache import CPM.Repository ( readPackageFromRepository ) -- Each package needs its own copy of all dependencies since KiCS2 and PACKS -- store their intermediate results for each source file in a hidden directory -- alongside that particular source file. This module manages these local -- copies. --- Returns a colon-separated list of the paths to a list of given packages --- inside a package's runtime package cache. dependencyPaths :: [Package] -> String -> String dependencyPaths pkgs dir = intercalate ":" $ dependencyPathsSeparate pkgs dir --- Returns a list of the paths to a list of given packages inside a package's --- runtime package cache. dependencyPathsSeparate :: [Package] -> String -> [String] dependencyPathsSeparate pkgs dir = concatMap (\p -> map (cacheDirectory dir p ) (sourceDirsOf p)) pkgs --- Returns the directory for a package inside another package's runtime cache. cacheDirectory :: String -> Package -> String cacheDirectory dir pkg = dir ".cpm" "packages" packageId pkg --- Copies a set of packages from the local package cache to the runtime --- package cache and returns the package specifications. copyPackages :: Config -> [Package] -> String -> ErrorLogger [Package] copyPackages cfg pkgs dir = mapM copyPackage pkgs where copyPackage pkg = do cdir <- ensureCacheDirectory dir let destDir = cdir packageId pkg liftIOEL $ recreateDirectory destDir pkgDirExists <- liftIOEL $ doesDirectoryExist pkgDir if pkgDirExists then do -- in order to obtain complete package specification: reppkg <- readPackageFromRepository cfg pkg liftIOEL $ copyDirectoryFollowingSymlinks pkgDir cdir writePackageConfig cfg destDir reppkg "" return reppkg else error $ "Package " ++ packageId pkg ++ " could not be found in package cache." where pkgDir = LocalCache.packageDir dir pkg --- Ensures that the runtime package cache directory exists. ensureCacheDirectory :: String -> ErrorLogger String ensureCacheDirectory dir = do let packagesDir = dir ".cpm" "packages" liftIOEL $ createDirectoryIfMissing True packagesDir return packagesDir --- Writes the package configuration module (if specified) into the --- the package sources. writePackageConfig :: Config -> String -> Package -> String -> ErrorLogger () writePackageConfig cfg pkgdir pkg loadpath = maybe (return ()) (\configmod -> let binnames = map (\ (PackageExecutable n _ _) -> n) (executableSpec pkg) in if null configmod then return () else do writeConfigFile configmod binnames return ()) (configModule pkg) where writeConfigFile configmod binnames = do let configfile = pkgdir "src" foldr1 () (split (=='.') configmod) <.> ".curry" liftIOEL $ do createDirectoryIfMissing True (takeDirectory configfile) abspkgdir <- getAbsolutePath pkgdir writeFile configfile $ unlines $ [ "module " ++ configmod ++ " where" , "" , "--- Package version as a string." , "packageVersion :: String" , "packageVersion = \"" ++ showVersion (version pkg) ++ "\"" , "" , "--- Package location." , "packagePath :: String" , "packagePath = " ++ show abspkgdir , "" , "--- Load path for the package (if it is the main package)." , "packageLoadPath :: String" , "packageLoadPath = " ++ show loadpath , "" ] ++ showExecutables binnames logDebug $ "Config module '" ++ configfile ++ "' written." showExecutables bins = case length bins of 0 -> [] 1 -> [ "--- Location of the executable installed by this package." , "packageExecutable :: String" , "packageExecutable = \"" ++ binInstallDir cfg head bins ++ "\"" ] _ -> [ "--- Location of the executables installed by this package." , "packageExecutables :: [String]" , "packageExecutables = [" ++ intercalate ", " (map (\s -> "\"" ++ binInstallDir cfg s ++ "\"") bins) ++ "]" ] curry-tools-v3.3.0/cpm/src/CPM/PackageCopy.curry000066400000000000000000000232061377556325500214730ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This module contains operations that operate on a package copy. -------------------------------------------------------------------------------- module CPM.PackageCopy ( resolveDependenciesForPackageCopy , resolveAndCopyDependencies, resolveAndCopyDependenciesForPackage , resolveDependencies , upgradeAllPackages , upgradeSinglePackage , linkToLocalCache , acquireAndInstallPackageWithDependencies , installLocalDependencies ) where import System.Directory ( doesDirectoryExist ) import Data.List ( intercalate ) import Data.Maybe ( mapMaybe ) import CPM.Config ( Config, compilerBaseVersion ) import CPM.Repository ( Repository, allPackages ) import CPM.Repository.Select import qualified CPM.LookupSet as LS import CPM.ErrorLogger import qualified CPM.PackageCache.Global as GC import qualified CPM.PackageCache.Runtime as RuntimeCache import qualified CPM.PackageCache.Local as LocalCache import CPM.Package import CPM.Resolution --- Resolves dependencies for a package copy. resolveDependenciesForPackageCopy :: Config -> Package -> Repository -> GC.GlobalCache -> String -> ErrorLogger ResolutionResult resolveDependenciesForPackageCopy cfg pkg repo gc dir = lookupSetForPackageCopy cfg pkg repo gc dir >>= \lookupSet -> resolveDependenciesFromLookupSet cfg (setBaseDependency cfg pkg) lookupSet --- Calculates the lookup set needed for dependency resolution on a package --- copy. lookupSetForPackageCopy :: Config -> Package -> Repository -> GC.GlobalCache -> String -> ErrorLogger LS.LookupSet lookupSetForPackageCopy cfg _ repo gc dir = do localPkgs <- LocalCache.allPackages dir diffInLC <- liftIOEL $ mapM filterGCLinked localPkgs let lsLC = addPackagesWOBase cfg lsGC localPkgs LS.FromLocalCache mapM logSymlinkedPackage (mapMaybe id diffInLC) return lsLC where allRepoPackages = allPackages repo logSymlinkedPackage p = logDebug $ "Using symlinked version of '" ++ packageId p ++ "' from local cache." lsRepo = addPackagesWOBase cfg LS.emptySet allRepoPackages LS.FromRepository -- Find all packages that are in the global cache, but not in the repo newInGC = filter (\p -> not $ any (packageIdEq p) allRepoPackages) (GC.allPackages gc) lsGC = addPackagesWOBase cfg lsRepo newInGC LS.FromGlobalCache filterGCLinked p = do points <- LocalCache.doesLinkPointToGlobalCache cfg dir (packageId p) return $ if points then Nothing else Just p --- Resolves dependencies for a package. resolveDependenciesForPackage :: Config -> Package -> Repository -> GC.GlobalCache -> ErrorLogger ResolutionResult resolveDependenciesForPackage cfg pkg repo gc = resolveDependenciesFromLookupSet cfg (setBaseDependency cfg pkg) lookupSet where lsRepo = addPackagesWOBase cfg LS.emptySet (allPackages repo) LS.FromRepository -- Find all packages that are in the global cache, but not in the repo newInGC = filter inGCButNotInRepo $ GC.allPackages gc inGCButNotInRepo p = not $ any (packageIdEq p) (allPackages repo) lookupSet = addPackagesWOBase cfg lsRepo newInGC LS.FromGlobalCache --- Acquires a package and its dependencies and installs them to the global --- package cache. acquireAndInstallPackageWithDependencies :: Config -> Repository -> Package -> ErrorLogger () acquireAndInstallPackageWithDependencies cfg repo pkg = do gc <- GC.readGlobalCache cfg repo result <- resolveDependenciesForPackage cfg pkg repo gc GC.installMissingDependencies cfg gc (resolvedPackages result) GC.acquireAndInstallPackage cfg pkg --- Links the dependencies of a package to its local cache and copies them to --- its runtime cache. Returns the package specifications of the dependencies. copyDependencies :: Config -> Package -> [Package] -> String -> ErrorLogger [Package] copyDependencies cfg pkg pkgs dir = do LocalCache.linkPackages cfg dir pkgs pkgspecs <- RuntimeCache.copyPackages cfg pkgs' dir return $ if pkg `elem` pkgs then pkg : pkgspecs else pkgspecs where pkgs' = filter (/= pkg) pkgs --- Upgrades all dependencies of a package copy. upgradeAllPackages :: Config -> String -> ErrorLogger () upgradeAllPackages cfg dir = do pkgspec <- loadPackageSpec dir LocalCache.clearCache dir (_,deps) <- installLocalDependencies cfg dir copyDependencies cfg pkgspec deps dir return () --- Upgrades a single package and its transitive dependencies. upgradeSinglePackage :: Config -> String -> String -> ErrorLogger () upgradeSinglePackage cfg dir pkgName = do pkgspec <- loadPackageSpec dir repo <- getRepoForPackageSpec cfg pkgspec gc <- GC.readGlobalCache cfg repo originalLS <- lookupSetForPackageCopy cfg pkgspec repo gc dir let transitiveDeps = pkgName : allTransitiveDependencies originalLS pkgName result <- resolveDependenciesFromLookupSet cfg (setBaseDependency cfg pkgspec) (LS.setLocallyIgnored originalLS transitiveDeps) GC.installMissingDependencies cfg gc (resolvedPackages result) logInfo (showDependencies result) copyDependencies cfg pkgspec (resolvedPackages result) dir return () --- Installs the dependencies of a package. installLocalDependencies :: Config -> String -> ErrorLogger (Package,[Package]) installLocalDependencies cfg dir = do pkgSpec <- loadPackageSpec dir repo <- getRepoForPackageSpec cfg pkgSpec installLocalDependenciesWithRepo cfg repo dir pkgSpec --- Installs the dependencies of a package. installLocalDependenciesWithRepo :: Config -> Repository -> String -> Package -> ErrorLogger (Package,[Package]) installLocalDependenciesWithRepo cfg repo dir pkgSpec = do gc <- GC.readGlobalCache cfg repo result <- resolveDependenciesForPackageCopy cfg pkgSpec repo gc dir GC.installMissingDependencies cfg gc (resolvedPackages result) logInfo (showDependencies result) cpkgs <- copyDependencies cfg pkgSpec (resolvedPackages result) dir return (pkgSpec, cpkgs) --- Links a directory into the local package cache. Used for `cypm link`. linkToLocalCache :: Config -> String -> String -> ErrorLogger () linkToLocalCache cfg src pkgDir = do dirExists <- liftIOEL $ doesDirectoryExist src if dirExists then do pkgSpec <- loadPackageSpec src mbp <- getPackageVersion cfg (name pkgSpec) (version pkgSpec) maybe (logCritical $ "Package '" ++ packageId pkgSpec ++ "' not in repository!\n" ++ "Note: you can only link copies of existing packages.") (\_ -> do LocalCache.createLink pkgDir src (packageId pkgSpec) True return ()) mbp else logCritical $ "Directory '" ++ src ++ "' does not exist." --- Resolves the dependencies for a package copy and fills the package caches. resolveAndCopyDependencies :: Config -> Repository -> GC.GlobalCache -> String -> ErrorLogger [Package] resolveAndCopyDependencies cfg repo gc dir = do pkgspec <- loadPackageSpec dir resolveAndCopyDependenciesForPackage' cfg repo gc dir pkgspec --- Resolves the dependencies for a package copy and fills the package caches. resolveAndCopyDependenciesForPackage :: Config -> String -> Package -> ErrorLogger [Package] resolveAndCopyDependenciesForPackage cfg dir pkgSpec = do repo <- getRepoForPackageSpec cfg pkgSpec gc <- GC.readGlobalCache cfg repo resolveAndCopyDependenciesForPackage' cfg repo gc dir pkgSpec resolveAndCopyDependenciesForPackage' :: Config -> Repository -> GC.GlobalCache -> String -> Package -> ErrorLogger [Package] resolveAndCopyDependenciesForPackage' cfg repo gc dir pkgSpec = do result <- resolveDependenciesForPackageCopy cfg pkgSpec repo gc dir let deps = resolvedPackages result missingDeps = GC.missingPackages gc deps failMsg = "Missing dependencies " ++ (intercalate "," $ map packageId missingDeps) ++ "\nUse `cypm install` to install missing dependencies." if null missingDeps then copyDependencies cfg pkgSpec deps dir else fail failMsg --- Resolves the dependencies for a package copy. resolveDependencies :: Config -> String -> ErrorLogger ResolutionResult resolveDependencies cfg dir = do pkgSpec <- loadPackageSpec dir logInfo $ "Read package spec from " ++ dir repo <- getRepoForPackageSpec cfg pkgSpec gc <- GC.readGlobalCache cfg repo resolveDependenciesForPackageCopy cfg pkgSpec repo gc dir ------------------------------------------------------------------------------ --- Sets `base` package dependency in a package to requiring equality --- with the current `compilerBaseVersion`. --- Hence, a conflict occurs if some package requires a different version --- of the `base` package. setBaseDependency :: Config -> Package -> Package setBaseDependency cfg pkg = pkg { dependencies = map setBase (dependencies pkg) } where bv = maybe (0,0,0,Nothing) id (readVersion (compilerBaseVersion cfg)) setBase (Dependency n disj) = Dependency n $ if n == "base" then map (\conj -> VExact bv : conj) disj else disj --- Same as `LS.addPackages` but set the `base` package dependency. addPackagesWOBase :: Config -> LS.LookupSet -> [Package] -> LS.LookupSource -> LS.LookupSet addPackagesWOBase cfg ls pkgs src = LS.addPackages ls (map (setBaseDependency cfg) pkgs) src ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/src/CPM/PerformanceTest.curry000066400000000000000000000353001377556325500224040ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This module contains the performance test program, currently covering API --- and behavior diff as well as resolution performance. -------------------------------------------------------------------------------- module CPM.PerformanceTest where import ReadShowTerm import System.IO import System.Directory import System.FilePath (()) import System.Process import System.IOExts import Debug.Trace import Data.List import Data.Maybe import Data.Function import Data.Either import AbstractCurry.Build import AbstractCurry.Types hiding (version) import AbstractCurry.Pretty import Debug.Profile import JSON.Pretty import CPM.LookupSet import CPM.ErrorLogger import CPM.FileUtil (recreateDirectory) import CPM.Package import CPM.Resolution import CPM.Diff.API hiding (getBaseTemp) import CPM.Diff.Behavior import CPM.Config import CPM.Repository (Repository, emptyRepository) import qualified CPM.PackageCache.Global as GC import OptParse --- Possible performance tests. data Command = BehaviorDiff | APIDiff | Resolution | CountDeps --- Command line options. data Options = Options { optCommand :: Command , bdTypeNesting :: Int , bdNumberOfFuncs :: Int , adNumberOfEach :: Int , resRepoPath :: Maybe String , resPackages :: String , cdPackage :: String } defaultOptions :: Options defaultOptions = Options { optCommand = BehaviorDiff , bdTypeNesting = 10 , bdNumberOfFuncs = 10 , adNumberOfEach = 10 , resRepoPath = Nothing , resPackages = "" , cdPackage = "" } optionParser :: ParseSpec (Options -> Options) optionParser = optParser ( commands (metavar "COMMAND") ( command "behavior" (help "Run behavior diff performance test.") (\a -> a { optCommand = BehaviorDiff }) ( option (\s a -> a { bdTypeNesting = readInt s }) ( metavar "TYPE-NESTING" <> help "Depth of nested type" <> long "type-nesting" <> short "t" ) <.> option (\s a -> a { bdNumberOfFuncs = readInt s }) ( metavar "NUMBER-OF-FUNCS" <> help "Number of functions to generate" <> long "functions" <> short "f" ) ) <|> command "api" (help "Run API diff performance test.") (\a -> a { optCommand = APIDiff }) ( option (\s a -> a { adNumberOfEach = readInt s }) ( metavar "NUMBER-OF-EACH" <> help "Number of added, removed, changed functions and types to generate." <> long "number" <> short "n") ) <|> command "resolution" (help "Run resolution performance test.") (\a -> a { optCommand = Resolution }) ( option (\s a -> a { resRepoPath = Just s }) ( metavar "REPO-PATH" <> help "A path to a package repository to read. Repository will be read from packages.term if not specified. If specified, repository will be read from this path and then written to packages.term. Note that reading large repositories is not supported on PAKCS." <> long "repo-path" <> short "r") <.> option (\s a -> a { resPackages = s }) ( metavar "PACKAGES" <> help "The package versions to resolve. Expects multiple package ids, i.e., package-version, separated by commas. Pre-release versions are not supported." <> long "packages" <> short "p") ) <|> command "countdeps" (help "Count dependencies of a package.") (\a -> a { optCommand = CountDeps }) ( arg (\s a -> a { cdPackage = s }) ( metavar "PACKAGE" <> help "The package to count dependencies for." ) ) ) ) main :: IO () main = do args <- getArgs -- The shell script that is used to execute CPM.PerformanceTest always adds -- the command line options `+RTS -T -RTS`, since they are needed to enable -- profiling for applications compiled with KiCS2. They are automatically on -- KiCS2, but will still be there when using PAKCS, confusing OptParse. So we -- remove them from the list if they're present. args' <- return $ filter (\a -> a /= "+RTS" && a /= "-T" && a /= "-RTS") args parseResult <- return $ parse (intercalate " " args') optionParser "perftest" case parseResult of Left err -> putStrLn err >> exitWith 1 Right r -> let opts = foldl (flip apply) defaultOptions r in case optCommand opts of BehaviorDiff -> behaviorDiffPerformance opts APIDiff -> apiDiffPerformance opts Resolution -> resolutionPerformance opts CountDeps -> countDeps opts behaviorDiffPerformance :: Options -> IO () behaviorDiffPerformance o = do putStrLn $ "Running behavior diff performance test with " ++ (show $ bdNumberOfFuncs o) ++ " functions and a type nesting depth of " ++ (show $ bdTypeNesting o) types <- return $ genNestedType (bdTypeNesting o) funcs <- return $ map (genCompareFunc (bdTypeNesting o)) [1..(bdNumberOfFuncs o)] prog <- return $ CurryProg "Sample" [] types funcs [] recreateDirectory "/tmp/verA" recreateDirectory "/tmp/verA/src" recreateDirectory "/tmp/verB" recreateDirectory "/tmp/verB/src" writeFile "/tmp/verA/src/Sample.curry" $ showCProg prog writeFile "/tmp/verB/src/Sample.curry" $ showCProg prog writeFile "/tmp/verA/package.json" (ppJSON $ packageSpecToJSON samplePackageA) writeFile "/tmp/verB/package.json" (ppJSON $ packageSpecToJSON samplePackageB) profileTime genTestProgram profileTime genTestProgram profileTime genTestProgram profileTime genTestProgram profileTime genTestProgram putStrLn "DONE" genTestProgram :: ErrorLogger () genTestProgram = preparePackageDirs defaultConfig emptyRepository GC.emptyCache "/tmp/verA" "/tmp/verB" |>= \info -> findFunctionsToCompare defaultConfig emptyRepository GC.emptyCache (infSourceDirA info) (infSourceDirB info) False Nothing |>= \(acyCache, loadpath, funcs, _) -> genCurryCheckProgram defaultConfig emptyRepository GC.emptyCache funcs info True acyCache loadpath |> return () apiDiffPerformance :: Options -> IO () apiDiffPerformance o = do putStrLn $ "Running API diff performance test with " ++ (show n) ++ " functions" (prog1, prog2) <- return $ genDiffProgs n n n n n n recreateDirectory "/tmp/verA" recreateDirectory "/tmp/verA/src" recreateDirectory "/tmp/verB" recreateDirectory "/tmp/verB/src" writeFile "/tmp/verA/src/Sample.curry" (showCProg prog1) writeFile "/tmp/verB/src/Sample.curry" (showCProg prog2) writeFile "/tmp/verA/package.json" (ppJSON $ packageSpecToJSON samplePackageA) writeFile "/tmp/verB/package.json" (ppJSON $ packageSpecToJSON samplePackageB) putStrLn "Files written, now starting test." profileTime (id $!! compareModulesInDirs defaultConfig emptyRepository GC.emptyCache "/tmp/verA" "/tmp/verB" Nothing) profileTime (id $!! compareModulesInDirs defaultConfig emptyRepository GC.emptyCache "/tmp/verA" "/tmp/verB" Nothing) profileTime (id $!! compareModulesInDirs defaultConfig emptyRepository GC.emptyCache "/tmp/verA" "/tmp/verB" Nothing) profileTime (id $!! compareModulesInDirs defaultConfig emptyRepository GC.emptyCache "/tmp/verA" "/tmp/verB" Nothing) profileTime (id $!! compareModulesInDirs defaultConfig emptyRepository GC.emptyCache "/tmp/verA" "/tmp/verB" Nothing) putStrLn "DONE" where n = adNumberOfEach o readPackageSpecs :: Options -> IO LookupSet readPackageSpecs o = case resRepoPath o of Nothing -> do putStrLn "About to read packages.term..." readQTermFile "packages.term" >>= \l -> return $!! addPackages emptySet l FromRepository Just p -> do putStrLn $ "About to read the index from '" ++ p ++ "' ..." ls <- profileTime $ readLS p putStrLn "Writing the index to packages.term..." writeQTermFile "packages.term" (id $!! allPackages ls) return ls resolutionPerformance :: Options -> IO () resolutionPerformance o = do putStrLn "Reading package specifications..." ls <- readPackageSpecs o pkgs <- return $ map (fromJust . (uncurry $ findVersion ls)) $ parsePkgs $ resPackages o putStrLn $ "Running resolution algorithm on " ++ intercalate ", " (map packageId pkgs) forIO pkgs $ \pkg -> do putStrLn $ "Resolving '" ++ packageId pkg ++ "'" profileTime (putStrLn $ showResult $ resolve pkg ls) profileTime (putStrLn $ showResult $ resolve pkg ls) profileTime (putStrLn $ showResult $ resolve pkg ls) profileTime (putStrLn $ showResult $ resolve pkg ls) profileTime (putStrLn $ showResult $ resolve pkg ls) return () where parsePkgs s = map parsePkg $ splitOn "," s parsePkg :: String -> (String, Version) parsePkg s = let split = splitOn "-" s pkgName = intercalate "-" $ init split pkgVer = last split in case readVersion pkgVer of Nothing -> error $ "Could not read version for '" ++ s ++ "'" Just v -> (pkgName, v) countDeps :: Options -> IO () countDeps o = do putStrLn "Reading package specifications..." ls <- readPackageSpecs o pkg <- return $ fromJust $ uncurry (findVersion ls) $ parsePkg (cdPackage o) transDeps <- return $ transitiveDependencies ls pkg verCount <- return $ foldl (flip $ (+) . length . (findAllVersions' ls)) 0 transDeps putStrLn $ packageId pkg ++ " has " ++ (show $ length transDeps) ++ " dependencies with " ++ show verCount ++ " versions" where findAllVersions' ls p = findAllVersions ls p True readLS :: String -> IO LookupSet readLS path = do pkgDirs <- getDirectoryContents path pkgPaths <- return $ map (path ) $ filter (not . isPrefixOf ".") pkgDirs verDirs <- mapIO getDirectoryContents pkgPaths verPaths <- return $ concat $ map (\(d, p) -> map (d ) (filter (not . isPrefixOf ".") p)) $ zip pkgPaths verDirs specPaths <- return $ map ( "package.json") verPaths specs <- mapIO (readPackageSpecIO specPaths) specPaths return $!! addPackages emptySet (rights specs) FromRepository where readPackageSpecIO _ p = do s <- readCompleteFile p return $ readPackageSpec s extractComponents :: [(a, b)] -> ([a], [b]) extractComponents ts = (as, bs) where as = map fst ts bs = map snd ts data APIDiffType = Added | Removed | Changed samplePackageA :: Package samplePackageA = Package { name = "sample" , version = (0, 0, 1, Nothing) , author = "author" , synopsis = "JSON library for Curry" , dependencies = [] , maintainer = Nothing , description = Nothing , license = Nothing , licenseFile = Nothing , copyright = Nothing , homepage = Nothing , bugReports = Nothing , repository = Nothing , compilerCompatibility = [] , source = Nothing , exportedModules = ["Sample"] , executableSpec = [] , testSuite = Nothing } samplePackageB :: Package samplePackageB = samplePackageA { version = (0, 0, 2, Nothing) } stringType :: CTypeExpr stringType = CTCons ("Prelude", "String") [] genDiffFunc :: APIDiffType -> Int -> (Maybe CFuncDecl, Maybe CFuncDecl) genDiffFunc Added n = (Just f, Nothing) where f = cfunc ("Sample", "f" ++ (show n)) 1 Public (CFuncType stringType stringType) [ simpleRule (pVars 1) (toVar 0) ] genDiffFunc Removed n = (Nothing, Just f) where f = cfunc ("Sample", "f" ++ (show n)) 1 Public (CFuncType stringType stringType) [ simpleRule (pVars 1) (toVar 0) ] genDiffFunc Changed n = (Just f1, Just f2) where f1 = cfunc ("Sample", "f" ++ (show n)) 1 Public (CFuncType stringType stringType) [ simpleRule (pVars 1) (toVar 0) ] f2 = cfunc ("Sample", "f" ++ (show n)) 2 Public (CFuncType stringType (CFuncType stringType stringType)) [ simpleRule (pVars 2) (toVar 1) ] genDiffFuncs :: Int -> Int -> APIDiffType -> ([CFuncDecl], [CFuncDecl]) genDiffFuncs s n t = both catMaybes $ extractComponents $ map (genDiffFunc t) (enumFromTo s n) allCons :: Int -> [CConsDecl] allCons n = [ CCons ("Sample", "Cons1" ++ (show n)) Public [stringType] , CCons ("Sample", "Cons2" ++ (show n)) Public [stringType] , CCons ("Sample", "Cons3" ++ (show n)) Public [stringType] ] notAllCons :: Int -> [CConsDecl] notAllCons n = [ CCons ("Sample", "Cons1" ++ (show n)) Public [stringType] , CCons ("Sample", "Cons2" ++ (show n)) Public [stringType] ] genDiffType :: APIDiffType -> Int -> (Maybe CTypeDecl, Maybe CTypeDecl) genDiffType Added n = (Just t, Nothing) where t = CType ("Sample", "Type" ++ (show n)) Public [] (allCons n) genDiffType Removed n = (Nothing, Just t) where t = CType ("Sample", "Type" ++ (show n)) Public [] (allCons n) genDiffType Changed n = (Just t1, Just t2) where t1 = CType ("Sample", "Type" ++ (show n)) Public [] (allCons n) t2 = CType ("Sample", "Type" ++ (show n)) Public [] (notAllCons n) genDiffTypes :: Int -> Int -> APIDiffType -> ([CTypeDecl], [CTypeDecl]) genDiffTypes s n t = both catMaybes $ extractComponents $ map (genDiffType t) (enumFromTo s n) genDiffProgs :: Int -> Int -> Int -> Int -> Int -> Int -> (CurryProg, CurryProg) genDiffProgs nfsAdded nfsRemoved nfsChanged ntsAdded ntsRemoved ntsChanged = (prog1, prog2) where fromfsAdded = 1 tofsAdded = nfsAdded fromfsRemoved = tofsAdded + 1 tofsRemoved = tofsAdded + nfsRemoved fromfsChanged = tofsRemoved + 1 tofsChanged = tofsRemoved + nfsChanged fromtsAdded = tofsChanged + 1 totsAdded = tofsChanged + ntsAdded fromtsRemoved = totsAdded + 1 totsRemoved = totsAdded + ntsRemoved fromtsChanged = totsRemoved + 1 totsChanged = totsRemoved + ntsChanged (fsAdded1, fsAdded2) = genDiffFuncs fromfsAdded tofsAdded Added (fsRemoved1, fsRemoved2) = genDiffFuncs fromfsRemoved tofsRemoved Removed (fsChanged1, fsChanged2) = genDiffFuncs fromfsChanged tofsChanged Changed (tsAdded1, tsAdded2) = genDiffTypes fromtsAdded totsAdded Added (tsRemoved1, tsRemoved2) = genDiffTypes fromtsRemoved totsRemoved Removed (tsChanged1, tsChanged2) = genDiffTypes fromtsChanged totsChanged Changed prog1 = CurryProg "Sample" [] (tsAdded1 ++ tsRemoved1 ++ tsChanged1) (fsAdded1 ++ fsRemoved1 ++ fsChanged1) [] prog2 = CurryProg "Sample" [] (tsAdded2 ++ tsRemoved2 ++ tsChanged2) (fsAdded2 ++ fsRemoved2 ++ fsChanged2) [] genNestedType :: Int -> [CTypeDecl] genNestedType n | n == 0 = [CType ("Sample", "Nested0") Public [] [CCons ("Sample", "Nested0") Public [stringType]]] | otherwise = let t = (CType ("Sample", "Nested" ++ (show n)) Public [] [CCons ("Sample", "Nested" ++ (show n)) Public [CTCons ("Sample", "Nested" ++ (show (n - 1))) []]]) in t:(genNestedType (n - 1)) genCompareFunc :: Int -> Int -> CFuncDecl genCompareFunc tn n = cfunc ("Sample", "f" ++ (show n)) 1 Public (CFuncType (CTCons ("Sample", "Nested" ++ (show tn)) []) (CTCons ("Sample", "Nested" ++ (show tn)) [])) [ simpleRule (pVars 1) (toVar 0) ] curry-tools-v3.3.0/cpm/src/CPM/Repository.curry000066400000000000000000000217011377556325500214620ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module implements functionality surrounding the package *repository*. --- The repository is the index of all packages known to the package manager. --- It contains metadata about the packages, such as their names, versions --- dependencies and where they can be acquired. The repository does not contain --- the actual packages. For a list of packages that are currently installed --- locally, you can consult the *database*. ------------------------------------------------------------------------------ module CPM.Repository ( Repository , emptyRepository, allPackages, pkgsToRepository , warnIfRepositoryOld, readRepositoryFrom , findAllVersions, findVersion, findLatestVersion , searchPackages, listPackages , useUpdateHelp, cleanRepositoryCache , readPackageFromRepository , repositoryCacheFilePrefix ) where import Data.Char ( toLower ) import Data.Either import Data.List import Data.Time import Control.Monad import System.Directory import System.FilePath import System.IO import System.IOExts ( readCompleteFile ) import System.Process ( exitWith, system ) import ReadShowTerm ( showQTerm, readQTerm, showTerm, readUnqualifiedTerm ) import CPM.Config ( Config, repositoryDir ) import CPM.ConfigPackage ( packageVersion ) import CPM.ErrorLogger import CPM.Package import CPM.FileUtil ( checkAndGetVisibleDirectoryContents , copyDirectory, inDirectory , quote, whenFileExists, removeDirectoryComplete ) import CPM.Resolution ( isCompatibleToCompiler ) ------------------------------------------------------------------------------ --- Abstract data type of a repository. data Repository = Repository [Package] --- Creates an empty repository. emptyRepository :: Repository emptyRepository = Repository [] --- Get all packages in the central package index. allPackages :: Repository -> [Package] allPackages (Repository ps) = ps --- Construct a repository from a list of packages. pkgsToRepository :: [Package] -> Repository pkgsToRepository ps = Repository ps ------------------------------------------------------------------------------ --- Finds all versions of a package known to the repository. Returns the --- packages sorted from newest to oldest. --- --- @param r the repository --- @param p the name of the package to search for --- @param pre should pre-release versions be included? findAllVersions :: Repository -> String -> Bool -> [Package] findAllVersions (Repository ps) p pre = sortedByVersion $ preFiltered $ sameName ps where sortedByVersion = sortBy (\a b -> (version a) `vgt` (version b)) preFiltered = filter filterPre sameName = filter ((== p) . name) filterPre p' = pre || (not . isPreRelease . version) p' --- Search the names and synopses of all compiler-compatbile packages --- in the repository for a particular term. --- Lower/upercase is ignored for the search. --- Returns all matching versions (newest first) of each package. --- --- @param repo - the repository --- @param searchmod - search for some module? --- @param searchexec - search for some executable? --- @param searchterm - the term to search for searchPackages :: Repository -> Bool -> Bool -> String -> [[Package]] searchPackages (Repository ps) searchmod searchexec searchterm = map sortedByVersion (groupBy (\a b -> name a == name b) allResults) where allResults = let s = lowerS searchterm in if searchmod then filter (\p -> searchterm `elem` exportedModules p) ps else if searchexec then filter (\p -> s `isInfixOf` (lowerS $ execOfPackage p)) ps else filter (matches s) ps matches q p = q `isInfixOf` (lowerS $ name p) || q `isInfixOf` (lowerS $ synopsis p) || q `isInfixOf` (lowerS $ unwords (exportedModules p)) sortedByVersion = sortBy (\a b -> version a `vgt` version b) lowerS = map toLower --- Get all packages in the repository and group them by versions --- (newest first). --- --- @param cfg - the current CPM configuration --- @param repo - the repository listPackages :: Repository -> [[Package]] listPackages (Repository ps) = map sortedByVersion (groupBy (\a b -> name a == name b) ps) where sortedByVersion = sortBy (\a b -> (version a) `vgt` (version b)) --- Finds the latest compiler-compatbile version of a package. --- --- @param cfg - the current CPM configuration --- @param repo - the central package index --- @param p - the package to search for --- @param pre - include pre-release versions findLatestVersion :: Config -> Repository -> String -> Bool -> Maybe Package findLatestVersion cfg repo pn pre = case filter (isCompatibleToCompiler cfg) (findAllVersions repo pn pre) of [] -> Nothing (p:_) -> Just p --- Finds a specific version of a package. findVersion :: Repository -> String -> Version -> Maybe Package findVersion repo pn v = maybeHead $ filter ((== v) . version) $ findAllVersions repo pn True where maybeHead [] = Nothing maybeHead (x:_) = Just x --- Prints a warning if the repository index is older than 10 days. warnIfRepositoryOld :: Config -> ErrorLogger () warnIfRepositoryOld cfg = do let updatefile = repositoryDir cfg "README.md" updexists <- liftIOEL $ doesFileExist updatefile if updexists then do utime <- liftIOEL $ getModificationTime updatefile ctime <- liftIOEL $ getClockTime let warntime = addDays 10 utime when (compareClockTime ctime warntime == GT) $ do -- we assume that clock time is measured in seconds let timediff = clockTimeToInt ctime - clockTimeToInt utime days = timediff `div` (60*60*24) logInfo $ "Warning: your repository index is older than " ++ show days ++ " days.\n" ++ useUpdateHelp else logInfo $ "Warning: your repository index is not up-to-date.\n" ++ useUpdateHelp useUpdateHelp :: String useUpdateHelp = "Use 'cypm update' to download the newest package index." --- Reads all package specifications from a repository. --- If some errors occur, show them and terminate with error exit status. --- --- @param path the location of the repository --- @return repository readRepositoryFrom :: String -> ErrorLogger Repository readRepositoryFrom path = do (repo, repoErrors) <- tryReadRepositoryFrom path if null repoErrors then return repo else do logError "Problems while reading the package index:" mapM_ logError repoErrors liftIOEL $ exitWith 1 --- Reads all package specifications from a repository. --- --- @param path the location of the repository --- @return repository and possible repository reading errors tryReadRepositoryFrom :: String -> ErrorLogger (Repository, [String]) tryReadRepositoryFrom path = do logDebug $ "Reading repository index from '" ++ path ++ "'..." repos <- liftIOEL $ checkAndGetVisibleDirectoryContents path pkgPaths <- liftIOEL $ mapM getDir (map (path ) repos) >>= return . concat verDirs <- liftIOEL $ mapM checkAndGetVisibleDirectoryContents pkgPaths verPaths <- return $ concatMap (\ (d, p) -> map (d ) p) $ zip pkgPaths verDirs specPaths <- return $ map ( "package.json") verPaths logInfo "Reading repository index..." specs <- liftIOEL $ mapM readPackageFile specPaths when (null (lefts specs)) $ logDebug "Finished reading repository" return $ (Repository $ rights specs, lefts specs) where readPackageFile f = do spec <- readPackageSpec <$> readCompleteFile f seq (id $!! spec) (putChar '.' >> hFlush stdout) return $ case spec of Left err -> Left $ "Problem reading '" ++ f ++ "': " ++ err Right s -> Right s getDir d = doesDirectoryExist d >>= \b -> return $ if b then [d] else [] ------------------------------------------------------------------------------ --- The prefix of all file names implementing the repository cache. repositoryCacheFilePrefix :: Config -> String repositoryCacheFilePrefix cfg = repositoryDir cfg "REPOSITORY_CACHE" --- Cleans the repository cache. cleanRepositoryCache :: Config -> ErrorLogger () cleanRepositoryCache cfg = do logDebug $ "Cleaning repository cache '" ++ repositoryCacheFilePrefix cfg ++ "*'" liftIOEL $ system $ "/bin/rm -f " ++ quote (repositoryCacheFilePrefix cfg) ++ "*" return () ------------------------------------------------------------------------------ --- Reads a given package from the default repository directory. --- This is useful to obtain the complete package specification --- from a possibly incomplete package specification. readPackageFromRepository :: Config -> Package -> ErrorLogger Package readPackageFromRepository cfg pkg = let pkgdir = repositoryDir cfg name pkg showVersion (version pkg) in loadPackageSpec pkgdir ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/src/CPM/Repository/000077500000000000000000000000001377556325500203735ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/src/CPM/Repository/CacheDB.curry000066400000000000000000000154661377556325500227060ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Operations to initialize and manipulate the repository cache database. --- --- @author Michael Hanus --- @version December 2020 ------------------------------------------------------------------------------ module CPM.Repository.CacheDB ( repositoryCacheDB, tryInstallRepositoryDB, addPackagesToRepositoryDB ) where import Data.Maybe ( maybeToList, listToMaybe ) import System.Directory ( doesFileExist, removeFile ) import System.FilePath ( () ) import System.IO ( hFlush, stdout ) import Control.Monad import ReadShowTerm import Database.CDBI.ER import Database.CDBI.Connection import System.Path ( fileInPath ) import Text.CSV import CPM.Config ( Config, packageTarFilesURLs, readConfigurationWith , repositoryDir ) import CPM.ErrorLogger import CPM.FileUtil ( cleanTempDir, quote, tempDir, whenFileExists ) import CPM.Repository.RepositoryDB import CPM.Package import CPM.Repository --- The database containing the repository cache. repositoryCacheDB :: Config -> String repositoryCacheDB cfg = repositoryCacheFilePrefix cfg ++ ".db" --- The database containing the repository cache. repositoryCacheCSV :: Config -> String repositoryCacheCSV cfg = repositoryCacheFilePrefix cfg ++ ".csv" --- Installs the repository database with the current repository index --- if the command `sqlite3` is in the path. tryInstallRepositoryDB :: Config -> Bool -> Bool -> ErrorLogger () tryInstallRepositoryDB cfg usecache writecsv = do withsqlite <- liftIOEL $ fileInPath "sqlite3" if withsqlite then installRepositoryDB cfg usecache writecsv else logInfo "Command 'sqlite3' not found: install package 'sqlite3' to speed up CPM" --- Writes the repository database with the current repository index. --- First, it is tried to download `REPOSITORY_CACHE.db` --- from the tar files URL (if the second argument is `True`). --- Otherwise, `writeRepositoryDB` is called. --- If the second argument is `True`, also a CSV file containing the --- database entries is written. installRepositoryDB :: Config -> Bool -> Bool -> ErrorLogger () installRepositoryDB cfg False writecsv = writeRepositoryDB cfg False writecsv installRepositoryDB cfg True writecsv = do let sqlitefile = repositoryCacheDB cfg liftIOEL $ whenFileExists sqlitefile $ removeFile sqlitefile c <- tryDownloadFromURLs sqlitefile (packageTarFilesURLs cfg) "REPOSITORY_CACHE.db" dbexists <- liftIOEL $ doesFileExist sqlitefile if c == 0 && dbexists then if writecsv then saveDBAsCSV cfg else return () else writeRepositoryDB cfg True writecsv --- Tries to download some target file (first argument) from a list of --- base URLs where the source file (third argument) is located. --- Returns 0 if the download was successfull. tryDownloadFromURLs :: String -> [String] -> String -> ErrorLogger Int tryDownloadFromURLs _ [] _ = return 1 tryDownloadFromURLs target (baseurl:baseurls) file = do let sourceurl = baseurl ++ "/" ++ file rc <- showExecCmd $ "curl -f -s -o " ++ quote target ++ " " ++ quote sourceurl if rc == 0 then return 0 else tryDownloadFromURLs target baseurls file --- Writes the repository database with the current repository index. --- It is generated either from the CSV file `REPOSITORY_CACHE.csv` --- downloaded from the tar files URL (if the second argument is `True`) --- or from reading all package specs. --- If the third argument is `True`, also a CSV file containing the --- database entries is written. writeRepositoryDB :: Config -> Bool -> Bool -> ErrorLogger () writeRepositoryDB cfg usecache writecsv = do let sqlitefile = repositoryCacheDB cfg liftIOEL $ do whenFileExists sqlitefile (removeFile sqlitefile) createNewDB sqlitefile tmpdir <- liftIOEL $ tempDir let csvfile = tmpdir "cachedb.csv" showExecCmd $ "/bin/rm -f " ++ csvfile c <- if usecache then tryDownloadFromURLs csvfile (packageTarFilesURLs cfg) "REPOSITORY_CACHE.csv" else return 1 csvexists <- liftIOEL $ doesFileExist csvfile pkgentries <- if c == 0 && csvexists then do logDebug $ "Reading CSV file '" ++ csvfile ++ "'..." (liftIOEL $ readCSVFile csvfile) >>= return . map Right else do when usecache $ logDebug $ "Fetching repository cache CSV file failed" repo <- readRepositoryFrom (repositoryDir cfg) return $ map Left $ allPackages repo liftIOEL $ putStr "Writing repository cache DB" addPackagesToRepositoryDB cfg False pkgentries liftIOEL $ putChar '\n' logInfo "Repository cache DB written" liftIOEL $ cleanTempDir if writecsv then saveDBAsCSV cfg else return () --- Add a list of package descriptions to the database. --- Here, a package description is either a (reduced) package specification --- or a list of string (a row from a CSV file) containing the required infos. addPackagesToRepositoryDB :: Config -> Bool -> [Either Package [String]] -> ErrorLogger () addPackagesToRepositoryDB cfg quiet pkgs = mapM (runDBAction . newEntry) pkgs >> return () where runDBAction act = do result <- liftIOEL $ runWithDB (repositoryCacheDB cfg) act case result of Left (DBError kind str) -> logCritical $ "Repository DB failure: " ++ show kind ++ " " ++ str Right _ -> liftIOEL $ do unless quiet $ putChar '.' hFlush stdout return () newEntry (Left p) = newIndexEntry (name p) (showTerm (version p)) (showTerm (dependencies p)) (showTerm (compilerCompatibility p)) (synopsis p) (showTerm (category p)) (showTerm (sourceDirs p)) (showTerm (exportedModules p)) (showTerm (listToMaybe (executableSpec p))) newEntry (Right [pn,pv,deps,cc,syn,cat,dirs,mods,exe]) = newIndexEntry pn pv deps cc syn cat dirs mods exe --- Saves complete database as term files into an existing directory --- provided as a parameter. saveDBAsCSV :: Config -> ErrorLogger () saveDBAsCSV cfg = do result <- liftIOEL $ runWithDB (repositoryCacheDB cfg) (getAllEntries indexEntry_CDBI_Description) case result of Left (DBError kind str) -> logCritical $ "Repository DB failure: " ++ show kind ++ " " ++ str Right es -> do let csvfile = repositoryCacheCSV cfg liftIOEL $ writeCSVFile csvfile $ map showIndexEntry es logInfo ("CSV file '" ++ csvfile ++ "' written!") where showIndexEntry (IndexEntry _ pn pv deps cc syn cat dirs mods exe) = [pn,pv,deps,cc,syn,cat,dirs,mods,exe] curry-tools-v3.3.0/cpm/src/CPM/Repository/CacheFile.curry000066400000000000000000000125051377556325500232670ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains operations implementing a file-based repository cache --- for faster reading the repository. This file-based implementation --- is used if the command `sqlite3` is not available (compare module --- `CPM.RepositoryCache.Init`). --- The repository cache contains reduced package specifications --- for faster reading/writing by removing some information --- which is not relevant for the repository data structure. --- --- The relevant package fields are: --- * small cache: name version dependencies compilerCompatibility --- * large cache: synopsis category sourceDirs exportedModules executableSpec --- --- @author Michael Hanus --- @version December 2020 ------------------------------------------------------------------------------ module CPM.Repository.CacheFile ( readRepository ) where import Data.Maybe ( maybeToList, listToMaybe ) import System.Directory ( doesFileExist ) import System.IO import ReadShowTerm ( showQTerm, readQTerm, showTerm, readUnqualifiedTerm ) import CPM.Config ( Config, repositoryDir ) import CPM.ConfigPackage ( packageVersion ) import CPM.ErrorLogger import CPM.Package import CPM.Repository ------------------------------------------------------------------------------ --- Reads all package specifications from the default repository. --- Uses the cache if it is present or update the cache after reading. --- If some errors occur, show them and terminate with error exit status. --- --- @param cfg - the configuration to use --- @param large - if true reads the larger cache with more package information --- (e.g., for searching all packages) readRepository :: Config -> Bool -> ErrorLogger Repository readRepository cfg large = do warnIfRepositoryOld cfg mbrepo <- readRepositoryCache cfg large case mbrepo of Nothing -> do repo <- readRepositoryFrom (repositoryDir cfg) logInfo $ "Writing " ++ (if large then "large" else "base") ++ " repository cache..." liftIOEL $ writeRepositoryCache cfg large repo return repo Just repo -> return repo --- The file containing the repository cache as a Curry term. repositoryCache :: Config -> Bool -> String repositoryCache cfg large = repositoryCacheFilePrefix cfg ++ (if large then "_LARGE" else "_SMALL") --- The first line of the repository cache (to check version compatibility): repoCacheVersion :: String repoCacheVersion = packageVersion ++ "-1" --- Stores the given repository in the cache. --- --- @param cfg - the configuration to use --- @param large - if true writes the larger cache with more package information --- (e.g., for searching all packages) --- @param repo - the repository to write writeRepositoryCache :: Config -> Bool -> Repository -> IO () writeRepositoryCache cfg large repo = writeFile (repositoryCache cfg large) $ unlines $ repoCacheVersion : map (if large then showTerm . package2largetuple else showTerm . package2smalltuple) (allPackages repo) where package2smalltuple p = ( name p, version p, dependencies p, compilerCompatibility p ) package2largetuple p = (package2smalltuple p, (synopsis p, category p, sourceDirs p, exportedModules p, listToMaybe (executableSpec p))) --- Reads the given repository from the cache. --- --- @param cfg - the configuration to use --- @param large - if true reads the larger cache with more package information --- (e.g., for searching all packages) readRepositoryCache :: Config -> Bool -> ErrorLogger (Maybe Repository) readRepositoryCache cfg large = do let cf = repositoryCache cfg large excache <- liftIOEL $ doesFileExist cf if excache then do logDebug ("Reading repository cache from '" ++ cf ++ "'...") ((if large then readTermInCacheFile cfg (largetuple2package . uread) cf else readTermInCacheFile cfg (smalltuple2package . uread) cf) >>= \repo -> logDebug "Finished reading repository cache" >> return repo) <|> (do logInfo "Cleaning broken repository cache..." cleanRepositoryCache cfg return Nothing ) else return Nothing where uread s = readUnqualifiedTerm ["CPM.Package","Prelude"] s smalltuple2package (nm,vs,dep,cmp) = emptyPackage { name = nm , version = vs , dependencies = dep , compilerCompatibility = cmp } largetuple2package (basics,(sy,cat,srcs,exps,exec)) = (smalltuple2package basics) { synopsis = sy , category = cat , sourceDirs = srcs , exportedModules = exps , executableSpec = maybeToList exec } readTermInCacheFile :: Config -> (String -> Package) -> String -> ErrorLogger (Maybe Repository) readTermInCacheFile cfg trans cf = do h <- liftIOEL $ openFile cf ReadMode pv <- liftIOEL $ hGetLine h if pv == repoCacheVersion then liftIOEL (hGetContents h) >>= \t -> return $!! Just (pkgsToRepository (map trans (lines t))) else do logInfo "Cleaning repository cache (wrong version)..." cleanRepositoryCache cfg return Nothing ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/src/CPM/Repository/IndexDB_ERD.curry000066400000000000000000000023351377556325500234330ustar00rootroot00000000000000------------------------------------------------------------------------------ --- ERD specification for the repository index database --- --- @author Michael Hanus --- @version March 2018 ------------------------------------------------------------------------------ import Database.ERD picERD :: ERD picERD = ERD "RepositoryDB" [Entity "IndexEntry" [Attribute "Name" (StringDom Nothing) NoKey False, Attribute "Version" (StringDom Nothing) NoKey False, Attribute "Dependencies" (StringDom Nothing) NoKey True, Attribute "CompilerCompatibility" (StringDom Nothing) NoKey True, Attribute "Synopsis" (StringDom Nothing) NoKey True, Attribute "Category" (StringDom Nothing) NoKey True, Attribute "SourceDirs" (StringDom Nothing) NoKey True, Attribute "ExportedModules" (StringDom Nothing) NoKey True, Attribute "ExecutableSpec" (StringDom Nothing) NoKey True ]] [] {- Generate CDBI API with: > erd2curry --cdbi --db REPOSITORY_CACHE.db IndexDB_ERD.curry Manual changes after generating the API module: * Rename CDBI API module: RepositoryDB -> CPM.RepositoryCache.RepositoryDB -} curry-tools-v3.3.0/cpm/src/CPM/Repository/README.txt000066400000000000000000000023021377556325500220660ustar00rootroot00000000000000This directory contains the implementation of the repository index cache with term files or a SQLite database. The file IndexDB_ERD.curry contains the definition of the ER model of the database. The initial version of the module `RepositoryDB` has been generated with > erd2curry --cdbi --db REPOSITORY_CACHE.db IndexDB_ERD.curry The following changes to the initially generated module were applied after its generation: * Rename the module from `RepositoryDB` to `CPM.Repository.RepositoryDB` (also in `RepositoryDB_SQLCode.info`). The actual database queries are defined in the module CPM.Repository.Select Since these queries are defined as embedded SQL code which requires the Curry preprocessor to translate them, the distribution of CPM contains the already preprocessed module whereas the original module is stored in file `Select_ORG.curry`. Hence, if one wants to further develop this part of CPM, one has to follow these steps: 1. Copy the original file: > cp Select_ORG.curry Select.curry 2. Make changes to `Select.curry`. 3. Compile CPM 4. Store the changes before committing by: > cp Select.curry Select_ORG.curry > cp Select.curry.CURRYPP Select.curry curry-tools-v3.3.0/cpm/src/CPM/Repository/RepositoryDB.curry000066400000000000000000000456111377556325500240550ustar00rootroot00000000000000--- This file has been generated from --- --- cpm/src/CPM/Repository/IndexDB_ERD.curry --- --- and contains definitions for all entities and relations --- specified in this model. module CPM.Repository.RepositoryDB where import qualified Data.Time as Time import qualified Database.CDBI.ER import qualified Database.CDBI.Criteria import qualified Database.CDBI.Connection import qualified Database.CDBI.Description data IndexEntry = IndexEntry IndexEntryID String String String String String String String String String deriving (Eq,Show,Read) data IndexEntryID = IndexEntryID Int deriving (Eq,Show,Read) --- The name of the SQLite database file. sqliteDBFile :: String sqliteDBFile = "REPOSITORY_CACHE.db" -- not used --- The ER description of the `IndexEntry` entity. indexEntry_CDBI_Description :: Database.CDBI.Description.EntityDescription IndexEntry indexEntry_CDBI_Description = Database.CDBI.Description.ED "IndexEntry" [Database.CDBI.Connection.SQLTypeInt ,Database.CDBI.Connection.SQLTypeString ,Database.CDBI.Connection.SQLTypeString ,Database.CDBI.Connection.SQLTypeString ,Database.CDBI.Connection.SQLTypeString ,Database.CDBI.Connection.SQLTypeString ,Database.CDBI.Connection.SQLTypeString ,Database.CDBI.Connection.SQLTypeString ,Database.CDBI.Connection.SQLTypeString ,Database.CDBI.Connection.SQLTypeString] (\(IndexEntry (IndexEntryID key) name version dependencies compilerCompatibility synopsis category sourceDirs exportedModules executableSpec) -> [Database.CDBI.Connection.SQLInt key ,Database.CDBI.Connection.SQLString name ,Database.CDBI.Connection.SQLString version ,Database.CDBI.Description.sqlString dependencies ,Database.CDBI.Description.sqlString compilerCompatibility ,Database.CDBI.Description.sqlString synopsis ,Database.CDBI.Description.sqlString category ,Database.CDBI.Description.sqlString sourceDirs ,Database.CDBI.Description.sqlString exportedModules ,Database.CDBI.Description.sqlString executableSpec]) (\(IndexEntry _ name version dependencies compilerCompatibility synopsis category sourceDirs exportedModules executableSpec) -> [Database.CDBI.Connection.SQLNull ,Database.CDBI.Connection.SQLString name ,Database.CDBI.Connection.SQLString version ,Database.CDBI.Description.sqlString dependencies ,Database.CDBI.Description.sqlString compilerCompatibility ,Database.CDBI.Description.sqlString synopsis ,Database.CDBI.Description.sqlString category ,Database.CDBI.Description.sqlString sourceDirs ,Database.CDBI.Description.sqlString exportedModules ,Database.CDBI.Description.sqlString executableSpec]) (\[Database.CDBI.Connection.SQLInt key ,Database.CDBI.Connection.SQLString name ,Database.CDBI.Connection.SQLString version ,dependencies ,compilerCompatibility ,synopsis ,category ,sourceDirs ,exportedModules ,executableSpec] -> IndexEntry (IndexEntryID key) name version (Database.CDBI.Description.fromStringOrNull dependencies) (Database.CDBI.Description.fromStringOrNull compilerCompatibility) (Database.CDBI.Description.fromStringOrNull synopsis) (Database.CDBI.Description.fromStringOrNull category) (Database.CDBI.Description.fromStringOrNull sourceDirs) (Database.CDBI.Description.fromStringOrNull exportedModules) (Database.CDBI.Description.fromStringOrNull executableSpec)) --- The database table of the `IndexEntry` entity. indexEntryTable :: Database.CDBI.Description.Table indexEntryTable = "IndexEntry" --- The database column `Key` of the `IndexEntry` entity. indexEntryColumnKey :: Database.CDBI.Description.Column IndexEntryID indexEntryColumnKey = Database.CDBI.Description.Column "\"Key\"" "\"IndexEntry\".\"Key\"" --- The database column `Name` of the `IndexEntry` entity. indexEntryColumnName :: Database.CDBI.Description.Column String indexEntryColumnName = Database.CDBI.Description.Column "\"Name\"" "\"IndexEntry\".\"Name\"" --- The database column `Version` of the `IndexEntry` entity. indexEntryColumnVersion :: Database.CDBI.Description.Column String indexEntryColumnVersion = Database.CDBI.Description.Column "\"Version\"" "\"IndexEntry\".\"Version\"" --- The database column `Dependencies` of the `IndexEntry` entity. indexEntryColumnDependencies :: Database.CDBI.Description.Column String indexEntryColumnDependencies = Database.CDBI.Description.Column "\"Dependencies\"" "\"IndexEntry\".\"Dependencies\"" --- The database column `CompilerCompatibility` of the `IndexEntry` entity. indexEntryColumnCompilerCompatibility :: Database.CDBI.Description.Column String indexEntryColumnCompilerCompatibility = Database.CDBI.Description.Column "\"CompilerCompatibility\"" "\"IndexEntry\".\"CompilerCompatibility\"" --- The database column `Synopsis` of the `IndexEntry` entity. indexEntryColumnSynopsis :: Database.CDBI.Description.Column String indexEntryColumnSynopsis = Database.CDBI.Description.Column "\"Synopsis\"" "\"IndexEntry\".\"Synopsis\"" --- The database column `Category` of the `IndexEntry` entity. indexEntryColumnCategory :: Database.CDBI.Description.Column String indexEntryColumnCategory = Database.CDBI.Description.Column "\"Category\"" "\"IndexEntry\".\"Category\"" --- The database column `SourceDirs` of the `IndexEntry` entity. indexEntryColumnSourceDirs :: Database.CDBI.Description.Column String indexEntryColumnSourceDirs = Database.CDBI.Description.Column "\"SourceDirs\"" "\"IndexEntry\".\"SourceDirs\"" --- The database column `ExportedModules` of the `IndexEntry` entity. indexEntryColumnExportedModules :: Database.CDBI.Description.Column String indexEntryColumnExportedModules = Database.CDBI.Description.Column "\"ExportedModules\"" "\"IndexEntry\".\"ExportedModules\"" --- The database column `ExecutableSpec` of the `IndexEntry` entity. indexEntryColumnExecutableSpec :: Database.CDBI.Description.Column String indexEntryColumnExecutableSpec = Database.CDBI.Description.Column "\"ExecutableSpec\"" "\"IndexEntry\".\"ExecutableSpec\"" --- The description of the database column `Key` of the `IndexEntry` entity. indexEntryKeyColDesc :: Database.CDBI.Description.ColumnDescription IndexEntryID indexEntryKeyColDesc = Database.CDBI.Description.ColDesc "\"IndexEntry\".\"Key\"" Database.CDBI.Connection.SQLTypeInt (\(IndexEntryID key) -> Database.CDBI.Connection.SQLInt key) (\(Database.CDBI.Connection.SQLInt key) -> IndexEntryID key) --- The description of the database column `Name` of the `IndexEntry` entity. indexEntryNameColDesc :: Database.CDBI.Description.ColumnDescription String indexEntryNameColDesc = Database.CDBI.Description.ColDesc "\"IndexEntry\".\"Name\"" Database.CDBI.Connection.SQLTypeString (\name -> Database.CDBI.Connection.SQLString name) (\(Database.CDBI.Connection.SQLString name) -> name) --- The description of the database column `Version` of the `IndexEntry` entity. indexEntryVersionColDesc :: Database.CDBI.Description.ColumnDescription String indexEntryVersionColDesc = Database.CDBI.Description.ColDesc "\"IndexEntry\".\"Version\"" Database.CDBI.Connection.SQLTypeString (\version -> Database.CDBI.Connection.SQLString version) (\(Database.CDBI.Connection.SQLString version) -> version) --- The description of the database column `Dependencies` of the `IndexEntry` entity. indexEntryDependenciesColDesc :: Database.CDBI.Description.ColumnDescription String indexEntryDependenciesColDesc = Database.CDBI.Description.ColDesc "\"IndexEntry\".\"Dependencies\"" Database.CDBI.Connection.SQLTypeString (\dependencies -> Database.CDBI.Description.sqlString dependencies) (\dependencies -> Database.CDBI.Description.fromStringOrNull dependencies) --- The description of the database column `CompilerCompatibility` of the `IndexEntry` entity. indexEntryCompilerCompatibilityColDesc :: Database.CDBI.Description.ColumnDescription String indexEntryCompilerCompatibilityColDesc = Database.CDBI.Description.ColDesc "\"IndexEntry\".\"CompilerCompatibility\"" Database.CDBI.Connection.SQLTypeString (\compilerCompatibility -> Database.CDBI.Description.sqlString compilerCompatibility) (\compilerCompatibility -> Database.CDBI.Description.fromStringOrNull compilerCompatibility) --- The description of the database column `Synopsis` of the `IndexEntry` entity. indexEntrySynopsisColDesc :: Database.CDBI.Description.ColumnDescription String indexEntrySynopsisColDesc = Database.CDBI.Description.ColDesc "\"IndexEntry\".\"Synopsis\"" Database.CDBI.Connection.SQLTypeString (\synopsis -> Database.CDBI.Description.sqlString synopsis) (\synopsis -> Database.CDBI.Description.fromStringOrNull synopsis) --- The description of the database column `Category` of the `IndexEntry` entity. indexEntryCategoryColDesc :: Database.CDBI.Description.ColumnDescription String indexEntryCategoryColDesc = Database.CDBI.Description.ColDesc "\"IndexEntry\".\"Category\"" Database.CDBI.Connection.SQLTypeString (\category -> Database.CDBI.Description.sqlString category) (\category -> Database.CDBI.Description.fromStringOrNull category) --- The description of the database column `SourceDirs` of the `IndexEntry` entity. indexEntrySourceDirsColDesc :: Database.CDBI.Description.ColumnDescription String indexEntrySourceDirsColDesc = Database.CDBI.Description.ColDesc "\"IndexEntry\".\"SourceDirs\"" Database.CDBI.Connection.SQLTypeString (\sourceDirs -> Database.CDBI.Description.sqlString sourceDirs) (\sourceDirs -> Database.CDBI.Description.fromStringOrNull sourceDirs) --- The description of the database column `ExportedModules` of the `IndexEntry` entity. indexEntryExportedModulesColDesc :: Database.CDBI.Description.ColumnDescription String indexEntryExportedModulesColDesc = Database.CDBI.Description.ColDesc "\"IndexEntry\".\"ExportedModules\"" Database.CDBI.Connection.SQLTypeString (\exportedModules -> Database.CDBI.Description.sqlString exportedModules) (\exportedModules -> Database.CDBI.Description.fromStringOrNull exportedModules) --- The description of the database column `ExecutableSpec` of the `IndexEntry` entity. indexEntryExecutableSpecColDesc :: Database.CDBI.Description.ColumnDescription String indexEntryExecutableSpecColDesc = Database.CDBI.Description.ColDesc "\"IndexEntry\".\"ExecutableSpec\"" Database.CDBI.Connection.SQLTypeString (\executableSpec -> Database.CDBI.Description.sqlString executableSpec) (\executableSpec -> Database.CDBI.Description.fromStringOrNull executableSpec) --- Gets the attribute `Key` of the `IndexEntry` entity. indexEntryKey :: IndexEntry -> IndexEntryID indexEntryKey (IndexEntry a _ _ _ _ _ _ _ _ _) = a --- Gets the attribute `Name` of the `IndexEntry` entity. indexEntryName :: IndexEntry -> String indexEntryName (IndexEntry _ a _ _ _ _ _ _ _ _) = a --- Gets the attribute `Version` of the `IndexEntry` entity. indexEntryVersion :: IndexEntry -> String indexEntryVersion (IndexEntry _ _ a _ _ _ _ _ _ _) = a --- Gets the attribute `Dependencies` of the `IndexEntry` entity. indexEntryDependencies :: IndexEntry -> String indexEntryDependencies (IndexEntry _ _ _ a _ _ _ _ _ _) = a --- Gets the attribute `CompilerCompatibility` of the `IndexEntry` entity. indexEntryCompilerCompatibility :: IndexEntry -> String indexEntryCompilerCompatibility (IndexEntry _ _ _ _ a _ _ _ _ _) = a --- Gets the attribute `Synopsis` of the `IndexEntry` entity. indexEntrySynopsis :: IndexEntry -> String indexEntrySynopsis (IndexEntry _ _ _ _ _ a _ _ _ _) = a --- Gets the attribute `Category` of the `IndexEntry` entity. indexEntryCategory :: IndexEntry -> String indexEntryCategory (IndexEntry _ _ _ _ _ _ a _ _ _) = a --- Gets the attribute `SourceDirs` of the `IndexEntry` entity. indexEntrySourceDirs :: IndexEntry -> String indexEntrySourceDirs (IndexEntry _ _ _ _ _ _ _ a _ _) = a --- Gets the attribute `ExportedModules` of the `IndexEntry` entity. indexEntryExportedModules :: IndexEntry -> String indexEntryExportedModules (IndexEntry _ _ _ _ _ _ _ _ a _) = a --- Gets the attribute `ExecutableSpec` of the `IndexEntry` entity. indexEntryExecutableSpec :: IndexEntry -> String indexEntryExecutableSpec (IndexEntry _ _ _ _ _ _ _ _ _ a) = a --- Sets the attribute `Key` of the `IndexEntry` entity. setIndexEntryKey :: IndexEntry -> IndexEntryID -> IndexEntry setIndexEntryKey (IndexEntry _ b9 b8 b7 b6 b5 b4 b3 b2 b1) a = IndexEntry a b9 b8 b7 b6 b5 b4 b3 b2 b1 --- Sets the attribute `Name` of the `IndexEntry` entity. setIndexEntryName :: IndexEntry -> String -> IndexEntry setIndexEntryName (IndexEntry a2 _ b8 b7 b6 b5 b4 b3 b2 b1) a = IndexEntry a2 a b8 b7 b6 b5 b4 b3 b2 b1 --- Sets the attribute `Version` of the `IndexEntry` entity. setIndexEntryVersion :: IndexEntry -> String -> IndexEntry setIndexEntryVersion (IndexEntry a3 a2 _ b7 b6 b5 b4 b3 b2 b1) a = IndexEntry a3 a2 a b7 b6 b5 b4 b3 b2 b1 --- Sets the attribute `Dependencies` of the `IndexEntry` entity. setIndexEntryDependencies :: IndexEntry -> String -> IndexEntry setIndexEntryDependencies (IndexEntry a4 a3 a2 _ b6 b5 b4 b3 b2 b1) a = IndexEntry a4 a3 a2 a b6 b5 b4 b3 b2 b1 --- Sets the attribute `CompilerCompatibility` of the `IndexEntry` entity. setIndexEntryCompilerCompatibility :: IndexEntry -> String -> IndexEntry setIndexEntryCompilerCompatibility (IndexEntry a5 a4 a3 a2 _ b5 b4 b3 b2 b1) a = IndexEntry a5 a4 a3 a2 a b5 b4 b3 b2 b1 --- Sets the attribute `Synopsis` of the `IndexEntry` entity. setIndexEntrySynopsis :: IndexEntry -> String -> IndexEntry setIndexEntrySynopsis (IndexEntry a6 a5 a4 a3 a2 _ b4 b3 b2 b1) a = IndexEntry a6 a5 a4 a3 a2 a b4 b3 b2 b1 --- Sets the attribute `Category` of the `IndexEntry` entity. setIndexEntryCategory :: IndexEntry -> String -> IndexEntry setIndexEntryCategory (IndexEntry a7 a6 a5 a4 a3 a2 _ b3 b2 b1) a = IndexEntry a7 a6 a5 a4 a3 a2 a b3 b2 b1 --- Sets the attribute `SourceDirs` of the `IndexEntry` entity. setIndexEntrySourceDirs :: IndexEntry -> String -> IndexEntry setIndexEntrySourceDirs (IndexEntry a8 a7 a6 a5 a4 a3 a2 _ b2 b1) a = IndexEntry a8 a7 a6 a5 a4 a3 a2 a b2 b1 --- Sets the attribute `ExportedModules` of the `IndexEntry` entity. setIndexEntryExportedModules :: IndexEntry -> String -> IndexEntry setIndexEntryExportedModules (IndexEntry a9 a8 a7 a6 a5 a4 a3 a2 _ b1) a = IndexEntry a9 a8 a7 a6 a5 a4 a3 a2 a b1 --- Sets the attribute `ExecutableSpec` of the `IndexEntry` entity. setIndexEntryExecutableSpec :: IndexEntry -> String -> IndexEntry setIndexEntryExecutableSpec (IndexEntry a10 a9 a8 a7 a6 a5 a4 a3 a2 _) a = IndexEntry a10 a9 a8 a7 a6 a5 a4 a3 a2 a --- id-to-value function for entity `IndexEntry`. indexEntryID :: IndexEntryID -> Database.CDBI.Criteria.Value IndexEntryID indexEntryID (IndexEntryID key) = Database.CDBI.Criteria.idVal key --- id-to-int function for entity `IndexEntry`. indexEntryKeyToInt :: IndexEntryID -> Int indexEntryKeyToInt (IndexEntryID key) = key --- Shows the key of a `IndexEntry` entity as a string. --- This is useful if a textual representation of the key is necessary --- (e.g., as URL parameters in web pages), but it should no be used --- to store keys in other attributes! showIndexEntryKey :: IndexEntry -> String showIndexEntryKey entry = Database.CDBI.ER.showDatabaseKey "IndexEntry" indexEntryKeyToInt (indexEntryKey entry) --- Transforms a string into a key of a `IndexEntry` entity. --- Nothing is returned if the string does not represent a meaningful key. readIndexEntryKey :: String -> Maybe IndexEntryID readIndexEntryKey = Database.CDBI.ER.readDatabaseKey "IndexEntry" IndexEntryID --- Gets all `IndexEntry` entities. queryAllIndexEntrys :: Database.CDBI.Connection.DBAction [IndexEntry] queryAllIndexEntrys = Database.CDBI.ER.getAllEntries indexEntry_CDBI_Description --- Gets all `IndexEntry` entities satisfying a given predicate. queryCondIndexEntry :: (IndexEntry -> Bool) -> Database.CDBI.Connection.DBAction [IndexEntry] queryCondIndexEntry = Database.CDBI.ER.getCondEntries indexEntry_CDBI_Description --- Gets a `IndexEntry` entry by a given key. getIndexEntry :: IndexEntryID -> Database.CDBI.Connection.DBAction IndexEntry getIndexEntry = Database.CDBI.ER.getEntryWithKey indexEntry_CDBI_Description indexEntryColumnKey indexEntryID --- Inserts a new `IndexEntry` entity. newIndexEntry :: String -> String -> String -> String -> String -> String -> String -> String -> String -> Database.CDBI.Connection.DBAction IndexEntry newIndexEntry name_p version_p dependencies_p compilerCompatibility_p synopsis_p category_p sourceDirs_p exportedModules_p executableSpec_p = Database.CDBI.ER.insertNewEntry indexEntry_CDBI_Description setIndexEntryKey IndexEntryID (IndexEntry (IndexEntryID 0) name_p version_p dependencies_p compilerCompatibility_p synopsis_p category_p sourceDirs_p exportedModules_p executableSpec_p) --- Deletes an existing `IndexEntry` entry by its key. deleteIndexEntry :: IndexEntry -> Database.CDBI.Connection.DBAction () deleteIndexEntry = Database.CDBI.ER.deleteEntry indexEntry_CDBI_Description indexEntryColumnKey (indexEntryID . indexEntryKey) --- Updates an existing `IndexEntry` entry by its key. updateIndexEntry :: IndexEntry -> Database.CDBI.Connection.DBAction () updateIndexEntry = Database.CDBI.ER.updateEntry indexEntry_CDBI_Description --- Generates a new database (name provided as the parameter) and --- creates its schema. createNewDB :: String -> IO () createNewDB dbfile = do conn <- Database.CDBI.Connection.connectSQLite dbfile Database.CDBI.Connection.writeConnection cstr conn Database.CDBI.Connection.disconnect conn where cstr = unlines ["create table 'IndexEntry'('Key' integer primary key ,'Name' string not null ,'Version' string not null ,'Dependencies' string ,'CompilerCompatibility' string ,'Synopsis' string ,'Category' string ,'SourceDirs' string ,'ExportedModules' string ,'ExecutableSpec' string);"] --- Saves complete database as term files into an existing directory --- provided as a parameter. saveDBTo :: String -> IO () saveDBTo dir = do Database.CDBI.ER.saveDBTerms indexEntry_CDBI_Description sqliteDBFile dir --- Restores complete database from term files which are stored --- in a directory provided as a parameter. restoreDBFrom :: String -> IO () restoreDBFrom dir = do Database.CDBI.ER.restoreDBTerms indexEntry_CDBI_Description sqliteDBFile dir --- Runs a DB action (typically a query). runQ :: Database.CDBI.Connection.DBAction a -> IO a runQ = Database.CDBI.ER.runQueryOnDB sqliteDBFile --- Runs a DB action as a transaction. runT :: Database.CDBI.Connection.DBAction a -> IO (Database.CDBI.Connection.SQLResult a) runT = Database.CDBI.ER.runTransactionOnDB sqliteDBFile --- Runs a DB action as a transaction. Emits an error in case of failure. runJustT :: Database.CDBI.Connection.DBAction a -> IO a runJustT = Database.CDBI.ER.runJustTransactionOnDB sqliteDBFile curry-tools-v3.3.0/cpm/src/CPM/Repository/RepositoryDB_SQLCode.info000066400000000000000000000017411377556325500251520ustar00rootroot00000000000000SQLParserInfoType.PInfo "REPOSITORY_CACHE.db" "CPM.Repository.RepositoryDB" [] [("indexEntryKey",False) ,("indexEntryName",False) ,("indexEntryVersion",False) ,("indexEntryDependencies",True) ,("indexEntryCompilerCompatibility",True) ,("indexEntrySynopsis",True) ,("indexEntryCategory",True) ,("indexEntrySourceDirs",True) ,("indexEntryExportedModules",True) ,("indexEntryExecutableSpec",True)] [("indexentry" ,("IndexEntry" ,["Key" ,"Name" ,"Version" ,"Dependencies" ,"CompilerCompatibility" ,"Synopsis" ,"Category" ,"SourceDirs" ,"ExportedModules" ,"ExecutableSpec"]))] [("indexEntryKey","IndexEntry") ,("indexEntryName","string") ,("indexEntryVersion","string") ,("indexEntryDependencies","string") ,("indexEntryCompilerCompatibility","string") ,("indexEntrySynopsis","string") ,("indexEntryCategory","string") ,("indexEntrySourceDirs","string") ,("indexEntryExportedModules","string") ,("indexEntryExecutableSpec","string")] curry-tools-v3.3.0/cpm/src/CPM/Repository/Select.curry000066400000000000000000000455451377556325500227150ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some queries on the repository cache. --- --- @author Michael Hanus --- @version December 2020 ------------------------------------------------------------------------------ module CPM.Repository.Select ( searchNameSynopsisModules , searchExportedModules, searchExecutable , getRepositoryWithNameVersionSynopsis , getRepositoryWithNameVersionSynopsisDeps , getRepositoryWithNameVersionCategory , getBaseRepository , getRepoForPackageSpec , getRepoForPackages , getAllPackageVersions, getPackageVersion , addPackageToRepositoryCache , updatePackageInRepositoryCache ) where import Data.Char ( toLower ) import Data.List ( isInfixOf ) import Data.Maybe ( maybeToList ) import System.Directory ( doesFileExist ) import ReadShowTerm import Database.CDBI.ER import Database.CDBI.Connection import CPM.Config ( Config ) import CPM.ErrorLogger import CPM.FileUtil ( ifFileExists ) import CPM.Repository.RepositoryDB import CPM.Repository.CacheFile ( readRepository ) import CPM.Repository.CacheDB import CPM.Package import CPM.Repository --- Runs a query on the repository cache DB and show debug infos. runQuery :: Config -> DBAction a -> ErrorLogger a runQuery cfg dbact = do warnIfRepositoryOld cfg let dbfile = repositoryCacheDB cfg logDebug $ "Reading repository database '" ++ dbfile ++ "'..." result <- liftIOEL $ runQueryOnDB dbfile dbact logDebug $ "Finished reading repository database" return result --- Returns the packages of the repository containing a given string --- in the name, synopsis, or exported modules. --- In each package, the name, version, synopsis, and compilerCompatibility --- is set. searchNameSynopsisModules :: Config -> String -> ErrorLogger [Package] searchNameSynopsisModules cfg pat = runQuery cfg $ fmap (map toPackage) (Database.CDBI.ER.getColumnFourTuple [] [Database.CDBI.ER.FourCS Database.CDBI.ER.All (Database.CDBI.ER.fourCol (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryNameColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryVersionColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntrySynopsisColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryCompilerCompatibilityColDesc 0 Database.CDBI.ER.none)) (Database.CDBI.ER.TC CPM.Repository.RepositoryDB.indexEntryTable 0 Nothing) (Database.CDBI.ER.Criteria (Database.CDBI.ER.Or [Database.CDBI.ER.like (Database.CDBI.ER.colNum CPM.Repository.RepositoryDB.indexEntryColumnName 0) (Database.CDBI.ER.string (pattern)) ,Database.CDBI.ER.Or [Database.CDBI.ER.like (Database.CDBI.ER.colNum CPM.Repository.RepositoryDB.indexEntryColumnSynopsis 0) (Database.CDBI.ER.string (pattern)) ,Database.CDBI.ER.like (Database.CDBI.ER.colNum CPM.Repository.RepositoryDB.indexEntryColumnExportedModules 0) (Database.CDBI.ER.string (pattern))]]) Nothing)] [] Nothing) where pattern = "%" ++ pat ++ "%" toPackage (nm,vs,syn,cmp) = emptyPackage { name = nm , version = pkgRead vs , synopsis = syn , compilerCompatibility = pkgRead cmp } --- Returns the packages of the repository containing a given module --- in the list of exported modules. --- In each package, the name, version, synopsis, compilerCompatibility, --- and exportedModules is set. searchExportedModules :: Config -> String -> ErrorLogger [Package] searchExportedModules cfg pat = (queryDBorCache cfg True $ fmap (pkgsToRepository . map toPackage) (Database.CDBI.ER.getColumnFiveTuple [] [Database.CDBI.ER.FiveCS Database.CDBI.ER.All (Database.CDBI.ER.fiveCol (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryNameColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryVersionColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntrySynopsisColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryCompilerCompatibilityColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryExportedModulesColDesc 0 Database.CDBI.ER.none)) (Database.CDBI.ER.TC CPM.Repository.RepositoryDB.indexEntryTable 0 Nothing) (Database.CDBI.ER.Criteria (Database.CDBI.ER.like (Database.CDBI.ER.colNum CPM.Repository.RepositoryDB.indexEntryColumnExportedModules 0) (Database.CDBI.ER.string (pattern))) Nothing)] [] Nothing) ) >>= return . filterExpModules . allPackages where pattern = "%" ++ pat ++ "%" lpat = map toLower pat filterExpModules = filter (\p -> any (\m -> lpat `isInfixOf` (map toLower m)) (exportedModules p)) toPackage (nm,vs,syn,cmp,exps) = emptyPackage { name = nm , version = pkgRead vs , synopsis = syn , compilerCompatibility = pkgRead cmp , exportedModules = pkgRead exps } --- Returns the packages of the repository containing a given string --- in the name of the executable. --- In each package, the name, version, synopsis, compilerCompatibility, --- and executableSpec is set. searchExecutable :: Config -> String -> ErrorLogger [Package] searchExecutable cfg pat = (queryDBorCache cfg True $ fmap (pkgsToRepository . map toPackage) (Database.CDBI.ER.getColumnFiveTuple [] [Database.CDBI.ER.FiveCS Database.CDBI.ER.All (Database.CDBI.ER.fiveCol (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryNameColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryVersionColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntrySynopsisColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryCompilerCompatibilityColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryExecutableSpecColDesc 0 Database.CDBI.ER.none)) (Database.CDBI.ER.TC CPM.Repository.RepositoryDB.indexEntryTable 0 Nothing) (Database.CDBI.ER.Criteria (Database.CDBI.ER.like (Database.CDBI.ER.colNum CPM.Repository.RepositoryDB.indexEntryColumnExecutableSpec 0) (Database.CDBI.ER.string (pattern))) Nothing)] [] Nothing) ) >>= return . filterExec . allPackages where pattern = "%" ++ pat ++ "%" lpat = map toLower pat filterExec = filter (\p -> lpat `isInfixOf` (map toLower $ execOfPackage p)) toPackage (nm,vs,syn,cmp,exec) = emptyPackage { name = nm , version = pkgRead vs , synopsis = syn , compilerCompatibility = pkgRead cmp , executableSpec = maybeToList (pkgRead exec) } --- Returns the complete repository where in each package --- the name, version, synopsis, and compilerCompatibility is set. getRepositoryWithNameVersionSynopsis :: Config -> ErrorLogger Repository getRepositoryWithNameVersionSynopsis cfg = queryDBorCache cfg True $ fmap (pkgsToRepository . map toPackage) (Database.CDBI.ER.getColumnFourTuple [] [Database.CDBI.ER.FourCS Database.CDBI.ER.All (Database.CDBI.ER.fourCol (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryNameColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryVersionColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntrySynopsisColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryCompilerCompatibilityColDesc 0 Database.CDBI.ER.none)) (Database.CDBI.ER.TC CPM.Repository.RepositoryDB.indexEntryTable 0 Nothing) (Database.CDBI.ER.Criteria Database.CDBI.ER.None Nothing)] [] Nothing) where toPackage (nm,vs,syn,cmp) = emptyPackage { name = nm , version = pkgRead vs , synopsis = syn , compilerCompatibility = pkgRead cmp } --- Returns the complete repository where in each package --- the name, version, synopsis, dependencies and compilerCompatibility is set. getRepositoryWithNameVersionSynopsisDeps :: Config -> ErrorLogger Repository getRepositoryWithNameVersionSynopsisDeps cfg = queryDBorCache cfg True $ fmap (pkgsToRepository . map toPackage) (Database.CDBI.ER.getColumnFiveTuple [] [Database.CDBI.ER.FiveCS Database.CDBI.ER.All (Database.CDBI.ER.fiveCol (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryNameColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryVersionColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntrySynopsisColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryDependenciesColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryCompilerCompatibilityColDesc 0 Database.CDBI.ER.none)) (Database.CDBI.ER.TC CPM.Repository.RepositoryDB.indexEntryTable 0 Nothing) (Database.CDBI.ER.Criteria Database.CDBI.ER.None Nothing)] [] Nothing) where toPackage (nm,vs,syn,deps,cmp) = emptyPackage { name = nm , version = pkgRead vs , synopsis = syn , dependencies = pkgRead deps , compilerCompatibility = pkgRead cmp } --- Returns the complete repository where in each package --- the name, version, category, and compilerCompatibility is set. getRepositoryWithNameVersionCategory :: Config -> ErrorLogger Repository getRepositoryWithNameVersionCategory cfg = queryDBorCache cfg True $ fmap (pkgsToRepository . map toPackage) (Database.CDBI.ER.getColumnFourTuple [] [Database.CDBI.ER.FourCS Database.CDBI.ER.All (Database.CDBI.ER.fourCol (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryNameColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryVersionColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryCategoryColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryCompilerCompatibilityColDesc 0 Database.CDBI.ER.none)) (Database.CDBI.ER.TC CPM.Repository.RepositoryDB.indexEntryTable 0 Nothing) (Database.CDBI.ER.Criteria Database.CDBI.ER.None Nothing)] [] Nothing) where toPackage (nm,vs,cats,cmp) = emptyPackage { name = nm , version = pkgRead vs , category = pkgRead cats , compilerCompatibility = pkgRead cmp } --- Returns the complete repository where in each package --- the name, version, dependencies, and compilerCompatibility is set. --- The information is read either from the cache DB or from the cache file. getBaseRepository :: Config -> ErrorLogger Repository getBaseRepository cfg = queryDBorCache cfg False $ fmap (pkgsToRepository . map toBasePackage) (Database.CDBI.ER.getColumnFourTuple [] [Database.CDBI.ER.FourCS Database.CDBI.ER.All (Database.CDBI.ER.fourCol (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryNameColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryVersionColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryDependenciesColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryCompilerCompatibilityColDesc 0 Database.CDBI.ER.none)) (Database.CDBI.ER.TC CPM.Repository.RepositoryDB.indexEntryTable 0 Nothing) (Database.CDBI.ER.Criteria Database.CDBI.ER.None Nothing)] [] Nothing) --- Translate the (Name|Version|Dependencies|CompilerCompatibility) columns --- of the cache DB into a package where the name, version, dependencies, --- and compilerCompatibility is set. toBasePackage :: (String,String,String,String) -> Package toBasePackage (nm,vs,deps,cmp) = emptyPackage { name = nm , version = pkgRead vs , dependencies = pkgRead deps , compilerCompatibility = pkgRead cmp } --- Returns the repository containing only packages with a given name where --- in each package the name, version, dependencies, and compilerCompatibility --- is set. --- The information is read either from the cache DB or from the cache file. getRepoPackagesWithName :: Config -> String -> ErrorLogger Repository getRepoPackagesWithName cfg pn = queryDBorCache cfg False $ fmap (pkgsToRepository . map toBasePackage) (Database.CDBI.ER.getColumnFourTuple [] [Database.CDBI.ER.FourCS Database.CDBI.ER.All (Database.CDBI.ER.fourCol (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryNameColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryVersionColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryDependenciesColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryCompilerCompatibilityColDesc 0 Database.CDBI.ER.none)) (Database.CDBI.ER.TC CPM.Repository.RepositoryDB.indexEntryTable 0 Nothing) (Database.CDBI.ER.Criteria (Database.CDBI.ER.equal (Database.CDBI.ER.colNum CPM.Repository.RepositoryDB.indexEntryColumnName 0) (Database.CDBI.ER.string (pn))) Nothing)] [] Nothing) --- Returns the repository containing all packages and dependencies --- (in all versions) mentioned in the given package specification. --- In each package the name, version, dependencies, and compilerCompatibility --- is set. --- The information is read either from the cache DB or from the cache file. getRepoForPackageSpec :: Config -> Package -> ErrorLogger Repository getRepoForPackageSpec cfg pkgspec = getRepoForPackages cfg (name pkgspec : dependencyNames pkgspec) --- Returns the repository containing only packages of the second argument --- and all the packages on which they depend (including all versions). --- In each package the name, version, dependencies, and compilerCompatibility --- is set. --- The information is read either from the cache DB or from the cache file. getRepoForPackages :: Config -> [String] -> ErrorLogger Repository getRepoForPackages cfg pkgnames = do dbexists <- liftIOEL $ doesFileExist (repositoryCacheDB cfg) if dbexists then do warnIfRepositoryOld cfg let dbfile = repositoryCacheDB cfg logDebug $ "Reading repository database '" ++ dbfile ++ "'..." repo <- queryPackagesFromDB pkgnames [] [] logDebug $ "Finished reading repository database" return repo else readRepository cfg False where queryPackagesFromDB [] _ pkgs = return $ pkgsToRepository pkgs queryPackagesFromDB (pn:pns) lpns pkgs | pn `elem` lpns = queryPackagesFromDB pns lpns pkgs | otherwise = do logDebug $ "Reading package versions of " ++ pn pnpkgs <- liftIOEL $ queryPackage pn let newdeps = concatMap dependencyNames pnpkgs queryPackagesFromDB (newdeps++pns) (pn:lpns) (pnpkgs++pkgs) queryPackage pn = runQueryOnDB (repositoryCacheDB cfg) $ fmap (map toBasePackage) (Database.CDBI.ER.getColumnFourTuple [] [Database.CDBI.ER.FourCS Database.CDBI.ER.All (Database.CDBI.ER.fourCol (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryNameColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryVersionColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryDependenciesColDesc 0 Database.CDBI.ER.none) (Database.CDBI.ER.singleCol CPM.Repository.RepositoryDB.indexEntryCompilerCompatibilityColDesc 0 Database.CDBI.ER.none)) (Database.CDBI.ER.TC CPM.Repository.RepositoryDB.indexEntryTable 0 Nothing) (Database.CDBI.ER.Criteria (Database.CDBI.ER.equal (Database.CDBI.ER.colNum CPM.Repository.RepositoryDB.indexEntryColumnName 0) (Database.CDBI.ER.string (pn))) Nothing)] [] Nothing) --- Retrieves all versions of a package with a given name from the repository. --- --- @param cfg - the current CPM configuration --- @param pkgname - the package name to be retrieved --- @param pre - should pre-release versions be included? getAllPackageVersions :: Config -> String -> Bool -> ErrorLogger [Package] getAllPackageVersions cfg pkgname pre = do repo <- getRepoPackagesWithName cfg pkgname return (findAllVersions repo pkgname pre) --- Retrieves a package with a given name and version from the repository. --- --- @param cfg - the current CPM configuration --- @param pkgname - the package name to be retrieved --- @param ver - the requested version of the package getPackageVersion :: Config -> String -> Version -> ErrorLogger (Maybe Package) getPackageVersion cfg pkgname ver = do repo <- getRepoPackagesWithName cfg pkgname return (findVersion repo pkgname ver) --- If the cache DB exists, run the DB query to get the repository, --- otherwise read the (small or large) repository cache file. queryDBorCache :: Config -> Bool -> DBAction Repository -> ErrorLogger Repository queryDBorCache cfg large dbaction = do dbexists <- liftIOEL $ doesFileExist (repositoryCacheDB cfg) if dbexists then runQuery cfg dbaction else readRepository cfg large --- Reads an unqualified Curry term w.r.t. the module `CPM.Package`. pkgRead :: String -> a pkgRead = readUnqualifiedTerm ["CPM.Package","Prelude"] ------------------------------------------------------------------------------ --- Adds a new package to the repository cache. --- In the file-based implementation, we simply clean the cache files. addPackageToRepositoryCache :: Config -> Package -> ErrorLogger () addPackageToRepositoryCache cfg pkg = do dbexists <- liftIOEL $ doesFileExist (repositoryCacheDB cfg) if dbexists then addPackagesToRepositoryDB cfg True [Left pkg] else cleanRepositoryCache cfg >> return () --- Updates an existing package in the repository cache. --- In the file-based implementation, we simply clean the cache files. updatePackageInRepositoryCache :: Config -> Package -> ErrorLogger () updatePackageInRepositoryCache cfg pkg = do dbexists <- liftIOEL $ doesFileExist (repositoryCacheDB cfg) if dbexists then removePackageFromRepositoryDB cfg pkg >> addPackagesToRepositoryDB cfg True [Left pkg] else cleanRepositoryCache cfg >> return () --- Removes a package from the repository cache DB. removePackageFromRepositoryDB :: Config -> Package -> ErrorLogger () removePackageFromRepositoryDB cfg pkg = runQuery cfg (Database.CDBI.ER.deleteEntries CPM.Repository.RepositoryDB.indexEntry_CDBI_Description (Just (Database.CDBI.ER.And [Database.CDBI.ER.equal (Database.CDBI.ER.colNum CPM.Repository.RepositoryDB.indexEntryColumnName 0) (Database.CDBI.ER.string (name pkg)) ,Database.CDBI.ER.equal (Database.CDBI.ER.colNum CPM.Repository.RepositoryDB.indexEntryColumnVersion 0) (Database.CDBI.ER.string (showTerm (version pkg)))]))) ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/src/CPM/Repository/Select_ORG.curry000066400000000000000000000307541377556325500234200ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some queries on the repository cache. --- --- @author Michael Hanus --- @version December 2020 ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -F --pgmF=currypp --optF=foreigncode --optF=-o #-} module CPM.Repository.Select ( searchNameSynopsisModules , searchExportedModules, searchExecutable , getRepositoryWithNameVersionSynopsis , getRepositoryWithNameVersionSynopsisDeps , getRepositoryWithNameVersionCategory , getBaseRepository , getRepoForPackageSpec , getRepoForPackages , getAllPackageVersions, getPackageVersion , addPackageToRepositoryCache , updatePackageInRepositoryCache ) where import Data.Char ( toLower ) import Data.List ( isInfixOf ) import Data.Maybe ( maybeToList ) import System.Directory ( doesFileExist ) import ReadShowTerm import Database.CDBI.ER import Database.CDBI.Connection import CPM.Config ( Config ) import CPM.ErrorLogger import CPM.FileUtil ( ifFileExists ) import CPM.Repository.RepositoryDB import CPM.Repository.CacheFile ( readRepository ) import CPM.Repository.CacheDB import CPM.Package import CPM.Repository --- Runs a query on the repository cache DB and show debug infos. runQuery :: Config -> DBAction a -> ErrorLogger a runQuery cfg dbact = do warnIfRepositoryOld cfg let dbfile = repositoryCacheDB cfg logDebug $ "Reading repository database '" ++ dbfile ++ "'..." result <- liftIOEL $ runQueryOnDB dbfile dbact logDebug $ "Finished reading repository database" return result --- Returns the packages of the repository containing a given string --- in the name, synopsis, or exported modules. --- In each package, the name, version, synopsis, and compilerCompatibility --- is set. searchNameSynopsisModules :: Config -> String -> ErrorLogger [Package] searchNameSynopsisModules cfg pat = runQuery cfg $ fmap (map toPackage) ``sql* Select Name, Version, Synopsis, CompilerCompatibility From IndexEntry Where Name like {pattern} Or Synopsis like {pattern} Or ExportedModules like {pattern};'' where pattern = "%" ++ pat ++ "%" toPackage (nm,vs,syn,cmp) = emptyPackage { name = nm , version = pkgRead vs , synopsis = syn , compilerCompatibility = pkgRead cmp } --- Returns the packages of the repository containing a given module --- in the list of exported modules. --- In each package, the name, version, synopsis, compilerCompatibility, --- and exportedModules is set. searchExportedModules :: Config -> String -> ErrorLogger [Package] searchExportedModules cfg pat = (queryDBorCache cfg True $ fmap (pkgsToRepository . map toPackage) ``sql* Select Name, Version, Synopsis, CompilerCompatibility, ExportedModules From IndexEntry Where ExportedModules like {pattern};'' ) >>= return . filterExpModules . allPackages where pattern = "%" ++ pat ++ "%" lpat = map toLower pat filterExpModules = filter (\p -> any (\m -> lpat `isInfixOf` (map toLower m)) (exportedModules p)) toPackage (nm,vs,syn,cmp,exps) = emptyPackage { name = nm , version = pkgRead vs , synopsis = syn , compilerCompatibility = pkgRead cmp , exportedModules = pkgRead exps } --- Returns the packages of the repository containing a given string --- in the name of the executable. --- In each package, the name, version, synopsis, compilerCompatibility, --- and executableSpec is set. searchExecutable :: Config -> String -> ErrorLogger [Package] searchExecutable cfg pat = (queryDBorCache cfg True $ fmap (pkgsToRepository . map toPackage) ``sql* Select Name, Version, Synopsis, CompilerCompatibility, ExecutableSpec From IndexEntry Where ExecutableSpec like {pattern};'' ) >>= return . filterExec . allPackages where pattern = "%" ++ pat ++ "%" lpat = map toLower pat filterExec = filter (\p -> lpat `isInfixOf` (map toLower $ execOfPackage p)) toPackage (nm,vs,syn,cmp,exec) = emptyPackage { name = nm , version = pkgRead vs , synopsis = syn , compilerCompatibility = pkgRead cmp , executableSpec = maybeToList (pkgRead exec) } --- Returns the complete repository where in each package --- the name, version, synopsis, and compilerCompatibility is set. getRepositoryWithNameVersionSynopsis :: Config -> ErrorLogger Repository getRepositoryWithNameVersionSynopsis cfg = queryDBorCache cfg True $ fmap (pkgsToRepository . map toPackage) ``sql* Select Name, Version, Synopsis, CompilerCompatibility From IndexEntry;'' where toPackage (nm,vs,syn,cmp) = emptyPackage { name = nm , version = pkgRead vs , synopsis = syn , compilerCompatibility = pkgRead cmp } --- Returns the complete repository where in each package --- the name, version, synopsis, dependencies and compilerCompatibility is set. getRepositoryWithNameVersionSynopsisDeps :: Config -> ErrorLogger Repository getRepositoryWithNameVersionSynopsisDeps cfg = queryDBorCache cfg True $ fmap (pkgsToRepository . map toPackage) ``sql* Select Name, Version, Synopsis, Dependencies, CompilerCompatibility From IndexEntry;'' where toPackage (nm,vs,syn,deps,cmp) = emptyPackage { name = nm , version = pkgRead vs , synopsis = syn , dependencies = pkgRead deps , compilerCompatibility = pkgRead cmp } --- Returns the complete repository where in each package --- the name, version, category, and compilerCompatibility is set. getRepositoryWithNameVersionCategory :: Config -> ErrorLogger Repository getRepositoryWithNameVersionCategory cfg = queryDBorCache cfg True $ fmap (pkgsToRepository . map toPackage) ``sql* Select Name, Version, Category, CompilerCompatibility From IndexEntry;'' where toPackage (nm,vs,cats,cmp) = emptyPackage { name = nm , version = pkgRead vs , category = pkgRead cats , compilerCompatibility = pkgRead cmp } --- Returns the complete repository where in each package --- the name, version, dependencies, and compilerCompatibility is set. --- The information is read either from the cache DB or from the cache file. getBaseRepository :: Config -> ErrorLogger Repository getBaseRepository cfg = queryDBorCache cfg False $ fmap (pkgsToRepository . map toBasePackage) ``sql* Select Name, Version, Dependencies, CompilerCompatibility From IndexEntry;'' --- Translate the (Name|Version|Dependencies|CompilerCompatibility) columns --- of the cache DB into a package where the name, version, dependencies, --- and compilerCompatibility is set. toBasePackage :: (String,String,String,String) -> Package toBasePackage (nm,vs,deps,cmp) = emptyPackage { name = nm , version = pkgRead vs , dependencies = pkgRead deps , compilerCompatibility = pkgRead cmp } --- Returns the repository containing only packages with a given name where --- in each package the name, version, dependencies, and compilerCompatibility --- is set. --- The information is read either from the cache DB or from the cache file. getRepoPackagesWithName :: Config -> String -> ErrorLogger Repository getRepoPackagesWithName cfg pn = queryDBorCache cfg False $ fmap (pkgsToRepository . map toBasePackage) ``sql* Select Name, Version, Dependencies, CompilerCompatibility From IndexEntry Where Name = {pn} ;'' --- Returns the repository containing all packages and dependencies --- (in all versions) mentioned in the given package specification. --- In each package the name, version, dependencies, and compilerCompatibility --- is set. --- The information is read either from the cache DB or from the cache file. getRepoForPackageSpec :: Config -> Package -> ErrorLogger Repository getRepoForPackageSpec cfg pkgspec = getRepoForPackages cfg (name pkgspec : dependencyNames pkgspec) --- Returns the repository containing only packages of the second argument --- and all the packages on which they depend (including all versions). --- In each package the name, version, dependencies, and compilerCompatibility --- is set. --- The information is read either from the cache DB or from the cache file. getRepoForPackages :: Config -> [String] -> ErrorLogger Repository getRepoForPackages cfg pkgnames = do dbexists <- liftIOEL $ doesFileExist (repositoryCacheDB cfg) if dbexists then do warnIfRepositoryOld cfg let dbfile = repositoryCacheDB cfg logDebug $ "Reading repository database '" ++ dbfile ++ "'..." repo <- queryPackagesFromDB pkgnames [] [] logDebug $ "Finished reading repository database" return repo else readRepository cfg False where queryPackagesFromDB [] _ pkgs = return $ pkgsToRepository pkgs queryPackagesFromDB (pn:pns) lpns pkgs | pn `elem` lpns = queryPackagesFromDB pns lpns pkgs | otherwise = do logDebug $ "Reading package versions of " ++ pn pnpkgs <- liftIOEL $ queryPackage pn let newdeps = concatMap dependencyNames pnpkgs queryPackagesFromDB (newdeps++pns) (pn:lpns) (pnpkgs++pkgs) queryPackage pn = runQueryOnDB (repositoryCacheDB cfg) $ fmap (map toBasePackage) ``sql* Select Name, Version, Dependencies, CompilerCompatibility From IndexEntry Where Name = {pn} ;'' --- Retrieves all versions of a package with a given name from the repository. --- --- @param cfg - the current CPM configuration --- @param pkgname - the package name to be retrieved --- @param pre - should pre-release versions be included? getAllPackageVersions :: Config -> String -> Bool -> ErrorLogger [Package] getAllPackageVersions cfg pkgname pre = do repo <- getRepoPackagesWithName cfg pkgname return (findAllVersions repo pkgname pre) --- Retrieves a package with a given name and version from the repository. --- --- @param cfg - the current CPM configuration --- @param pkgname - the package name to be retrieved --- @param ver - the requested version of the package getPackageVersion :: Config -> String -> Version -> ErrorLogger (Maybe Package) getPackageVersion cfg pkgname ver = do repo <- getRepoPackagesWithName cfg pkgname return (findVersion repo pkgname ver) --- If the cache DB exists, run the DB query to get the repository, --- otherwise read the (small or large) repository cache file. queryDBorCache :: Config -> Bool -> DBAction Repository -> ErrorLogger Repository queryDBorCache cfg large dbaction = do dbexists <- liftIOEL $ doesFileExist (repositoryCacheDB cfg) if dbexists then runQuery cfg dbaction else readRepository cfg large --- Reads an unqualified Curry term w.r.t. the module `CPM.Package`. pkgRead :: String -> a pkgRead = readUnqualifiedTerm ["CPM.Package","Prelude"] ------------------------------------------------------------------------------ --- Adds a new package to the repository cache. --- In the file-based implementation, we simply clean the cache files. addPackageToRepositoryCache :: Config -> Package -> ErrorLogger () addPackageToRepositoryCache cfg pkg = do dbexists <- liftIOEL $ doesFileExist (repositoryCacheDB cfg) if dbexists then addPackagesToRepositoryDB cfg True [Left pkg] else cleanRepositoryCache cfg >> return () --- Updates an existing package in the repository cache. --- In the file-based implementation, we simply clean the cache files. updatePackageInRepositoryCache :: Config -> Package -> ErrorLogger () updatePackageInRepositoryCache cfg pkg = do dbexists <- liftIOEL $ doesFileExist (repositoryCacheDB cfg) if dbexists then removePackageFromRepositoryDB cfg pkg >> addPackagesToRepositoryDB cfg True [Left pkg] else cleanRepositoryCache cfg >> return () --- Removes a package from the repository cache DB. removePackageFromRepositoryDB :: Config -> Package -> ErrorLogger () removePackageFromRepositoryDB cfg pkg = runQuery cfg ``sql* Delete From IndexEntry Where Name = {name pkg} And Version = {showTerm (version pkg)};'' ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/src/CPM/Repository/Update.curry000066400000000000000000000135351377556325500227120ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module implements operations to update and change the --- package repository, i.e., the index of all packages known --- to the package manager. ------------------------------------------------------------------------------ module CPM.Repository.Update ( addPackageToRepository, updateRepository ) where import System.Directory import System.FilePath import System.Process ( system ) import Data.List ( isSuffixOf ) import Control.Monad import CPM.Config ( Config, packageInstallDir, packageIndexURLs , repositoryDir ) import CPM.ErrorLogger import CPM.Package import CPM.Package.Helpers ( cleanPackage ) import CPM.FileUtil ( copyDirectory, inDirectory, quote , recreateDirectory, removeDirectoryComplete ) import CPM.Repository import CPM.Repository.CacheDB ( tryInstallRepositoryDB ) import CPM.Repository.Select ( addPackageToRepositoryCache , updatePackageInRepositoryCache ) ------------------------------------------------------------------------------ --- Updates the package index from the central Git repository. --- If the second argument is `True`, also the global package cache --- is cleaned in order to support downloading the newest versions. --- If the third argument is `True`, the global package index is recreated --- by downloading it from the central repository. --- If the fourth argument is `True`, the package database is created --- by reading the CSV file `REPOSITORY_CACHE.csv` downloaded from --- the tar files URL, otherwise by reading all package specifications. --- If the fifth argument is `True`, also a CSV file containing the --- database entries is written. updateRepository :: Config -> Bool -> Bool -> Bool -> Bool -> ErrorLogger () updateRepository cfg cleancache download usecache writecsv = do cleanRepositoryCache cfg when cleancache $ do logDebug $ "Deleting global package cache: '" ++ packageInstallDir cfg ++ "'" liftIOEL $ removeDirectoryComplete $ packageInstallDir cfg logDebug $ "Recreating package index: '" ++ repositoryDir cfg ++ "'" if download then do liftIOEL $ recreateDirectory $ repositoryDir cfg c <- inDirectoryEL (repositoryDir cfg) (tryDownload (packageIndexURLs cfg)) if c == 0 then finishUpdate else fail $ "Failed to update package index, return code " ++ show c else tryInstallRepositoryDB cfg usecache writecsv where tryDownload [] = return 1 tryDownload (url:urls) = do c <- downloadCommand url if c == 0 then return 0 else tryDownload urls downloadCommand piurl | ".git" `isSuffixOf` piurl = execQuietCmd $ \q -> unwords ["git clone", q, quote piurl, "."] | ".tar" `isSuffixOf` piurl = do let tarfile = "INDEX.tar" c1 <- showExecCmd $ unwords ["curl", "-s", "-o", tarfile, quote piurl] c2 <- showExecCmd $ unwords ["tar", "-xf", tarfile] liftIOEL $ removeFile tarfile return (c1+c2) | ".tar.gz" `isSuffixOf` piurl = do let tarfile = "INDEX.tar.gz" c1 <- showExecCmd $ unwords ["curl", "-s", "-o", tarfile, quote piurl] c2 <- showExecCmd $ unwords ["tar", "-xzf", tarfile] liftIOEL $ removeFile tarfile return (c1+c2) | otherwise = do logError $ "Unknown kind of package index URL: " ++ piurl return 1 finishUpdate = do liftIOEL $ setLastUpdate cfg cleanRepositoryCache cfg logInfo "Successfully downloaded repository index" tryInstallRepositoryDB cfg usecache writecsv --- Sets the date of the last update by touching README.md. setLastUpdate :: Config -> IO () setLastUpdate cfg = system (unwords ["touch", repositoryDir cfg "README.md"]) >> return () ------------------------------------------------------------------------------ --- Adds a package stored in the given directory to the repository index. --- If the argument `force` is true, overwrite an already existing package. --- If the argument `cpdir` is true, copy also the complete directory --- into the local package installation store. addPackageToRepository :: Config -> String -> Bool -> Bool -> ErrorLogger () addPackageToRepository cfg pkgdir force cpdir = do dirExists <- liftIOEL $ doesDirectoryExist pkgdir if dirExists then do pkgSpec <- loadPackageSpec pkgdir copyPackage pkgSpec logInfo $ "Package in directory '" ++ pkgdir ++ "' installed into local repository" else logCritical $ "Directory '" ++ pkgdir ++ "' does not exist." where copyPackage pkg = do let pkgIndexDir = name pkg showVersion (version pkg) pkgRepositoryDir = repositoryDir cfg pkgIndexDir pkgInstallDir = packageInstallDir cfg packageId pkg exrepodir <- liftIOEL $ doesDirectoryExist pkgRepositoryDir when (exrepodir && not force) $ error $ "Package repository directory '" ++ pkgRepositoryDir ++ "' already exists!\n" expkgdir <- liftIOEL $ doesDirectoryExist pkgInstallDir when expkgdir $ if force then liftIOEL $ removeDirectoryComplete pkgInstallDir else error $ "Package installation directory '" ++ pkgInstallDir ++ "' already exists!\n" logInfo $ "Create directory: " ++ pkgRepositoryDir liftIOEL $ do createDirectoryIfMissing True pkgRepositoryDir copyFile (pkgdir "package.json") (pkgRepositoryDir "package.json") when cpdir $ do liftIOEL $ copyDirectory pkgdir pkgInstallDir inDirectoryEL pkgInstallDir $ cleanPackage cfg Debug if exrepodir then updatePackageInRepositoryCache cfg pkg else addPackageToRepositoryCache cfg pkg ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/src/CPM/Resolution.curry000066400000000000000000000771171377556325500214620ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This module contains the dependency resolution algorithm. -------------------------------------------------------------------------------- module CPM.Resolution ( ResolutionResult , showResult , resolutionSuccess , resolvedPackages , showDependencies , showConflict , allTransitiveDependencies , transitiveDependencies , resolve , resolveDependenciesFromLookupSet , isCompatibleToCompiler , isDisjunctionCompatible ) where import Data.Either import Data.List import Data.Maybe import Test.Prop import Text.Pretty import CPM.Config ( Config, defaultConfig, compilerVersion , compilerBaseVersion ) import CPM.ErrorLogger import CPM.LookupSet import CPM.Package --- Resolves the dependencies of a package using packages from a lookup set, --- inside an error logger. resolveDependenciesFromLookupSet :: Config -> Package -> LookupSet -> ErrorLogger ResolutionResult resolveDependenciesFromLookupSet cfg pkg lookupSet = let result = resolve cfg pkg lookupSet in if resolutionSuccess result then return result else fail $ showResult result --- Resolves the dependencies of a package using packages from a lookup set. --- The base package of the current compiler is removed from the result set. resolve :: Config -> Package -> LookupSet -> ResolutionResult resolve cfg pkg ls = case resolvedPkgs of Just pkgs -> ResolutionSuccess pkg (deleteBase pkgs) Nothing -> ResolutionFailure labeledTree where labeledTree = labelConflicts cfg $ candidateTree pkg ls noConflicts = prune ((/= Nothing) . clConflict) labeledTree resolvedPkgs = maybeHead . map stPackages . filter stComplete . leaves . mapTree clState $ noConflicts deleteBase = filter (\p -> name p /= "base" || showVersion (version p) /= compilerBaseVersion cfg) --- Gives a list of all activated packages for a successful resolution. resolvedPackages :: ResolutionResult -> [Package] resolvedPackages (ResolutionSuccess pkg deps) = delete pkg deps resolvedPackages (ResolutionFailure _) = error "resolvedPackages called on failure" --- Tries to get a list of activated packages for a resolution. Returns Nothing --- if the resolution was not successful. maybeResolvedPackages :: ResolutionResult -> Maybe [Package] maybeResolvedPackages (ResolutionSuccess _ deps) = Just deps maybeResolvedPackages (ResolutionFailure _) = Nothing --- Was a resolution successful? resolutionSuccess :: ResolutionResult -> Bool resolutionSuccess (ResolutionSuccess _ _) = True resolutionSuccess (ResolutionFailure _) = False --- Renders a dependency tree from a successful resolution. showDependencies :: ResolutionResult -> String showDependencies (ResolutionSuccess pkg deps) = showTree . mapTree (text . packageId) $ dependencyTree deps pkg showDependencies (ResolutionFailure _) = "Resolution failed." --- Renders a conflict resolution into a textual representation. showConflict :: ResolutionResult -> String showConflict (ResolutionSuccess _ _) = "Resolution succeeded." showConflict (ResolutionFailure t) = case findRelevantConflict t of Just c -> showConflictState c Nothing -> case missingPackages $ clState $ findDeepestNode t of [] -> "Conflict resolution failed for an unknown reason... Hint:(\n" ++ "Please clean your package ('cypm clean') and/or\n" ++ "your package index ('cypm update') and try again..." (d@(Dependency p _):_) -> "There seems to be no version of package " ++ p ++ " that can satisfy the constraint " ++ showDependency d showConflictTree :: ResolutionResult -> String showConflictTree (ResolutionSuccess _ _) = "Resolution succeeded." showConflictTree (ResolutionFailure t) = showTree $ mapTree labeler $ cutBelowConflict t where pkgId = text . packageId . actPackage actChain a@(InitialA _) = pkgId a actChain a@(ChildA _ _ p) = pkgId a <+> text "->" <+> actChain p labeler ((a, _), Nothing) = pkgId a labeler ((a, _), Just (CompilerConflict _)) = red $ text "C" <+> actChain a labeler ((a, _), Just (PrimaryConflict _)) = red $ text "P" <+> actChain a labeler ((a, _), Just (SecondaryConflict a' a'')) = red $ text "S" <+> actChain a <+> parens (pkgId a') <+> parens (pkgId a'') cutBelowConflict (Node (a, Nothing) cs) = Node (a, Nothing) $ map cutBelowConflict cs cutBelowConflict (Node (a, Just c) _) = Node (a, Just c) [] showCandidateTree :: Tree State -> String showCandidateTree = showTree . mapTree (text . packageId . actPackage . stActivation) showLabelTree :: Config -> Tree State -> String showLabelTree cfg = showTree . mapTree labeler . cutBelowConflict . labelConflicts cfg where pkgId = text . packageId . actPackage . stActivation actId = text . packageId . actPackage labeler (s, Nothing) = pkgId s labeler (s, Just (CompilerConflict _)) = red $ text "C" <+> pkgId s labeler (s, Just (PrimaryConflict _)) = red $ text "P" <+> pkgId s labeler (s, Just (SecondaryConflict a1 a2)) = red $ text "S" <+> pkgId s <+> actId a1 <+> actId a2 cutBelowConflict (Node (a, Nothing) cs) = Node (a, Nothing) $ map cutBelowConflict cs cutBelowConflict (Node (a, Just c) _) = Node (a, Just c) [] resultConflict :: ResolutionResult -> Maybe Conflict resultConflict (ResolutionSuccess _ _) = Nothing resultConflict (ResolutionFailure t) = case findRelevantConflict t of Nothing -> Nothing Just cs -> clConflict cs --- Renders a resolution result into a textual representation for the user. In --- case of success, the dependency tree is shown. In case of failure, --- information on the cause of the conflict is shown. showResult :: ResolutionResult -> String showResult r@(ResolutionSuccess _ _) = showDependencies r showResult r@(ResolutionFailure _) = showConflict r --- Result of a resolution run. In case of success, it contains the original --- package as well as a list of resolved packages. If the resolution failed, it --- contains the conflict tree. data ResolutionResult = ResolutionSuccess Package [Package] | ResolutionFailure (Tree ConflictState) deriving (Eq,Show) --- Represents an activation of a package in the candidate tree. Activations --- form a chain up to the initial activation, i.e. the initial package that --- resolution was started on. Each activation's parent is the activation of the --- package that led to the current activation, i.e. the package whose --- dependency led to the current package version being chosen. data Activation = InitialA Package | ChildA Package Dependency Activation deriving (Eq,Show) --- Each tree node is labeled with the current activation and all former --- activations. type State = (Activation, [Activation]) --- A conflict occurs when one of the active packages in a state clashes with --- one of dependencies of all of the state's active packages. If the clash --- occurs between a package A and a dependency of a package B and B is also the --- package that activated A, i.e. the parent of its activation, we call the --- conflict a 'same package' conflict. A 'real' conflict is a one where package --- A was activated by some earlier package. When the compiler compatibility --- constraints of the package activated in the current state are not met, then --- we use the compiler conflict. data Conflict = SecondaryConflict Activation Activation | PrimaryConflict Activation | CompilerConflict Activation deriving (Eq,Show) --- A state and a potential conflict. type ConflictState = (State, Maybe Conflict) --- Gets the package that was activated in a state. stPackage :: State -> Package stPackage (a, _) = actPackage a --- Gets all active packages in a state. stPackages :: State -> [Package] stPackages (_, as) = map actPackage as --- Gets the state's current activation stActivation :: State -> Activation stActivation = fst --- Gets all activations leading up to the state, including the current --- activation. stActivations :: State -> [Activation] stActivations = snd --- Gets a list of all dependencies of all active packages in a state, alongside --- the activations that activated the respective packages. stDependencies :: State -> [(Activation, Dependency)] stDependencies = concatMap zippedDeps . stActivations where zippedDeps a = zip (repeat a) $ dependencies $ actPackage a --- Gets a list of all dependencies of all active packages in a state. stAllDependencies :: State -> [Dependency] stAllDependencies = concatMap dependencies . stPackages --- Gets an activation's package. actPackage :: Activation -> Package actPackage (InitialA p) = p actPackage (ChildA p _ _) = p actDependency :: Activation -> Dependency actDependency (InitialA _) = error "Called on initialA" actDependency (ChildA _ d _) = d actParent :: Activation -> Activation actParent a@(InitialA _) = a actParent (ChildA _ _ p) = p --- Gets a potential conflict from a conflict state. clConflict :: ConflictState -> Maybe Conflict clConflict = snd --- Gets the original state from a conflict state. clState :: ConflictState -> State clState = fst --- A tree with a label and child nodes. data Tree a = Node a [Tree a] deriving (Eq,Show) --- Recursively applies a function to each node in a tree. mapTree :: (a -> b) -> Tree a -> Tree b mapTree f (Node a cs) = Node (f a) $ map (mapTree f) cs --- A node's label. label :: Tree a -> a label (Node a _) = a leaves :: Tree a -> [a] leaves (Node a []) = [a] leaves (Node _ cs@(_:_)) = concatMap leaves cs --- Folds a tree to a value. foldTree :: (a -> [b] -> b) -> Tree a -> b foldTree f (Node a cs) = f a (map (foldTree f) cs) --- Filters a tree using a predicate. filterTree :: (a -> Bool) -> Tree a -> Tree a filterTree p = foldTree f where f a cs = Node a (filter (p . label) cs) --- Removes all nodes from a tree that match the predicate. prune :: (a -> Bool) -> Tree a -> Tree a prune p = filterTree (not . p) --- Shows a textual representation of a tree. showTree :: Tree Doc -> String showTree t = "Package dependencies:\n" ++ pPrint (ppTree t) --- Pretty prints a tree of Docs into a single Doc. ppTree :: Tree Doc -> Doc ppTree (Node l cs) = l <$$> vcat children where children = map (\t -> indent 2 $ text "|-" <+> ppTree t) cs --- Extends a tree by appending a node to the first leaf in order, i.e. the --- leftmost leaf. extendTree :: Tree a -> Tree a -> Tree a extendTree (Node a []) n = Node a [n] extendTree (Node a (c:cs)) n = Node a $ (extendTree c n):cs --- Converts a tree of strings into the Graphviz dot format. dotifyTree :: Tree String -> String dotifyTree t = "digraph tree {\n" ++ full ++ "\n}" where (_, _, full) = dotify' (0, [], "") t dotify' (n, acc, s) (Node l cs) = let (n', children, str) = foldl (dotify') (n + 1, [], "") cs in (n', n:acc, s ++ intercalate "\n" ([node n l] ++ map (edge n) children) ++ str) node n l = "n" ++ (show n) ++ " [label=\"" ++ l ++ "\"];\n" edge a b = "n" ++ (show a) ++ " -> " ++ "n" ++ (show b) ++ ";\n" --- Builds a tree of candidate states from a package and a lookup set. This is --- the tree that is searched for complete states or conflicts. candidateTree :: Package -> LookupSet -> Tree State candidateTree pkg ls = let s = InitialA pkg in Node (s, [s]) $ tree' [s] (zip (repeat s) (dependencies pkg)) where tree' acts ((act, d@(Dependency p _)):ds) = if p `elem` (map (name . actPackage) acts) then tree' acts ds else map (nodesForDep act d ds acts) $ findAllVersions ls p True tree' _ [] = [] nodesForDep act d ds acts p' = let act' = ChildA p' d act acts' = act':acts nextDeps = zip (repeat act') (dependencies p') ++ ds in Node (act', acts') $ tree' acts' nextDeps --- Calculates the first conflict for each node in the tree and annotates the --- nodes with these conflicts. labelConflicts :: Config -> Tree State -> Tree ConflictState labelConflicts cfg = mapTree f where f s = (s, firstConflict cfg s (reverse $ stDependencies s)) --- Checks whether a state is complete, i.e. whether all packages mentioned in --- all dependencies of all active packages are present in the list of active --- packages. Note that stComplete does not check whether a dependency is --- actually met by a package, only whether the package is present. stComplete --- is meant to be called on a state that has already been checked for --- conflicts. stComplete :: State -> Bool stComplete s = missingPackages s == [] stCompleteness :: State -> Int stCompleteness s = length $ missingPackages s --- Finds all dependencies in a state which is unmet because its dependency is --- missing altogether, i.e. no version of the package is activated. missingPackages :: State -> [Dependency] missingPackages s = missing' (stPackages s) (stAllDependencies s) where missing' pkgs ds = filter (noPackage pkgs) ds noPackage pkgs (Dependency p _) = find ((== p) . name) pkgs == Nothing --- Calculates the first conflict in a state. firstConflict :: Config -> State -> [(Activation, Dependency)] -> Maybe Conflict firstConflict _ _ [] = Nothing firstConflict cfg s@(act, acts) ((depAct, Dependency p disj):ds) = if not $ isCompatibleToCompiler cfg (actPackage act) then Just $ CompilerConflict act else case findPkg of Nothing -> firstConflict cfg s ds Just a -> if isDisjunctionCompatible (version $ actPackage a) disj then firstConflict cfg s ds else if actParent a == depAct then Just $ PrimaryConflict a else Just $ SecondaryConflict a depAct where findPkg = find ((== p) . name . actPackage) acts --- Finds the deepest right-most node in a tree. findDeepestNode :: Tree a -> a findDeepestNode = snd . maxNode . leaves . depthTree where maxNode ls = foldl maxN (head ls) ls maxN (na, a) (nb, b) = if nb >= na then (nb, b) else (na, a) depthTree = relabel 0 relabel n (Node a cs) = Node (n, a) (map (relabel (n + 1)) cs) findRelevantConflict :: Tree ConflictState -> Maybe ConflictState findRelevantConflict = maybeMostRelevant . map mostRelevant . map snd . minGroups . filter ((/= []) . snd) . findGroups . cutBelowConflict . relabel where maybeMostRelevant [] = Nothing maybeMostRelevant cs@(_:_) = Just $ mostRelevant cs mostRelevant cs = case find (isSecondary . fromJust . clConflict) cs of Just s -> s Nothing -> case find (isCompiler . fromJust . clConflict) cs of Just c -> c Nothing -> head cs minGroups gs = let minG = foldl (\m g -> min m (fst g)) 99999 gs in filter ((== minG) . fst) gs isSecondary (SecondaryConflict _ _) = True isSecondary (PrimaryConflict _) = False isSecondary (CompilerConflict _) = False isCompiler (SecondaryConflict _ _) = False isCompiler (PrimaryConflict _) = False isCompiler (CompilerConflict _) = True findGroups (Node (d, (_, Nothing)) []) = [(d, [])] findGroups (Node (d, (_, Nothing)) cs@(_:_)) = if containsOnlyConflicts cs then [(d, map (snd . label) cs)] else concatMap findGroups cs findGroups (Node (d, (_, Just _)) _) = [(d, [])] containsOnlyConflicts = all (isJust . clConflict . snd) . map label cutBelowConflict (Node (d, (a, Nothing)) cs) = Node (d, (a, Nothing)) $ map cutBelowConflict cs cutBelowConflict (Node (d, (a, Just c)) _) = Node (d, (a, Just c)) [] relabel = mapTree (\a -> (stCompleteness $ clState a, a)) --- Renders the information from a real conflict into a textual representation --- for the user. --- --- @param originalAct - the original activation of the package --- @param confDep - the dependency conflicting the original activation --- @param confAct - the activation of the conflict dependency showRealConflictInfo :: Activation -> Activation -> String showRealConflictInfo originalAct confAct = let mkLabel pkg dep = (text $ name pkg) <+> (parens $ text $ showDependency dep) triedPkg = actPackage originalAct actLabeler (InitialA p) = text $ name p actLabeler (ChildA p dep _) = mkLabel p dep originalTree = mapTree actLabeler $ activationTree originalAct confTree = mapTree actLabeler $ activationTree confAct confDepLabel = mkLabel triedPkg (findDependencyOn triedPkg confAct) confTree' = extendTree confTree (Node confDepLabel []) findDependencyOn pkg act = case find ((== name pkg) . depPkg) $ dependencies $ actPackage act of Just a -> a Nothing -> error "Hey!" depPkg (Dependency p _) = p in pPrint $ (text $ "There was a conflict for package " ++ name triedPkg) <$$> ppTree originalTree <$$> ppTree confTree' showSamePackageConflictInfo :: Activation -> String showSamePackageConflictInfo act = let triedPkg = actPackage act in "There seems to be no version of package " ++ name triedPkg ++ " that can satisfy the constraint " ++ showDependency (actDependency act) showCompilerConflictInfo :: Activation -> String showCompilerConflictInfo act = "The package " ++ (packageId $ actPackage act) ++ ", dependency constraint " ++ showDependency (actDependency act) ++ ", is not compatible to the current compiler. It was activated because:\n" ++ showTree actTree where mkLabel pkg dep = (text $ name pkg) <+> (parens $ text $ showDependency dep) actLabeler (InitialA p) = text $ name p actLabeler (ChildA p dep _) = mkLabel p dep actTree = mapTree actLabeler $ activationTree act --- Renders a conflict state into a textual representation for the user. showConflictState :: ConflictState -> String showConflictState ((InitialA _, _), Nothing) = "No Conflict!" showConflictState ((InitialA pkg, _), Just _) = "Initial Conflict! " ++ packageId pkg showConflictState ((ChildA _ _ _, _), Nothing) = "No Conflict!" showConflictState ((ChildA _ _ _, _), Just (PrimaryConflict originalAct)) = showSamePackageConflictInfo originalAct showConflictState ((ChildA _ _ _, _), Just (SecondaryConflict originalAct confAct)) = showRealConflictInfo originalAct confAct showConflictState ((ChildA _ _ _, _), Just (CompilerConflict act)) = showCompilerConflictInfo act --- Turns an activation into a tree, with the initial activation as its root. --- Note that this tree will be a singly linked list, i.e. each node will have --- at most one child. activationTree :: Activation -> Tree Activation activationTree = head . foldl (\acc f -> f acc) [] . actTree' where actTree' x@(InitialA _) = [\cs -> [Node x cs]] actTree' x@(ChildA _ _ parent) = (\cs -> [Node x cs]):(actTree' parent) --- Turns a list of activated packages and an original package into a dependency --- tree. dependencyTree :: [Package] -> Package -> Tree Package dependencyTree chosen pkg = Node pkg $ map (dependencyTree chosen) childPkgs where justs = map fromJust . filter (/= Nothing) childPkgs = justs $ map findPkg (dependencies pkg) findPkg (Dependency p _) = find ((== p) . name) chosen maybeHead :: [a] -> Maybe a maybeHead [] = Nothing maybeHead (x:_) = Just x packageSource :: Package -> LookupSet -> Maybe LookupSource packageSource p ls = lookupSource ls p allTransitiveDependencies' :: [String] -> LookupSet -> String -> [String] allTransitiveDependencies' seen ls pkg = nub $ allDeps where allVersions = findAllVersions ls pkg True allDeps = foldl (\s d -> transitiveDependencies' s ls d) seen allVersions allTransitiveDependencies :: LookupSet -> String -> [String] allTransitiveDependencies = allTransitiveDependencies' [] transitiveDependencies' :: [String] -> LookupSet -> Package -> [String] transitiveDependencies' seen ls pkg = foldl (\s d -> if d `elem` s then s else (nub (s ++ allTransitiveDependencies' (d:s) ls d))) seen deps where deps = map dependencyName $ dependencies pkg dependencyName (Dependency n _) = n transitiveDependencies :: LookupSet -> Package -> [String] transitiveDependencies = transitiveDependencies' [] test_transitiveDependencies_simpleCase :: Prop test_transitiveDependencies_simpleCase = transitiveDependencies db pkg -=- ["B", "C"] where pkg = cPackage "A" (0, 0, 1, Nothing) [cDep "B" ">= 1.0.0", cDep "C" "= 1.2.0"] b = cPackage "B" (1, 0, 9, Nothing) [] c = cPackage "C" (1, 2, 0, Nothing) [] db = cDB [b, c] test_transitiveDependencies_loop :: Prop test_transitiveDependencies_loop = transitiveDependencies db pkg -=- ["B", "C"] where pkg = cPackage "A" (0, 0, 1, Nothing) [cDep "B" ">= 1.0.0", cDep "C" "= 1.2.0"] b = cPackage "B" (1, 0, 0, Nothing) [cDep "C" "= 1.2.0"] c = cPackage "C" (1, 2, 0, Nothing) [cDep "B" ">= 1.0.0"] db = cDB [b, c] test_transitiveDependencies_multipleVersions :: Prop test_transitiveDependencies_multipleVersions = transitiveDependencies db pkg -=- ["B", "D", "C"] where pkg = cPackage "A" (0, 0, 1, Nothing) [cDep "B" ">= 1.0.0"] b100 = cPackage "B" (1, 0, 0, Nothing) [cDep "C" "= 1.0.0"] b110 = cPackage "B" (1, 1, 0, Nothing) [cDep "D" "= 1.0.0"] c = cPackage "C" (1, 0, 0, Nothing) [] d = cPackage "D" (1, 0, 0, Nothing) [] db = cDB [b100, b110, c, d] -- Is the package compatible to the compiler used by CPM? isCompatibleToCompiler :: Config -> Package -> Bool isCompatibleToCompiler cfg p = case compats of [] -> -- No compiler constraints => check base compatibility isCompilerCompatibleBase cfg p (_:_) -> case constraintForCompiler of Nothing -> False -- No constraints for current compiler -- => compiler is incompatible Just (CompilerCompatibility _ c) -> isDisjunctionCompatible (maj, min, revi, Nothing) c && isCompilerCompatibleBase cfg p where (name, maj, min, revi) = compilerVersion cfg compats = compilerCompatibility p constraintForCompiler = find (\(CompilerCompatibility c _) -> c == name) compats -- Is the package compatible to the base version of the compiler used by CPM? isCompilerCompatibleBase :: Config -> Package -> Bool isCompilerCompatibleBase cfg p = all (\ (Dependency _ c) -> isDisjunctionCompatible baseversion c) basedependencies where baseversion = maybe (0,0,0,Nothing) id (readVersion (compilerBaseVersion cfg)) basedependencies = filter (\ (Dependency dp _) -> dp == "base") (dependencies p) isDisjunctionCompatible :: Version -> Disjunction -> Bool isDisjunctionCompatible ver cs = any id (map (all id) rs) where rs = map (map isCompatible) cs preReleaseCompatible (_, _, _, p1) (_, _, _, p2) = (isJust p1 && isJust p2) || (isNothing p1 && isNothing p2) isCompatible (VExact v) = v == ver isCompatible (VLt v) = ver `vlt` v && preReleaseCompatible ver v isCompatible (VLte v) = ver `vlte` v && preReleaseCompatible ver v isCompatible (VGt v) = ver `vgt` v && preReleaseCompatible ver v isCompatible (VGte v) = ver `vgte` v && preReleaseCompatible ver v isCompatible (VMinCompatible v) = ver `vgte` v && ver `vlt` (nextMinor v) && preReleaseCompatible ver v isCompatible (VMajCompatible v) = ver `vgte` v && ver `vlt` (nextMajor v) && preReleaseCompatible ver v test_onlyConjunctionCompatible :: Prop test_onlyConjunctionCompatible = isDisjunctionCompatible ver dis -=- True where dis = cDisj "= 1.0.0" ver = (1, 0, 0, Nothing) test_allConjunctionsCompatible :: Prop test_allConjunctionsCompatible = isDisjunctionCompatible ver dis -=- True where dis = cDisj ">= 1.0.0 || = 1.2.0" ver = (1, 2, 0, Nothing) test_oneConjunctionCompatible :: Prop test_oneConjunctionCompatible = isDisjunctionCompatible ver dis -=- True where ver = (1, 0, 0, Nothing) dis = cDisj "> 2.0.0 || = 1.0.0" test_conjunctionWithMultipleParts :: Prop test_conjunctionWithMultipleParts = isDisjunctionCompatible ver dis -=- True where ver = (1, 0, 0, Nothing) dis = cDisj ">= 1.0.0, < 2.0.0" test_reportsSimpleFailure :: Prop test_reportsSimpleFailure = isDisjunctionCompatible ver dis -=- False where ver = (1, 0, 0, Nothing) dis = cDisj "> 1.0.0" test_reportsAllConjunctionsAsFailure :: Prop test_reportsAllConjunctionsAsFailure = isDisjunctionCompatible ver dis -=- False where ver = (1, 0, 0, Nothing) dis = cDisj "< 1.0.0 || > 1.0.0" test_reportsRelevantPartOfConjunction :: Prop test_reportsRelevantPartOfConjunction = isDisjunctionCompatible ver dis -=- False where ver = (1, 0, 0, Nothing) dis = cDisj "< 1.0.0, > 0.5.0" test_semverCompatible :: Prop test_semverCompatible = isDisjunctionCompatible ver dis -=- True where ver = (0, 5, 9, Nothing) dis = cDisj "~> 0.5.0" test_semverIncompatible :: Prop test_semverIncompatible = isDisjunctionCompatible ver dis -=- False where ver = (0, 7, 1, Nothing) dis = cDisj "~> 0.6.0" test_semverMinimum :: Prop test_semverMinimum = isDisjunctionCompatible ver dis -=- False where ver = (0, 7, 0, Nothing) dis = cDisj "~> 0.7.2" test_resolvesSimpleDependency :: Prop test_resolvesSimpleDependency = maybeResolvedPackages (resolve defaultConfig pkg db) -=- Just [json100, pkg] where pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "=1.0.0"] json100 = cPackage "json" (1, 0, 0, Nothing) [] json101 = cPackage "json" (1, 0, 1, Nothing) [] db = cDB [json100, json101] test_reportsUnknownPackage :: Prop test_reportsUnknownPackage = showResult result -=- "There seems to be no version of package json that can satisfy the constraint json = 1.0.0" where result = resolve defaultConfig pkg db pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "= 1.0.0"] db = cDB [pkg] test_reportsMissingPackageVersion :: Prop test_reportsMissingPackageVersion = showResult result -=- "There seems to be no version of package json that can satisfy the constraint json = 1.2.0" where result = resolve defaultConfig pkg db pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "=1.2.0"] json = cPackage "json" (1, 0, 0, Nothing) [] db = cDB [json] test_reportsSecondaryConflict :: Prop test_reportsSecondaryConflict = showResult result -=- expectedMessage where result = resolve defaultConfig pkg db pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "= 1.0.0", cDep "b" ">= 0.0.1"] b = cPackage "b" (0, 0, 2, Nothing) [cDep "json" "~> 1.0.4"] json100 = cPackage "json" (1, 0, 0, Nothing) [] json105 = cPackage "json" (1, 0, 5, Nothing) [] db = cDB [pkg, b, json100, json105] expectedMessage = "There was a conflict for package json\n" ++ "sample\n" ++ " |- json (json = 1.0.0)\n" ++ "sample\n" ++ " |- b (b >= 0.0.1)\n" ++ " |- json (json ~1.0.4)" test_reportsSecondaryConflictInsteadOfPrimary :: Prop test_reportsSecondaryConflictInsteadOfPrimary = showResult result -=- expectedMessage where result = resolve defaultConfig pkg db pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "= 1.0.0", cDep "b" ">= 0.0.5"] b001 = cPackage "b" (0, 0, 1, Nothing) [] b002 = cPackage "b" (0, 0, 2, Nothing) [] b003 = cPackage "b" (0, 0, 3, Nothing) [] b006 = cPackage "b" (0, 0, 6, Nothing) [cDep "json" "~> 1.0.4"] json100 = cPackage "json" (1, 0, 0, Nothing) [] json105 = cPackage "json" (1, 0, 5, Nothing) [] db = cDB [pkg, b001, b002, b003, b006, json100, json105] expectedMessage = "There was a conflict for package json\n" ++ "sample\n" ++ " |- json (json = 1.0.0)\n" ++ "sample\n" ++ " |- b (b >= 0.0.5)\n" ++ " |- json (json ~1.0.4)" test_detectsSecondaryOnFirstActivation :: Prop test_detectsSecondaryOnFirstActivation = showResult result -=- expectedMessage where result = resolve defaultConfig pkg db pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "a" "= 0.0.1", cDep "b" "> 0.0.1"] a001 = cPackage "a" (0, 0, 1, Nothing) [cDep "b" "= 0.0.1"] b001 = cPackage "b" (0, 0, 1, Nothing) [] b002 = cPackage "b" (0, 0, 2, Nothing) [] db = cDB [pkg, a001, b001, b002] expectedMessage = "There was a conflict for package b\n" ++ "sample\n" ++ " |- a (a = 0.0.1)\n" ++ " |- b (b = 0.0.1)\n" ++ "sample\n" ++ " |- b (b > 0.0.1)" test_makesDecisionBetweenAlternatives :: Prop test_makesDecisionBetweenAlternatives = maybeResolvedPackages (resolve defaultConfig pkg db) -=- Just [json150, pkg] where pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "> 1.0.0, < 2.0.0 || >= 4.0.0"] json150 = cPackage "json" (1, 5, 0, Nothing) [] json320 = cPackage "json" (3, 2, 0, Nothing) [] db = cDB [json150, json320] test_alwaysChoosesNewestAlternative :: Prop test_alwaysChoosesNewestAlternative = maybeResolvedPackages (resolve defaultConfig pkg db) -=- Just [json420, pkg] where pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "> 1.0.0, < 2.0.0 || >= 4.0.0"] json150 = cPackage "json" (1, 5, 0, Nothing) [] json420 = cPackage "json" (4, 2, 0, Nothing) [] db = cDB [json150, json420] test_doesNotChoosePrereleaseByDefault :: Prop test_doesNotChoosePrereleaseByDefault = maybeResolvedPackages (resolve defaultConfig pkg db) -=- Just [b109, pkg] where pkg = cPackage "A" (0, 0, 1, Nothing) [cDep "B" ">= 1.0.0"] b109 = cPackage "B" (1, 0, 9, Nothing) [] b110b1 = cPackage "B" (1, 1, 0, Just "b1") [] db = cDB [b109, b110b1] test_upgradesPackageToPrereleaseWhenNeccesary :: Prop test_upgradesPackageToPrereleaseWhenNeccesary = maybeResolvedPackages (resolve defaultConfig pkg db) -=- Just [b110b1, c, pkg] where pkg = cPackage "A" (0, 0, 1, Nothing) [cDep "C" "= 1.2.0"] b109 = cPackage "B" (1, 0, 9, Nothing) [] b110b1 = cPackage "B" (1, 1, 0, Just "b1") [] c = cPackage "C" (1, 2, 0, Nothing) [cDep "B" ">= 1.1.0-b1"] db = cDB [b109, b110b1, c] test_prefersLocalPackageCacheEvenIfOlder :: Prop test_prefersLocalPackageCacheEvenIfOlder = maybeResolvedPackages (resolve defaultConfig pkg db) -=- Just [b101, pkg] where pkg = cPackage "A" (0, 0, 1, Nothing) [cDep "B" ">= 1.0.0"] b101 = cPackage "B" (1, 0, 1, Nothing) [] b105 = cPackage "B" (1, 0, 5, Nothing) [] db = addPackage (addPackage emptySet b101 FromLocalCache) b105 FromRepository test_reportsCompilerIncompatibility :: Prop test_reportsCompilerIncompatibility = showResult result -=- "The package json-1.0.0, dependency constraint json = 1.0.0, is not compatible to the current compiler. It was activated because:\nPackage dependencies:\nsample\n |- json (json = 1.0.0)" where result = resolve defaultConfig pkg db pkg = cPackage "sample" (0, 0, 1, Nothing) [cDep "json" "= 1.0.0"] json = cPackageCC "json" (1, 0, 0, Nothing) [cCC "nocompiler" "= 1.0.0"] db = cDB [json] cPackage :: String -> Version -> [Dependency] -> Package cPackage p v ds = emptyPackage { name = p , version = v , author = ["author"] , synopsis = "JSON library for Curry" , dependencies = ds , maintainer = [] , description = Nothing , license = Nothing , licenseFile = Nothing , copyright = Nothing , homepage = Nothing , bugReports = Nothing , repository = Nothing , compilerCompatibility = [] , source = Nothing , exportedModules = [] } cPackageCC :: String -> Version -> [CompilerCompatibility] -> Package cPackageCC p v cs = emptyPackage { name = p , version = v , author = ["author"] , synopsis = "JSON library for Curry" , dependencies = [] , maintainer = [] , description = Nothing , license = Nothing , licenseFile = Nothing , copyright = Nothing , homepage = Nothing , bugReports = Nothing , repository = Nothing , compilerCompatibility = cs , source = Nothing , exportedModules = [] } cDisj :: String -> Disjunction cDisj = fromJust . readVersionConstraints cDep :: String -> String -> Dependency cDep p c = Dependency p (fromJust $ readVersionConstraints c) cCC :: String -> String -> CompilerCompatibility cCC p c = CompilerCompatibility p (fromJust $ readVersionConstraints c) cDB :: [Package] -> LookupSet cDB ps = addPackages emptySet ps FromRepository curry-tools-v3.3.0/cpm/templates/000077500000000000000000000000001377556325500170045ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/templates/LICENSE000066400000000000000000000027351377556325500200200ustar00rootroot00000000000000Copyright (c) 2020, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/templates/Main.curry000066400000000000000000000001071377556325500207540ustar00rootroot00000000000000module Main where main :: IO () main = putStrLn "This is my project!" curry-tools-v3.3.0/cpm/vendor/000077500000000000000000000000001377556325500163035ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/abstract-curry/000077500000000000000000000000001377556325500212505ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/abstract-curry/LICENSE000066400000000000000000000027351377556325500222640ustar00rootroot00000000000000Copyright (c) 2017, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/abstract-curry/README.md000066400000000000000000000025371377556325500225360ustar00rootroot00000000000000abstract-curry ============== This package contains libraries to deal with AbstractCurry programs. AbstractCurry is a representation of Curry programs oriented towards the source code of Curry. Thus, it can be used to generate readable Curry programs, e.g., by the Web framework Spicey. The package contains the following modules: * `AbstractCurry.Build`: This module provides some useful operations to write programs that generate AbstractCurry programs in a more compact and readable way. * `AbstractCurry.Files`: This module defines operations to read and write AbstractCurry programs. * `AbstractCurry.Pretty`: This module provides a pretty-printer for AbstractCurry modules. * `AbstractCurry.Select`: This module provides some useful operations to select components in AbstractCurry programs, i.e., it provides a collection of selector functions for AbstractCurry. * `AbstractCurry.Show`: This module provides transformation and update operations on AbstractCurry programs. Since the transformations are defined recursively on structured types, they are useful to construct specific transformations on AbstractCurry programs. In particular, this library contains the transformation `renameCurryModule` to rename an AbstractCurry module. * `AbstractCurry.Types`: This module defines the data types to represent AbstractCurry programs in Curry. curry-tools-v3.3.0/cpm/vendor/abstract-curry/package.json000066400000000000000000000022701377556325500235370ustar00rootroot00000000000000{ "name": "abstract-curry", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Libraries to deal with AbstractCurry programs", "category": [ "Metaprogramming" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "currypath" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0", "directory" : ">= 3.0.0, < 4.0.0", "frontend-exec" : ">= 3.0.0, < 4.0.0", "wl-pprint" : ">= 3.0.0, < 4.0.0", "read-legacy" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "AbstractCurry.Build", "AbstractCurry.Files", "AbstractCurry.Pretty", "AbstractCurry.Select", "AbstractCurry.Transform", "AbstractCurry.Types" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/abstract-curry.git", "tag": "$version" }, "testsuite": { "src-dir": "test", "modules": [ "TestAbstractCurry" ] } } curry-tools-v3.3.0/cpm/vendor/abstract-curry/src/000077500000000000000000000000001377556325500220375ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/abstract-curry/src/AbstractCurry/000077500000000000000000000000001377556325500246275ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/abstract-curry/src/AbstractCurry/Build.curry000066400000000000000000000217431377556325500267630ustar00rootroot00000000000000------------------------------------------------------------------------ --- This library provides some useful operations to write programs --- that generate AbstractCurry programs in a more compact and readable way. --- --- @version October 2016 --- @category meta ------------------------------------------------------------------------ module AbstractCurry.Build where import AbstractCurry.Types infixr 9 ~> ------------------------------------------------------------------------ -- Goodies to construct type declarations --- Constructs a simple `CurryProg` without type classes and instances. simpleCurryProg :: String -> [String] -> [CTypeDecl] -> [CFuncDecl] -> [COpDecl] -> CurryProg simpleCurryProg name imps types funcs ops = CurryProg name imps Nothing [] [] types funcs ops ------------------------------------------------------------------------ -- Goodies to construct type declarations --- Constructs a simple constructor declaration without quantified --- type variables and type class constraints. simpleCCons :: QName -> CVisibility -> [CTypeExpr] -> CConsDecl simpleCCons = CCons ------------------------------------------------------------------------ -- Goodies to construct type expressions --- A type application of a qualified type constructor name to a list of --- argument types. applyTC :: QName -> [CTypeExpr] -> CTypeExpr applyTC f es = foldl CTApply (CTCons f) es --- A function type. (~>) :: CTypeExpr -> CTypeExpr -> CTypeExpr t1 ~> t2 = CFuncType t1 t2 --- A base type. baseType :: QName -> CTypeExpr baseType t = CTCons t --- Constructs a list type from an element type. listType :: CTypeExpr -> CTypeExpr listType a = CTApply (CTCons (pre "[]")) a --- Constructs a tuple type from list of component types. tupleType :: [CTypeExpr] -> CTypeExpr tupleType ts | l==0 = baseType (pre "()") | l==1 = head ts | otherwise = foldl CTApply (CTCons (pre ('(' : take (l-1) (repeat ',') ++ ")"))) ts where l = length ts --- Constructs an IO type from a type. ioType :: CTypeExpr -> CTypeExpr ioType a = CTApply (CTCons (pre "IO")) a --- Constructs a Maybe type from element type. maybeType :: CTypeExpr -> CTypeExpr maybeType a = CTApply (CTCons (pre "Maybe")) a --- The type expression of the String type. stringType :: CTypeExpr stringType = baseType (pre "String") --- The type expression of the Int type. intType :: CTypeExpr intType = baseType (pre "Int") --- The type expression of the Float type. floatType :: CTypeExpr floatType = baseType (pre "Float") --- The type expression of the Bool type. boolType :: CTypeExpr boolType = baseType (pre "Bool") --- The type expression of the Char type. charType :: CTypeExpr charType = baseType (pre "Char") --- The type expression of the unit type. unitType :: CTypeExpr unitType = baseType (pre "()") --- The type expression of the Time.CalendarTime type. dateType :: CTypeExpr dateType = baseType ("Time", "CalendarTime") --- A qualified type with empty class constraints. emptyClassType :: CTypeExpr -> CQualTypeExpr emptyClassType te = CQualType (CContext []) te ------------------------------------------------------------------------ -- Goodies to construct function declarations --- Constructs a function declaration from a given qualified function name, --- arity, visibility, type expression and list of defining rules. cfunc :: QName -> Int -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl cfunc = CFunc --- Constructs a function declaration from a given comment, --- qualified function name, --- arity, visibility, type expression and list of defining rules. cmtfunc :: String -> QName -> Int -> CVisibility -> CQualTypeExpr -> [CRule] -> CFuncDecl cmtfunc = CmtFunc -- Constructs a `CFunc` with simple (unqualified) type expression. stFunc :: QName -> Int -> CVisibility -> CTypeExpr -> [CRule] -> CFuncDecl stFunc name arity vis texp rs = cfunc name arity vis (emptyClassType texp) rs -- Constructs a `CmtFunc` with simple (unqualified) type expression. stCmtFunc :: String -> QName -> Int -> CVisibility -> CTypeExpr -> [CRule] -> CFuncDecl stCmtFunc cm name arity vis texp rs = cmtfunc cm name arity vis (emptyClassType texp) rs --- Constructs a simple rule with a pattern list and an --- unconditional right-hand side. simpleRule :: [CPattern] -> CExpr -> CRule simpleRule pats rhs = CRule pats (CSimpleRhs rhs []) --- Constructs a simple rule with a pattern list, an --- unconditional right-hand side, and local declarations. simpleRuleWithLocals :: [CPattern] -> CExpr -> [CLocalDecl] -> CRule simpleRuleWithLocals pats rhs ldecls = CRule pats (CSimpleRhs rhs ldecls) --- Constructs a rule with a possibly guarded right-hand side --- and local declarations. --- A simple right-hand side is constructed if there is only one --- `True` condition. guardedRule :: [CPattern] -> [(CExpr,CExpr)] -> [CLocalDecl] -> CRule guardedRule pats gs ldecls | length gs == 1 && fst (head gs) == CSymbol (pre "True") = CRule pats (CSimpleRhs (snd (head gs)) ldecls) | otherwise = CRule pats (CGuardedRhs gs ldecls) --- Constructs a guarded expression with the trivial guard. noGuard :: CExpr -> (CExpr, CExpr) noGuard e = (CSymbol (pre "True"), e) ------------------------------------------------------------------------ -- Goodies to construct expressions and patterns --- An application of a qualified function name to a list of arguments. applyF :: QName -> [CExpr] -> CExpr applyF f es = foldl CApply (CSymbol f) es --- An application of an expression to a list of arguments. applyE :: CExpr -> [CExpr] -> CExpr applyE f args = foldl CApply f args --- A constant, i.e., an application without arguments. constF :: QName -> CExpr constF f = applyF f [] --- An application of a variable to a list of arguments. applyV :: CVarIName -> [CExpr] -> CExpr applyV v es = foldl CApply (CVar v) es -- Applies the Just constructor to an AbstractCurry expression. applyJust :: CExpr -> CExpr applyJust a = applyF (pre "Just") [a] -- Applies the maybe function to three AbstractCurry expressions. applyMaybe :: CExpr -> CExpr -> CExpr -> CExpr applyMaybe a1 a2 a3 = applyF (pre "maybe") [a1,a2,a3] --- Constructs a tuple expression from list of component expressions. tupleExpr :: [CExpr] -> CExpr tupleExpr es | l==0 = constF (pre "()") | l==1 = head es | otherwise = applyF (pre ('(' : take (l-1) (repeat ',') ++ ")")) es where l = length es -- Constructs a let declaration (with possibly empty local delcarations). letExpr :: [CLocalDecl] -> CExpr -> CExpr letExpr locals cexp = if null locals then cexp else CLetDecl locals cexp --- Constructs from a pattern and an expression a branch for a case expression. cBranch :: CPattern -> CExpr -> (CPattern, CRhs) cBranch pattern exp = (pattern, CSimpleRhs exp []) --- Constructs a tuple pattern from list of component patterns. tuplePattern :: [CPattern] -> CPattern tuplePattern ps | l==0 = CPComb (pre "()") [] | l==1 = head ps | otherwise = CPComb (pre ('(' : take (l-1) (repeat ',') ++ ")")) ps where l = length ps --- Constructs, for given n, a list of n PVars starting from 0. pVars :: Int -> [CPattern] pVars n = [CPVar (i,"x"++show i) | i<-[0..n-1]] --- Converts an integer into an AbstractCurry expression. pInt :: Int -> CPattern pInt x = CPLit (CIntc x) --- Converts a float into an AbstractCurry expression. pFloat :: Float -> CPattern pFloat x = CPLit (CFloatc x) --- Converts a character into a pattern. pChar :: Char -> CPattern pChar x = CPLit (CCharc x) --- Constructs an empty list pattern. pNil :: CPattern pNil = CPComb (pre "[]") [] --- Constructs a list pattern from list of component patterns. listPattern :: [CPattern] -> CPattern listPattern [] = pNil listPattern (p:ps) = CPComb (pre ":") [p, listPattern ps] --- Converts a string into a pattern representing this string. stringPattern :: String -> CPattern stringPattern = CPLit . CStringc --- Converts a list of AbstractCurry expressions into an --- AbstractCurry representation of this list. list2ac :: [CExpr] -> CExpr list2ac [] = constF (pre "[]") list2ac (c:cs) = applyF (pre ":") [c, list2ac cs] --- Converts an integer into an AbstractCurry expression. cInt :: Int -> CExpr cInt x = CLit (CIntc x) --- Converts a float into an AbstractCurry expression. cFloat :: Float -> CExpr cFloat x = CLit (CFloatc x) --- Converts a character into an AbstractCurry expression. cChar :: Char -> CExpr cChar x = CLit (CCharc x) --- Converts a string into an AbstractCurry represention of this string. string2ac :: String -> CExpr string2ac s = CLit (CStringc s) --- Converts an index i into a variable named xi. toVar :: Int -> CExpr toVar i = CVar (1,"x"++show i) --- Converts a string into a variable with index 1. cvar :: String -> CExpr cvar s = CVar (1,s) --- Converts a string into a pattern variable with index 1. cpvar :: String -> CPattern cpvar s = CPVar (1,s) --- Converts a string into a type variable with index 1. ctvar :: String -> CTypeExpr ctvar s = CTVar (1,s) ------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/abstract-curry/src/AbstractCurry/Files.curry000066400000000000000000000243041377556325500267620ustar00rootroot00000000000000-- --------------------------------------------------------------------------- --- This library defines various I/O actions to read Curry programs and --- transform them into the AbstractCurry representation and to write --- AbstractCurry files. --- --- Assumption: an abstract Curry program is stored in file with --- extension `.acy` in the subdirectory `.curry` --- --- @author Michael Hanus, Bjoern Peemoeller, Jan Tikovsky, Finn Teegen --- @version December 2018 -- --------------------------------------------------------------------------- module AbstractCurry.Files where import Data.Char ( isSpace ) import System.Directory ( doesFileExist, getModificationTime , findFileWithSuffix, getFileWithSuffix ) import System.FilePath ( takeFileName, (), (<.>) ) import System.CurryPath ( getLoadPathForModule, inCurrySubdir , lookupModuleSourceInLoadPath, stripCurrySuffix ) import System.FrontendExec import ReadShowTerm import AbstractCurry.Select ( imports ) import AbstractCurry.Types -- --------------------------------------------------------------------------- --- I/O action which parses a Curry program and returns the corresponding --- typed Abstract Curry program. --- Thus, the argument is the file name without suffix ".curry" --- or ".lcurry") and the result is a Curry term representing this --- program. readCurry :: String -> IO CurryProg readCurry prog = readCurryWithParseOptions prog (setQuiet True defaultParams) --- Read an AbstractCurry file with all its imports. --- @param modname - Module name or file name of Curry module --- @return a list of curry programs, having the AbstractCurry file as head. readCurryWithImports :: String -> IO [CurryProg] readCurryWithImports modname = collect [] [modname] where collect _ [] = return [] collect imported (m:ms) | m `elem` imported = collect imported ms | otherwise = do p <- readCurry m ps <- collect (m:imported) (ms ++ imports p) return (p:ps) tryReadCurryWithImports :: String -> IO (Either [String] [CurryProg]) tryReadCurryWithImports modname = collect [] [modname] where collect _ [] = return (Right []) collect imported (m:ms) | m `elem` imported = collect imported ms | otherwise = do eProg <- tryReadCurryFile m case eProg of Left err -> return (Left [err]) Right prog@(CurryProg _ is _ _ _ _ _ _) -> do results <- collect (m:imported) (ms ++ is) return (either Left (Right . (prog :)) results) tryReadCurryFile :: String -> IO (Either String CurryProg) tryReadCurryFile m = do mbSrc <- lookupModuleSourceInLoadPath m case mbSrc of Nothing -> cancel $ "Source module '" ++ m ++ "' not found" Just (_,srcFile) -> do callFrontendWithParams ACY (setQuiet True defaultParams) m mbFn <- getLoadPathForModule m >>= findFileWithSuffix (abstractCurryFileName m) [""] case mbFn of Nothing -> cancel $ "AbstractCurry module '" ++ m ++ "' not found" Just fn -> do ctime <- getModificationTime srcFile ftime <- getModificationTime fn if ctime > ftime then cancel $ "Source file '" ++ srcFile ++ "' is newer than AbstractCurry file '" ++ fn ++ "'" else do mbProg <- tryParse fn case mbProg of Left err -> cancel err Right p -> return (Right p) where cancel str = return (Left str) --- Try to parse an AbstractCurry file. --- @param fn - file name of AbstractCurry file tryParse :: String -> IO (Either String CurryProg) tryParse fn = do exists <- doesFileExist fn if not exists then cancel $ "AbstractCurry file '" ++ fn ++ "' does not exist" else do src <- readFile fn let (line1, lines) = break (=='\n') src if line1 /= "{- "++version++" -}" then cancel $ "Could not parse AbstractCurry file '" ++ fn ++ "': incompatible versions" else case readsUnqualifiedTerm ["AbstractCurry.Types","Prelude"] lines of [(p,tl)] | all isSpace tl -> return (Right p) _ -> cancel $ "Could not parse AbstractCurry file '" ++ fn ++ "': no parse" where cancel str = return (Left str) --- I/O action which parses a Curry program and returns the corresponding --- untyped AbstractCurry program. --- The argument is the file name without suffix ".curry" --- or ".lcurry") and the result is a Curry term representing this --- program. --- In an untyped AbstractCurry program, the type signatures --- of operations are the type signatures provided by the programmer --- (and not the type signatures inferred by the front end). --- If the programmer has not provided an explicit type signature, --- the function declaration contains the type `(CTCons ("Prelude","untyped")`. readUntypedCurry :: String -> IO CurryProg readUntypedCurry prog = readUntypedCurryWithParseOptions prog (setQuiet True defaultParams) --- I/O action which reads a typed Curry program from a file (with extension --- ".acy") with respect to some parser options. --- This I/O action is used by the standard action 'readCurry'. --- It is currently predefined only in Curry2Prolog. --- @param progfile - the program file name (without suffix ".curry") --- @param options - parameters passed to the front end readCurryWithParseOptions :: String -> FrontendParams -> IO CurryProg readCurryWithParseOptions progname options = do let modname = takeFileName progname mbsrc <- lookupModuleSourceInLoadPath progname case mbsrc of Nothing -> do -- no source file, try to find AbstractCurry file in load path: loadpath <- getLoadPathForModule progname filename <- getFileWithSuffix (abstractCurryFileName modname) [""] loadpath readAbstractCurryFile filename Just (dir,_) -> do callFrontendWithParams ACY options progname readAbstractCurryFile (abstractCurryFileName (dir modname)) --- I/O action which reads an untyped Curry program from a file (with extension --- ".uacy") with respect to some parser options. For more details --- see function 'readCurryWithParseOptions' --- In an untyped AbstractCurry program, the type signatures --- of operations are the type signatures provided by the programmer --- (and not the type signatures inferred by the front end). --- If the programmer has not provided an explicit type signature, --- the function declaration contains the type `(CTCons ("Prelude","untyped")`. readUntypedCurryWithParseOptions :: String -> FrontendParams -> IO CurryProg readUntypedCurryWithParseOptions progname options = do let modname = takeFileName progname mbsrc <- lookupModuleSourceInLoadPath progname case mbsrc of Nothing -> do -- no source file, try to find AbstractCurry file in load path: loadpath <- getLoadPathForModule progname filename <- getFileWithSuffix (untypedAbstractCurryFileName modname) [""] loadpath readAbstractCurryFile filename Just (dir,_) -> do callFrontendWithParams UACY options progname readAbstractCurryFile (untypedAbstractCurryFileName (dir modname)) --- Transforms a name of a Curry program (with or without suffix ".curry" --- or ".lcurry") into the name of the file containing the --- corresponding AbstractCurry program. abstractCurryFileName :: String -> String abstractCurryFileName prog = inCurrySubdir (stripCurrySuffix prog) <.> "acy" --- Transforms a name of a Curry program (with or without suffix ".curry" --- or ".lcurry") into the name of the file containing the --- corresponding untyped AbstractCurry program. untypedAbstractCurryFileName :: String -> String untypedAbstractCurryFileName prog = inCurrySubdir (stripCurrySuffix prog) <.> "uacy" --- I/O action which reads an AbstractCurry program from a file in ".acy" --- format. In contrast to readCurry, this action does not parse --- a source program. Thus, the argument must be the name of an existing --- file (with suffix ".acy") containing an AbstractCurry program in ".acy" --- format and the result is a Curry term representing this program. --- It is currently predefined only in Curry2Prolog. readAbstractCurryFile :: String -> IO CurryProg readAbstractCurryFile filename = do exacy <- doesFileExist filename if exacy then readExistingACY filename else do let subdirfilename = inCurrySubdir filename exdiracy <- doesFileExist subdirfilename if exdiracy then readExistingACY subdirfilename else error ("EXISTENCE ERROR: AbstractCurry file '"++filename++ "' does not exist") where readExistingACY fname = do filecontents <- readFile fname let (line1,lines) = break (=='\n') filecontents if line1 == "{- "++version++" -}" then return (readUnqualifiedTerm ["AbstractCurry.Types","Prelude"] lines) else error $ "AbstractCurry: incompatible file found: "++fname --- Tries to read an AbstractCurry file and returns --- --- * Left err , where err specifies the error occurred --- * Right prog, where prog is the AbstractCurry program tryReadACYFile :: String -> IO (Maybe CurryProg) tryReadACYFile fn = do exists <- doesFileExist fn if exists then tryRead fn else do let fn' = inCurrySubdir fn exists' <- doesFileExist fn' if exists' then tryRead fn' else cancel where tryRead file = do src <- readFile file let (line1,lines) = break (=='\n') src if line1 /= "{- "++version++" -}" then error $ "AbstractCurry: incompatible file found: "++fn else case readsUnqualifiedTerm ["AbstractCurry.Types","Prelude"] lines of [] -> cancel [(p,tl)] -> if all isSpace tl then return $ Just p else cancel _ -> cancel cancel = return Nothing --- Writes an AbstractCurry program into a file in ".acy" format. --- The first argument must be the name of the target file --- (with suffix ".acy"). writeAbstractCurryFile :: String -> CurryProg -> IO () writeAbstractCurryFile file prog = writeFile file (showTerm prog) ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/abstract-curry/src/AbstractCurry/Pretty.curry000066400000000000000000001327071377556325500272160ustar00rootroot00000000000000--- -------------------------------------------------------------------------- --- Pretty-printing of AbstractCurry. --- --- This library provides a pretty-printer for AbstractCurry modules. --- --- @author Yannik Potdevin (with changes by Michael Hanus) --- @version June 2018 --- -------------------------------------------------------------------------- module AbstractCurry.Pretty ( Qualification, Options, LayoutChoice(..) , defaultOptions , setPageWith, setIndentWith , setNoQualification, setFullQualification, setImportQualification , setOnDemandQualification , setModName, setLayoutChoice , showCProg, prettyCurryProg, ppCurryProg , ppMName, ppExports, ppImports , ppCOpDecl, ppCTypeDecl, ppCFuncDecl, ppCFuncDeclWithoutSig, ppCRhs , ppCFuncSignature, ppCQualTypeExpr, ppCTypeExpr, ppCRules, ppCRule , ppCPattern, ppCLiteral, ppCExpr , ppCStatement, ppQFunc, ppFunc, ppQType, ppType) where import AbstractCurry.Select hiding (varsOfLDecl, varsOfFDecl, varsOfStat) import AbstractCurry.Types import AbstractCurry.Transform (typesOfCurryProg, funcsOfCurryProg) import Data.Function (on) import Data.List (partition, union, scanl, last, nub, (\\)) import Data.Maybe (isJust, fromJust) import Text.Pretty hiding ( list, listSpaced, tupled, tupledSpaced , set , setSpaced ) import Prelude hiding ( empty ) type Collection a = [a] data Qualification = Full -- ^ Fully qualify every identifier, including those of the -- processed module and Prelude. | Imports -- ^ Fully qualify external identifiers, do not qualify local -- identifiers and those of Prelude. | OnDemand -- ^ Fully qualify only identifiers which need to be. | None -- ^ Do not qualify any function. deriving Eq --- The choice for a generally preferred layout. --- @cons PreferNestedLayout - prefer a layout where the arguments of --- long expressions are vertically aligned --- @cons PreferFilledLayout - prefer a layout where the arguments of --- long expressions are filled as long as possible --- into one line data LayoutChoice = PreferNestedLayout -- ^ Prefer -- a f a -- + b respectively b -- + ... c -- if an expression does not fit the page | PreferFilledLayout -- ^ Prefer -- a + b f a b -- + c + d respectively c d -- if an expression does not fit the page data Options = Options { pageWidth :: Int , indentationWidth :: Int , qualification :: Qualification , moduleName :: String {- Debugging flag (show signature of local functions or not). -} , showLocalSigs :: Bool , layoutChoice :: LayoutChoice {- A collection of all to this module visible types (i.e. all imported [prelude too] and self defined types) -- used to determine how to qualify, if Qualification`OnDemand` was chosen. -} , visibleTypes :: Collection QName {- A collection of all to this module visible functions and constructors (i.e. all imported [prelude too] and self defined ones) -- used to determine how to qualify, if Qualification `OnDemand` was chosen. -} , visibleFunctions :: Collection QName {- A collection of currently visible (depending on context) variables. Used to determine how to qualify, if Qualification `OnDemand` was chosen. -} , visibleVariables :: Collection CVarIName } --- The default options to pretty print a module. These are: --- * page width: 78 characters --- * indentation width: 2 characters --- * qualification method: qualify all imported names (except prelude names) --- * layout choice: prefer nested layout (see 'LayoutChoice') --- These options can be changed by corresponding setters --- ('setPageWith', 'setIndentWith', `set...Qualification`, 'setLayoutChoice'). --- --- Note: If these default options are used for pretty-print operations --- other than 'prettyCurryProg' or 'ppCurryProg', then one has to set --- the current module name explicitly by 'setModName'! defaultOptions :: Options defaultOptions = Options { pageWidth = 78 , indentationWidth = 2 , qualification = Imports , moduleName = "" , showLocalSigs = False , layoutChoice = PreferNestedLayout , visibleTypes = emptyCol , visibleFunctions = emptyCol , visibleVariables = emptyCol } --- Sets the page width of the pretty printer options. setPageWith :: Int -> Options -> Options setPageWith pw o = o { pageWidth = pw } --- Sets the indentation width of the pretty printer options. setIndentWith :: Int -> Options -> Options setIndentWith iw o = o { indentationWidth = iw } --- Sets the qualification method to be used to print identifiers to --- "import qualification" (which is the default). --- In this case, all identifiers imported from other modules (except --- for the identifiers of the prelude) are fully qualified. setImportQualification :: Options -> Options setImportQualification o = o { qualification = Imports } --- Sets the qualification method to be used to print identifiers to --- "unqualified". --- In this case, no identifiers is printed with its module qualifier. --- This might lead to name conflicts or unintended references --- if some identifiers in the pretty-printed module are in conflict --- with imported identifiers. setNoQualification :: Options -> Options setNoQualification o = o { qualification = None } --- Sets the qualification method to be used to print identifiers to --- "fully qualified". --- In this case, every identifiers, including those of the processed module --- and the prelude, are fully qualified. setFullQualification :: Options -> Options setFullQualification o = o { qualification = Full } --- Sets the qualification method to be used to print identifiers to --- "qualification on demand". --- In this case, an identifier is qualified only if it is necessary --- to avoid a name conflict, e.g., if a local identifier has the same --- names as an imported identifier. Since it is necessary to know --- the names of all identifiers defined in the current module (to be pretty --- printed) and imported from other modules, the first argument --- is the list of modules consisting of the current module and --- all imported modules (including the prelude). --- The current module must always be the head of this list. setOnDemandQualification :: [CurryProg] -> Options -> Options setOnDemandQualification mods o = setRelatedMods mods (o { qualification = OnDemand }) --- Sets the name of the current module in the pretty printer options. setModName :: MName -> Options -> Options setModName m o = o { moduleName = m } --- Sets the preferred layout in the pretty printer options. setLayoutChoice :: LayoutChoice -> Options -> Options setLayoutChoice lc o = o { layoutChoice = lc } --- Sets the related modules in the pretty printer options. See 'options' to --- read a specification of "related modules". setRelatedMods :: [CurryProg] -> Options -> Options setRelatedMods [] o = o setRelatedMods (currentMod:imports) o = o { visibleTypes = vts, visibleFunctions = vfs } where vts = fromList $ map typeName (types currentMod) ++ collect publicTypeNames vfs = fromList $ concat [ map funcName $ functions currentMod , collect publicFuncNames , map consName $ constructors currentMod , collect publicConsNames ] collect proj = foldr union [] $ map proj imports --- precedence of top level (pattern or application) context -- lowest tlPrec :: Int tlPrec = 0 --- precedence of infix (pattern or application) context infAppPrec :: Int infAppPrec = 1 --- precedence of standard prefix (pattern or application) context prefAppPrec :: Int prefAppPrec = 2 --- precedence of atoms (variables, literals, tuples, lists ...) highestPrec :: Int highestPrec = 3 --- Shows a pretty formatted version of an abstract Curry Program. --- The options for pretty-printing are the 'defaultOptions' (and therefore the --- restrictions mentioned there apply here too). --- @param prog - a curry prog --- @return a string, which represents the input program `prog` showCProg :: CurryProg -> String showCProg = prettyCurryProg defaultOptions --- Pretty-print the document generated by 'ppCurryProg', using the page width --- specified by given options. prettyCurryProg :: Options -> CurryProg -> String prettyCurryProg opts cprog = showWidth (pageWidth opts) $ ppCurryProg opts cprog --- Pretty-print a CurryProg (the representation of a program, written in Curry, --- using AbstractCurry) according to given options. --- This function will overwrite the module name given by options --- with the name specified as the first component of `CurryProg`. --- The list of imported modules is extended to all modules mentioned --- in the program if qualified pretty printing is used. --- This is necessary to avoid errors w.r.t. names re-exported by modules. ppCurryProg :: Options -> CurryProg -> Doc ppCurryProg opts cprog@(CurryProg m ms dfltdecl clsdecls instdecls ts fs os) = vsepBlank [ (nest' opts' $ sep [ text "module" <+> ppMName m, ppExports opts' ts fs]) where_ , ppImports opts' allImports , vcatMap (ppCOpDecl opts') os , ppCDefaultDecl opts' dfltdecl , vsepBlankMap (ppCClassDecl opts') clsdecls , vsepBlankMap (ppCInstanceDecl opts') instdecls , vsepBlankMap (ppCTypeDecl opts') ts , vsepBlankMap (ppCFuncDecl opts') fs ] where opts' = opts { moduleName = m } allModNames = filter (not . null) (union (nub (map fst (typesOfCurryProg cprog))) (nub (map fst (funcsOfCurryProg cprog)))) allImports = if qualification opts == None then ms else nub (ms ++ allModNames) \\ [m] --- Pretty-print a module name (just a string). ppMName :: MName -> Doc ppMName = text --- Pretty-print exports, i.e. all type and function declarations which are --- public. --- extract the type and function declarations which are public and gather their --- qualified names in a list. ppExports :: Options -> [CTypeDecl] -> [CFuncDecl] -> Doc ppExports opts ts fs | null pubTs && null pubFs = parens empty -- nothing is exported | null privTs && null privFs && null privCs = empty -- everything is exported | otherwise = filledTupledSpaced $ map tDeclToDoc pubTs ++ map fDeclToDoc pubFs where (pubTs, privTs) = partition isPublicTypeDecl ts (pubFs, privFs) = partition isPublicFuncDecl fs privCs = filter ((== Private) . consVis) . concatMap typeCons $ ts isPublicTypeDecl = (== Public) . typeVis isPublicFuncDecl = (== Public) . funcVis tDeclToDoc = on' (<>) (ppQTypeParsIfInfix opts . typeName) (ppConsExports opts . typeCons) fDeclToDoc = ppQFuncParsIfInfix opts . funcName -- internal use only ppConsExports :: Options -> [CConsDecl] -> Doc ppConsExports opts cDecls | null pubCs = empty | null privCs = parens $ dot <> dot | otherwise = filledTupled $ map cDeclToDoc pubCs where (pubCs, privCs) = partition isPublicConsDecl cDecls isPublicConsDecl = (== Public) . consVis cDeclToDoc = ppQFuncParsIfInfix opts . consName --- Pretty-print imports (list of module names) by prepending the word "import" --- to the module name. If the qualification mode is 'Imports' or 'Full', --- then the imports are declared as `qualified`. ppImports :: Options -> [MName] -> Doc ppImports opts imps = vcatMap (\m -> text importmode <+> ppMName m) (filter (/= "Prelude") imps) where importmode = if qualification opts `elem` [Imports,Full] then "import qualified" else "import" --- Pretty-print operator precedence declarations. ppCOpDecl :: Options -> COpDecl -> Doc ppCOpDecl _ (COp qn fix p) = hsep [ppCFixity fix, int p, genericPPName (bquotesIf . not . isInfixId) qn] --- Pretty-print the fixity of a function. ppCFixity :: CFixity -> Doc ppCFixity CInfixOp = text "infix" ppCFixity CInfixlOp = text "infixl" ppCFixity CInfixrOp = text "infixr" --- Pretty-print operator precedence declarations. ppCDefaultDecl :: Options -> Maybe CDefaultDecl -> Doc ppCDefaultDecl _ Nothing = empty ppCDefaultDecl opts (Just (CDefaultDecl texps)) = text "default" <+> filledTupled (map (ppCTypeExpr opts) texps) --- Pretty-print a class declaration. ppCClassDecl :: Options -> CClassDecl -> Doc ppCClassDecl opts (CClass qn _ ctxt tvar funcs) = hsep [ text "class", ppCContext opts ctxt, ppType qn, ppCTVarIName opts tvar , text "where"] <$!$> indent' opts (vsepBlankMap (ppCFuncClassDecl opts) funcs) --- Pretty-print an instance declaration. ppCInstanceDecl :: Options -> CInstanceDecl -> Doc ppCInstanceDecl opts (CInstance qn ctxt texp funcs) = hsep [ text "instance", ppCContext opts ctxt , ppQType opts qn, ppCTypeExpr' 2 opts texp, text "where"] <$!$> indent' opts (vsepBlankMap (ppCFuncDeclWithoutSig opts) funcs) --- Pretty-print type declarations, like `data ... = ...`, `type ... = ...` or --- `newtype ... = ...`. ppCTypeDecl :: Options -> CTypeDecl -> Doc ppCTypeDecl opts (CType qn _ tVars cDecls derivings) = hsep [ text "data", ppType qn, ppCTVarINames opts tVars , if null cDecls then empty else ppCConsDecls opts cDecls] <$!$> ppDeriving opts derivings ppCTypeDecl opts (CTypeSyn qn _ tVars tExp) = hsep [ text "type", ppType qn, ppCTVarINames opts tVars , align $ equals <+> ppCTypeExpr opts tExp] ppCTypeDecl opts (CNewType qn _ tVars cDecl derivings) = hsep [ text "newtype", ppType qn, ppCTVarINames opts tVars, equals , ppCConsDecl opts cDecl] <$!$> ppDeriving opts derivings --- Pretty-print deriving clause. ppDeriving :: Options -> [QName] -> Doc ppDeriving _ [] = empty ppDeriving opts [cn] = text " deriving" <+> ppQType opts cn ppDeriving opts cls@(_:_:_) = text " deriving" <+> alignedTupled (map (ppQType opts) cls) --- Pretty-print a list of constructor declarations, including the `=` sign. ppCConsDecls :: Options -> [CConsDecl] -> Doc ppCConsDecls opts cDecls = align . sep $ [equals <+> ppCConsDecl opts (head cDecls)] ++ map ((bar <+>) . (ppCConsDecl opts)) (tail cDecls) --- Pretty-print a constructor declaration. ppCConsDecl :: Options -> CConsDecl -> Doc ppCConsDecl opts (CCons qn _ tExps ) = hsep [ppFunc qn, hsepMap (ppCTypeExpr' 2 opts) tExps] ppCConsDecl opts (CRecord qn _ fDecls) = hsep [ppFunc qn <+> alignedSetSpaced (map (ppCFieldDecl opts) fDecls)] --- Pretty-print a record field declaration (`field :: type`). ppCFieldDecl :: Options -> CFieldDecl -> Doc ppCFieldDecl opts (CField qn _ tExp) = hsep [ ppFunc qn , doubleColon , ppCTypeExpr opts tExp ] --- Pretty-print a document comment. ppCDocComment :: String -> Doc ppCDocComment cmt = vsepMap (text . ("--- " ++)) (lines cmt) --- Pretty-print a function declaration occurring in a class declaration. ppCFuncClassDecl :: Options -> CFuncDecl -> Doc ppCFuncClassDecl opts fDecl@(CFunc qn _ _ tExp rs) = ppCFuncSignature opts qn tExp <$!$> ppCRulesWithoutExternal funcDeclOpts qn rs where funcDeclOpts = addFuncNamesToOpts (funcNamesOfFDecl fDecl) opts ppCFuncClassDecl opts (CmtFunc cmt qn a v tExp rs) = ppCDocComment cmt <$!$> ppCFuncClassDecl opts (CFunc qn a v tExp rs) --- Pretty-print a function declaration. ppCFuncDecl :: Options -> CFuncDecl -> Doc ppCFuncDecl opts fDecl@(CFunc qn _ _ tExp _) = ppCFuncSignature opts qn tExp <$!$> ppCFuncDeclWithoutSig opts fDecl ppCFuncDecl opts (CmtFunc cmt qn a v tExp rs) = ppCDocComment cmt <$!$> ppCFuncDecl opts (CFunc qn a v tExp rs) --- Pretty-print a function declaration without signature. ppCFuncDeclWithoutSig :: Options -> CFuncDecl -> Doc ppCFuncDeclWithoutSig opts fDecl@(CFunc qn _ _ _ rs) = ppCRules funcDeclOpts qn rs where funcDeclOpts = addFuncNamesToOpts (funcNamesOfFDecl fDecl) opts ppCFuncDeclWithoutSig opts (CmtFunc cmt qn a v tExp rs) = ppCDocComment cmt <$!$> ppCFuncDeclWithoutSig opts (CFunc qn a v tExp rs) --- Pretty-print a function signature according to given options. ppCFuncSignature :: Options -> QName -> CQualTypeExpr -> Doc ppCFuncSignature opts qn tExp | isUntyped tExp = empty | otherwise = nest' opts $ sep [ genericPPName parsIfInfix qn , align $ doubleColon <+> ppCQualTypeExpr opts tExp ] where isUntyped te = te == CQualType (CContext []) (CTCons (pre "untyped")) --- Pretty-print a qualified type expression. ppCQualTypeExpr :: Options -> CQualTypeExpr -> Doc ppCQualTypeExpr opts (CQualType clsctxt texp) = ppCContext opts clsctxt <+> ppCTypeExpr opts texp --- Pretty-print a class context. ppCContext :: Options -> CContext -> Doc ppCContext _ (CContext []) = empty ppCContext opts (CContext [clscon]) = ppCConstraint opts clscon <+> text "=>" ppCContext opts (CContext ctxt@(_:_:_)) = alignedTupled (map (ppCConstraint opts) ctxt) <+> text "=>" --- Pretty-print a single class constraint. ppCConstraint :: Options -> CConstraint -> Doc ppCConstraint opts (cn,texp) = ppQType opts cn <+> ppCTypeExpr' prefAppPrec opts texp --- Pretty-print a type expression. ppCTypeExpr :: Options -> CTypeExpr -> Doc ppCTypeExpr = ppCTypeExpr' tlPrec -- Internal use only: Pretty-print a type expression and make use of supplied -- precedence context. The supplied number represents the precedence of the -- enclosing expression. Higher values mean more precedence, so if the nested -- expression has lower precedence than the enclosing expression, the nested one -- has to be enclosed in parentheses. ppCTypeExpr' :: Int -> Options -> CTypeExpr -> Doc ppCTypeExpr' _ opts (CTVar tvar) = ppCTVarIName opts tvar ppCTypeExpr' p opts (CFuncType tExp1 tExp2) = parensIf (p > tlPrec) $ sep [ ppCTypeExpr' 1 opts tExp1, rarrow <+> ppCTypeExpr opts tExp2] ppCTypeExpr' _ opts (CTCons qn) = ppQType opts qn ppCTypeExpr' p opts texp@(CTApply tcon targ) = maybe (parensIf (p >= 2) $ ppCTypeExpr' 2 opts tcon <+> ppCTypeExpr' 2 opts targ) (\qn -> ppCTypeTConApply qn (argsOfApply texp)) (funOfApply texp) where ppCTypeTConApply qn targs | isListCons qn = brackets . ppCTypeExpr opts . head $ targs -- assume singleton | isTupleCons qn = alignedTupled $ map (ppCTypeExpr opts) targs | otherwise = parensIf (p >= 2) $ ppQType opts qn <+> hsepMap (ppCTypeExpr' 2 opts) targs funOfApply te = case te of CTApply (CTCons qn) _ -> Just qn CTApply tc _ -> funOfApply tc _ -> Nothing argsOfApply te = case te of CTApply (CTCons _) ta -> [ta] CTApply tc ta -> argsOfApply tc ++ [ta] _ -> [] -- should not occur --- Pretty-print a list of type variables horizontally separating them --- by `space`. ppCTVarINames :: Options -> [CTVarIName] -> Doc ppCTVarINames opts = hsepMap (ppCTVarIName opts) --- Pretty-print a type variable (currently the Int is ignored). ppCTVarIName :: Options -> CTVarIName -> Doc ppCTVarIName _ (_, tvar) = text tvar --- Pretty-print a list of function rules, concatenated vertically. --- If there are no rules, an external rule is printed. ppCRules :: Options -> QName -> [CRule] -> Doc ppCRules opts qn rs | null rs = genericPPName parsIfInfix qn <+> text "external" | otherwise = vcatMap (ppCRule opts qn) rs --- Pretty-print a list of function rules, concatenated vertically. --- If there are no rules, an empty document is returned. ppCRulesWithoutExternal :: Options -> QName -> [CRule] -> Doc ppCRulesWithoutExternal opts qn rs = if null rs then empty else vcatMap (ppCRule opts qn) rs --- Pretty-print a rule of a function. Given a function --- `f x y = x * y`, then `x y = x * y` is a rule consisting of `x y` as list of --- patterns and `x * y` as right hand side. ppCRule :: Options -> QName -> CRule -> Doc ppCRule opts qn rule@(CRule ps rhs) = (nest' opts $ sep [ ppCPattern opts (CPComb qn ps) {- exploit similarity between left hand side of rule and constructor pattern -} <+> (case rhs of CSimpleRhs _ _ -> equals CGuardedRhs _ _ -> empty ) , ppFuncRhs rhsOpts rhs ] ) $$ if null lDecls then empty else indent' opts $ ppWhereDecl whereOpts lDecls where lDecls = ldeclsOfRule rule whereOpts = addVarsToOpts (concatMap varsOfPat ps) opts rhsOpts = last $ optsWithIncreasingNamespaces varsOfLDecl funcNamesOfLDecl lDecls whereOpts --- Pretty-print a pattern expression. ppCPattern :: Options -> CPattern -> Doc ppCPattern = ppCPattern' tlPrec -- Internal use only: Pretty-print a pattern expression and make use of supplied -- precedence context. The supplied number represents the precedence of the -- enclosing pattern. Higher values mean more precedence, so if the nested -- pattern has lower precedence than the enclosing pattern, the nested one has -- to be enclosed in parentheses. ppCPattern' :: Int -> Options -> CPattern -> Doc ppCPattern' _ opts (CPVar pvar) = ppCVarIName opts pvar ppCPattern' _ opts (CPLit lit ) = ppCLiteral opts lit ppCPattern' p opts pat@(CPComb qn ps) | null ps = parsIfInfix qn qnDoc | isApp qn = parensIf (p >= prefAppPrec) $ ppCPattern' infAppPrec opts (ps !! 0) <+> ppCPattern' prefAppPrec opts (ps !! 1) | isTupleCons qn = filledTupled . map (ppCPattern opts) $ ps | isFinLis pat = let ps' = fromJust $ extractFiniteListPattern pat in alignedList . map (ppCPattern opts) $ ps' | isInfixId qn = case ps of [l, r] -> parensIf (p >= infAppPrec) $ hsep [ ppCPattern' p' opts l, qnDoc , ppCPattern' p' opts r ] _ -> prefixApp | otherwise = prefixApp where qnDoc = ppQFunc opts qn isApp = (== ("Prelude", "apply")) p' = if isInfixId qn then infAppPrec else prefAppPrec prefixApp = parensIf (p >= prefAppPrec) . nest' opts $ sep [ parsIfInfix qn qnDoc , align . (case layoutChoice opts of PreferFilledLayout -> fillSep PreferNestedLayout -> sep) . map (ppCPattern' p' opts) $ ps ] isFinLis = isJust . extractFiniteListPattern ppCPattern' _ opts (CPAs pvar p) = hcat [ppCVarIName opts pvar, at, ppCPattern' highestPrec opts p] ppCPattern' p opts (CPFuncComb qn ps) = ppCPattern' p opts (CPComb qn ps) ppCPattern' _ opts (CPLazy p ) = tilde <> ppCPattern' highestPrec opts p ppCPattern' _ opts (CPRecord qn rps) = ppQFunc opts qn <+> alignedSetSpaced (map (ppCFieldPattern opts) rps) --- Pretty-print a pattern variable (currently the Int is ignored). ppCVarIName :: Options -> CVarIName -> Doc ppCVarIName _ (_, pvar) = text pvar --- Pretty-print given literal (Int, Float, ...). ppCLiteral :: Options -> CLiteral -> Doc ppCLiteral _ (CIntc i) = int i ppCLiteral _ (CFloatc f) = float f ppCLiteral _ (CCharc c) = text $ show c ppCLiteral _ (CStringc s) | null s = text "\"\"" -- necessary for pakcs | otherwise = text $ show s --- Pretty-print a record pattern ppCFieldPattern :: Options -> CField CPattern -> Doc ppCFieldPattern opts (qn, p) = ppQFunc opts qn <+> equals <+> ppCPattern opts p --- Pretty-print the right hand side of a rule (or case expression), including --- the d sign, where `d` is the relation (as doc) between the left hand side --- and the right hand side -- usually this is one of `=`, `->`. --- If the right hand side contains local declarations, they will be pretty --- printed too, further indented. ppCRhs :: Doc -> Options -> CRhs -> Doc ppCRhs d opts rhs = case rhs of CSimpleRhs exp lDecls -> (nest' opts $ sep [d, ppCExpr (expAndGuardOpts lDecls) exp]) $$ maybePPlDecls lDecls CGuardedRhs conds lDecls -> ppCGuardedRhs (expAndGuardOpts lDecls) d conds $$ maybePPlDecls lDecls where expAndGuardOpts ls = last $ optsWithIncreasingNamespaces varsOfLDecl funcNamesOfLDecl ls opts maybePPlDecls ls = if null ls then empty else indent' opts (ppWhereDecl opts ls) --- Like 'ppCRhs', but do not pretty-print local declarations. --- Instead give caller the choice how to handle the declarations. For example --- the function 'ppCRule' uses this to prevent local declarations from being --- further indented. ppFuncRhs :: Options -> CRhs -> Doc {- No further enrichment of options necessary -- it was done in 'ppCRule' -} ppFuncRhs opts (CSimpleRhs exp _) = ppCExpr opts exp ppFuncRhs opts (CGuardedRhs conds _) = ppCGuardedRhs opts equals conds ppCaseRhs :: Options -> CRhs -> Doc ppCaseRhs = ppCRhs rarrow --- Pretty-print guard, i.e. the `| cond d exp` part of a right hand side, where --- `d` is the relation (as doc) between `cond` and `exp` -- usually this is --- one of `=`, `->`. ppCGuardedRhs :: Options -> Doc -> [(CExpr, CExpr)] -> Doc ppCGuardedRhs opts d = align . vvsepMap ppCGuard where ppCGuard (e1, e2) = sep [ bar <+> ppCExpr opts e1 , d <+> ppCExpr opts e2 ] --- Pretty-print local declarations . If the second argument is `text "where"`, --- pretty-print a `where` block. If the second argument is `text "let"`, --- pretty-print a `let` block without `in`. ppCLocalDecls :: Options -> Doc -> [CLocalDecl] -> Doc ppCLocalDecls opts d lDecls = (d <+>) . align . vvsepMap (ppCLocalDecl lDeclOpts) $ lDecls where lDeclOpts = last $ optsWithIncreasingNamespaces varsOfLDecl funcNamesOfLDecl lDecls opts --- Pretty-print local declarations (the part that follows the `where` keyword). ppCLocalDecl :: Options -> CLocalDecl -> Doc ppCLocalDecl opts (CLocalFunc fDecl) = if showLocalSigs opts then ppCFuncDecl opts fDecl else ppCFuncDeclWithoutSig opts fDecl ppCLocalDecl opts (CLocalPat p rhs) = hsep [ ppCPattern opts p, ppCRhs equals rhsOpts rhs ] where rhsOpts = addVarsToOpts (varsOfPat p) opts ppCLocalDecl opts (CLocalVars pvars) = (<+> text "free") $ hsep $ punctuate comma $ map (ppCVarIName opts) pvars --- Pretty-print a `where` block, in which the word `where` stands alone in a --- single line, above the following declarations. ppWhereDecl :: Options -> [CLocalDecl] -> Doc ppWhereDecl opts lDecls = (where_ $$) . indent' opts . vvsepMap (ppCLocalDecl lDeclOpts) $ lDecls where lDeclOpts = last $ optsWithIncreasingNamespaces varsOfLDecl funcNamesOfLDecl lDecls opts --- Pretty-print a `let` block without `in`. In contrast to 'ppWhereDecl', the --- word `let` is in the same line as the first local declaration. ppLetDecl :: Options -> [CLocalDecl] -> Doc ppLetDecl opts = ppCLocalDecls opts (text "let") --- Pretty-print an expression. ppCExpr :: Options -> CExpr -> Doc ppCExpr = ppCExpr' tlPrec -- Internal use only: Pretty-print an expression and make use of supplied -- precedence context. The supplied number represents the precedence of the -- enclosing expression. Higher values mean more precedence, so if the nested -- expression has lower precedence than the enclosing expression, the nested one -- has to be enclosed in parentheses. ppCExpr' :: Int -> Options -> CExpr -> Doc ppCExpr' _ opts (CVar pvar) = ppCVarIName opts pvar ppCExpr' _ opts (CLit lit ) = ppCLiteral opts lit ppCExpr' _ opts (CSymbol qn ) = ppQFuncParsIfInfix opts qn ppCExpr' p opts app@(CApply f exp) | isITE app = parensIf (p > tlPrec) $ let (c, t, e) = fromJust $ extractITE app in text "if" <+> (align $ sep [ ppCExpr opts c , text "then" <+> ppCExpr opts t , text "else" <+> ppCExpr opts e]) | isTup app = let args = fromJust $ extractTuple app in alignedTupled (map (ppCExpr opts) args) | isFinLis app = let elems = fromJust $ extractFiniteListExp app in (case layoutChoice opts of PreferNestedLayout -> alignedList PreferFilledLayout -> filledList ) (map (ppCExpr opts) elems) | isInf app = parensIf (p >= infAppPrec) $ let (op, l, r) = fromJust $ extractInfix app in (case layoutChoice opts of PreferNestedLayout -> ppNestedWay PreferFilledLayout -> ppFilledWay) (ppCExpr' infAppPrec opts l) (ppQFunc opts op) (ppCExpr' infAppPrec opts r) | otherwise = parensIf (p >= prefAppPrec) $ (case layoutChoice opts of PreferNestedLayout -> ppNestedWay PreferFilledLayout -> ppFilledWay) (ppCExpr' infAppPrec opts f) empty (ppCExpr' prefAppPrec opts exp) where isITE = isJust . extractITE isInf = isJust . extractInfix isTup = isJust . extractTuple isFinLis = isJust . extractFiniteListExp ppNestedWay l sepa r = align . nest 1 $ sep [l, sepa <+> r] ppFilledWay l sepa r = nest 1 $ fillSep [l, sepa, r] ppCExpr' p opts (CLambda ps exp) = parensIf (p > tlPrec) . nest' opts $ sep [ backslash <> hsepMap (ppCPattern' prefAppPrec opts) ps <+> rarrow , ppCExpr expOpts exp] where expOpts = addVarsToOpts (concatMap varsOfPat ps) opts ppCExpr' p opts (CLetDecl lDecls exp) = parensIf (p > tlPrec) . align {- 'ppLetDecl' itself ensures the correct handling of opts -} $ sep [ ppLetDecl opts lDecls, text "in" <+> ppCExpr expOpts exp] where expOpts = last $ optsWithIncreasingNamespaces varsOfLDecl funcNamesOfLDecl lDecls opts ppCExpr' p opts (CDoExpr stms) = parensIf (p > tlPrec) $ text "do" <+> align (vvsep $ zipWith ppCStatement statOptsList stms) where statOptsList = optsWithIncreasingNamespaces varsOfStat funcNamesOfStat stms opts ppCExpr' _ opts (CListComp exp stms) = brackets $ hsep [ ppCExpr expOpts exp, bar , hsep $ punctuate (comma <> space) (zipWith ppCStatement statOptsList stms)] where expOpts = last statOptsList statOptsList = optsWithIncreasingNamespaces varsOfStat funcNamesOfStat stms opts ppCExpr' p opts (CCase cType exp cases) = parensIf (p > tlPrec) . align . nest' opts $ sep [ ppCCaseType cType <+> ppCExpr opts exp <+> text "of" , ppCases opts cases] ppCExpr' p opts (CTyped exp tExp) = parensIf (p > tlPrec) $ hsep [ppCExpr opts exp, doubleColon, ppCQualTypeExpr opts tExp] ppCExpr' _ opts (CRecConstr qn rFields) = ppQFunc opts qn <+> ppRecordFields opts rFields ppCExpr' p opts (CRecUpdate exp rFields) = ppCExpr' p opts exp <+> ppRecordFields opts rFields ppCStatement :: Options -> CStatement -> Doc ppCStatement opts (CSExpr exp ) = ppCExpr opts exp ppCStatement opts (CSPat pat exp) = ppCPattern opts pat <+> larrow <+> ppCExpr opts exp ppCStatement opts (CSLet lDecls ) = ppLetDecl opts lDecls --- Pretty-print `case`, `fcase` keywords. ppCCaseType :: CCaseType -> Doc ppCCaseType CRigid = text "case" ppCCaseType CFlex = text "fcase" --- Pretty-print a list of case expressions, i.e. the `p1 -> e1`,...,`pn -> en`, --- transitions, vertically aligned. ppCases :: Options -> [(CPattern, CRhs)] -> Doc ppCases opts = align . vvsepMap (ppCase opts) --- Pretty-print a case expression. ppCase :: Options -> (CPattern, CRhs) -> Doc ppCase opts (p, rhs) = ppCPattern opts p <+> ppCaseRhs rhsOpts rhs where rhsOpts = addVarsToOpts (varsOfPat p) opts --- Pretty-print record field assignments like this: --- { lab1 = exp1, ..., labn expn } --- if it fits the page, or --- { lab1 = exp1 --- , ... --- , labn = expn } --- otherwise. ppRecordFields :: Options -> [CField CExpr] -> Doc ppRecordFields opts = alignedSetSpaced . map (ppRecordField opts) --- Pretty-print a record field assignment (`fieldLabel = exp`). ppRecordField :: Options -> CField CExpr -> Doc ppRecordField opts (qn, exp) = ppQFunc opts qn <+> equals <+> ppCExpr opts exp --- Pretty-print a QName qualified according to given options. --- @param visNames - Depending on call, this is the namespace of visible types --- or of visible functions. Used to determine if `qn` is --- ambiguous, in case the qualification method 'OnDemand' was --- chosen --- @param visVars - The in current context visible variables. --- @param g - A doc tranformer used to manipulate (f.e. surround with --- parentheses) the QName, after it was (maybe) qualified. --- @param opts - The options to use. --- @param qn - The `QName` to pretty-print. --- @return A pretty-printed `QName`, maybe qualified (depending on settings). genericPPQName :: Collection QName -> Collection CVarIName -> (QName -> Doc -> Doc) -> Options -> QName -> Doc genericPPQName visNames visVars g opts qn@(m, f) | qnIsBuiltIn = name | null m = name -- assume local declaration | otherwise = case qualification opts of Full -> qName Imports -> if m == moduleName opts || m == "Prelude" then name else qName OnDemand -> if m == moduleName opts then name else odName -- at this point we know qn is imported None -> name where qnIsBuiltIn = or (map ($ qn) [ isUnitCons , isListCons , isTupleCons, isConsCons ]) name = g qn (text f) qName = g qn $ ppMName m <> dot <> text f odName = if isShadowed qn || isAmbiguous qn then qName else name isAmbiguous n = anyCol (on' (&&) (sameName n) (diffMod n)) visNames isShadowed n = anyCol (sameName n) visVars diffMod = (/=) `on` fst sameName (_,x) (_,y) = x == y genericPPName :: (QName -> Doc -> Doc) -> QName -> Doc genericPPName f qn = f qn $ text . snd $ qn --- Pretty-print a function name or constructor name qualified according to --- given options. Use 'ppQType' or 'ppType' for pretty-printing type names. ppQFunc :: Options -> QName -> Doc ppQFunc opts = genericPPQName (visibleFunctions opts) (visibleVariables opts) (flip const) opts --- Like 'ppQFunc', but surround name with parentheses if it is an infix --- identifier. ppQFuncParsIfInfix :: Options -> QName -> Doc ppQFuncParsIfInfix opts = genericPPQName (visibleFunctions opts) (visibleVariables opts) parsIfInfix opts --- Pretty-print a function name or constructor name non-qualified. --- Use 'ppQType' or 'ppType' for pretty-printing type names. ppFunc :: QName -> Doc ppFunc = genericPPName (flip const) --- Pretty-print a type (`QName`) qualified according to given options. ppQType :: Options -> QName -> Doc ppQType opts = genericPPQName (visibleTypes opts) emptyCol (flip const) opts --- Like 'ppQType', but surround name with parentheses if it is an infix --- identifier. ppQTypeParsIfInfix :: Options -> QName -> Doc ppQTypeParsIfInfix opts = genericPPQName (visibleTypes opts) emptyCol parsIfInfix opts --- Pretty-print a type (`QName`) non-qualified. ppType :: QName -> Doc ppType = genericPPName (flip const) -- Helping function (diagnosis) --- Check whether an operator is an infix identifier. isInfixId :: QName -> Bool isInfixId = all (`elem` "~!@#$%^&*+-=<>:?./|\\") . snd --- Check whether an identifier represents the unit constructor isUnitCons :: QName -> Bool isUnitCons (_, i) = i == "()" --- Check whether an identifier represents the empty list constructor isListCons :: QName -> Bool isListCons (_, i) = i == "[]" --- Check whether an identifier represents the list constructor `:` isConsCons :: QName -> Bool isConsCons (_, i) = i == ":" --- Check whether an identifier represents a tuple constructor isTupleCons :: QName -> Bool isTupleCons (_, i) = i == mkTuple (length i) where mkTuple n = '(' : replicate (n - 2) ',' ++ ")" --- Check if given application tree represents an if then else construct. --- If so, return the condition, the "then expression" and the "else expression". --- Otherwise, return `Nothing`. extractITE :: CExpr -> Maybe (CExpr, CExpr, CExpr) extractITE e = case e of CApply (CApply (CApply (CSymbol ("Prelude","if_then_else")) cond) tExp) fExp -> Just (cond, tExp, fExp) _ -> Nothing --- Check if given application tree represents an infix operator application. --- If so, return the operator, its left and its right argument. Otherwise, --- return `Nothing`. extractInfix :: CExpr -> Maybe (QName, CExpr, CExpr) extractInfix e = case e of CApply (CApply (CSymbol s) e1) e2 | isInfixId s -> Just (s, e1, e2) _ -> Nothing --- Check if given application tree represents a tuple contructor application. --- If so, return the constructor and its arguments in a list. Otherwise, return --- `Nothing`. extractTuple :: CExpr -> Maybe [CExpr] extractTuple = extractTuple' [] where extractTuple' es exp = case exp of CApply f e -> extractTuple' (e:es) f CSymbol s | isTupleCons s -> Just es _ -> Nothing --- Check if given application tree represents a finite list `[x1, ..., xn]`. --- If so, return the list elements in a list. Otherwise, return `Nothing`. extractFiniteListExp :: CExpr -> Maybe [CExpr] extractFiniteListExp = extractFiniteListExp' [] where extractFiniteListExp' es exp = case exp of CApply (CApply (CSymbol f) e) arg | isConsCons f -> extractFiniteListExp' (e:es) arg CSymbol s | isListCons s -> Just $ reverse es _ -> Nothing --- Check if given construct pattern represents a finite list `[x1, ..., xn]`. --- If so, return the list elements in a list. Otherwise, return `Nothing`. extractFiniteListPattern :: CPattern -> Maybe [CPattern] extractFiniteListPattern = extractFiniteListPattern' [] where extractFiniteListPattern' es pat = case pat of CPComb qn [e, t] | isConsCons qn -> extractFiniteListPattern' (e:es) t CPComb qn [] | isListCons qn -> Just $ reverse es _ -> Nothing -- Helping functions (pretty-printing) hsepMap :: (a -> Doc) -> [a] -> Doc hsepMap f = hsep . map f vcatMap :: (a -> Doc) -> [a] -> Doc vcatMap f = vcat . map f vsepMap :: (a -> Doc) -> [a] -> Doc vsepMap f = vsep . map f vsepBlankMap :: (a -> Doc) -> [a] -> Doc vsepBlankMap f = vsepBlank . map f vvsep :: [Doc] -> Doc vvsep = compose (<$!$>) vvsepMap :: (a -> Doc) -> [a] -> Doc vvsepMap f = vvsep . map f fillSepMap :: (a -> Doc) -> [a] -> Doc fillSepMap f = fillSep . map f encloseSepSpaced :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseSepSpaced l r s = encloseSep (l <> space) (space <> r) (s <> space) alignedList :: [Doc] -> Doc alignedList = encloseSep lbracket rbracket comma filledList :: [Doc] -> Doc filledList = fillEncloseSep lbracket rbracket comma alignedSetSpaced :: [Doc] -> Doc alignedSetSpaced = encloseSepSpaced lbrace rbrace comma alignedTupled :: [Doc] -> Doc alignedTupled = encloseSep lparen rparen comma filledTupled :: [Doc] -> Doc filledTupled = fillEncloseSep lparen rparen comma filledTupledSpaced :: [Doc] -> Doc filledTupledSpaced = fillEncloseSepSpaced lparen rparen comma nest' :: Options -> Doc -> Doc nest' opts = nest (indentationWidth opts) indent' :: Options -> Doc -> Doc indent' opts = indent (indentationWidth opts) bquotesIf :: Bool -> Doc -> Doc bquotesIf b d = if b then bquotes d else d parsIfInfix :: QName -> Doc -> Doc parsIfInfix = parensIf . isInfixId larrow :: Doc larrow = text "<-" where_ :: Doc where_ = text "where" nil :: Doc nil = text "[]" -- Helping functions (various) on' :: (b -> b -> c) -> (a -> b) -> (a -> b) -> a -> c on' comb f g x = f x `comb` g x -- Helping functions (CRUD functions for Collection) emptyCol :: Collection a emptyCol = [] appendCol :: Collection a -> Collection a -> Collection a appendCol = (++) anyCol :: (a -> Bool) -> Collection a -> Bool anyCol = any fromList :: [a] -> Collection a fromList = id -- Helping functions (management of visible names) addVarsToOpts :: [CVarIName] -> Options -> Options addVarsToOpts vs o = o { visibleVariables = fromList vs `appendCol` visibleVariables o } addFuncNamesToOpts :: [QName] -> Options -> Options addFuncNamesToOpts ns o = o { visibleFunctions = fromList ns `appendCol` visibleFunctions o } addVarsAndFuncNamesToOpts :: [CVarIName] -> [QName] -> Options -> Options addVarsAndFuncNamesToOpts vs ns = addVarsToOpts vs . addFuncNamesToOpts ns --- Generates a list of options with increasing numbers of visible variables --- and function names. Resulting lists are useful to match the scopes of --- do expressions and list comprehensions, where latter statements see previous --- variables and functions names, but prior elements do not see subsequent --- variables and function names. --- Note that `last $ optsWithIncreasingNamespaces varsOf funcNamesOf xs opts` --- are options which contain all variables and function names of xs. --- @param varsOf - a projection function --- @param funcNamesOf - a projection function --- @xs - a list [x1, x2, ...] of elements to which the projection functions --- will be applied --- @param opts - root options --- @return a list `[opts0, opts1, opts2, ...]`, where --- `opts == opts0`, --- `opts1 == opts0` plus vars and funcNames of `x1`, --- `opts2 == opts1` plus vars and funcNames of `x2`, --- ... optsWithIncreasingNamespaces :: (a -> [CVarIName]) -> (a -> [QName]) -> [a] -> Options -> [Options] optsWithIncreasingNamespaces varsOf funcNamesOf xs opts = scanl (flip . uncurry $ addVarsAndFuncNamesToOpts) opts varsAndFuncNamesOfXs where varsAndFuncNamesOfXs = map varsOf xs `zip` map funcNamesOf xs -- Helping function (gather variables occurring in argument) --- In contrast to `AbstractCurry.Select.varsOfLDecl`, this function does not --- include variables of right hand sides. varsOfLDecl :: CLocalDecl -> [CVarIName] varsOfLDecl (CLocalFunc f ) = varsOfFDecl f varsOfLDecl (CLocalPat p _) = varsOfPat p varsOfLDecl (CLocalVars lvars ) = lvars --- In contrast to `AbstractCurry.Select.varsOfFDecl`, this function does not --- include variables of right hand sides. varsOfFDecl :: CFuncDecl -> [CVarIName] varsOfFDecl (CFunc _ _ _ _ r) = concatMap varsOfRule r varsOfFDecl (CmtFunc _ _ _ _ _ r) = concatMap varsOfRule r where varsOfRule (CRule pats _) = concatMap varsOfPat pats --- In contrast to `AbstractCurry.Select.varsOfStat`, this function does not --- include variables of right hand sides. varsOfStat :: CStatement -> [CVarIName] varsOfStat (CSExpr _ ) = [] varsOfStat (CSPat p _) = varsOfPat p varsOfStat (CSLet ld ) = concatMap varsOfLDecl ld curry-tools-v3.3.0/cpm/vendor/abstract-curry/src/AbstractCurry/Select.curry000066400000000000000000000304261377556325500271410ustar00rootroot00000000000000------------------------------------------------------------------------ --- This library provides some useful operations to select components --- in AbstractCurry programs, i.e., it provides a collection of --- selector functions for AbstractCurry. --- --- @version October 2016 --- @category meta ------------------------------------------------------------------------ module AbstractCurry.Select ( progName, imports, functions, constructors, types, publicFuncNames , publicConsNames, publicTypeNames , typeOfQualType, classConstraintsOfQualType , typeName, typeVis, typeCons , consName, consVis , isBaseType, isPolyType, isFunctionalType, isIOType, isIOReturnType , argTypes, resultType, tvarsOfType, tconsOfType, modsOfType, tconsArgsOfType , funcName, funcArity, funcComment, funcVis, funcType, funcRules , ruleRHS, ldeclsOfRule , varsOfPat, varsOfExp, varsOfRhs, varsOfStat, varsOfLDecl , varsOfFDecl, varsOfRule , funcNamesOfLDecl, funcNamesOfFDecl, funcNamesOfStat , isPrelude ) where import AbstractCurry.Types import Data.List (union) ------------------------------------------------------------------------ -- Selectors for curry programs -- Returns the name of a given Curry program. progName :: CurryProg -> String progName (CurryProg modname _ _ _ _ _ _ _) = modname --- Returns the imports (module names) of a given Curry program. imports :: CurryProg -> [MName] imports (CurryProg _ ms _ _ _ _ _ _) = ms --- Returns the function declarations of a given Curry program. functions :: CurryProg -> [CFuncDecl] functions (CurryProg _ _ _ _ _ _ fs _) = fs --- Returns all constructors of given Curry program. constructors :: CurryProg -> [CConsDecl] constructors = concatMap typeCons . types --- Returns the type declarations of a given Curry program. types :: CurryProg -> [CTypeDecl] types (CurryProg _ _ _ _ _ ts _ _) = ts --- Returns the names of all visible functions in given Curry program. publicFuncNames :: CurryProg -> [QName] publicFuncNames = map funcName . filter ((== Public) . funcVis) . functions --- Returns the names of all visible constructors in given Curry program. publicConsNames :: CurryProg -> [QName] publicConsNames = map consName . filter ((== Public) . consVis) . constructors --- Returns the names of all visible types in given Curry program. publicTypeNames :: CurryProg -> [QName] publicTypeNames = map typeName . filter ((== Public) . typeVis) . types ------------------------------------------------------------------------ -- Selectors for type expressions --- Returns the type expression of a qualified type. typeOfQualType :: CQualTypeExpr -> CTypeExpr typeOfQualType (CQualType _ te) = te --- Returns the class constraints of a qualified type. classConstraintsOfQualType :: CQualTypeExpr -> [CConstraint] classConstraintsOfQualType (CQualType (CContext cc) _) = cc --- Returns the name of a given type declaration typeName :: CTypeDecl -> QName typeName (CType n _ _ _ _) = n typeName (CTypeSyn n _ _ _ ) = n typeName (CNewType n _ _ _ _) = n --- Returns the visibility of a given type declaration. typeVis :: CTypeDecl -> CVisibility typeVis (CType _ vis _ _ _) = vis typeVis (CTypeSyn _ vis _ _ ) = vis typeVis (CNewType _ vis _ _ _) = vis --- Returns the constructors of a given type declaration. typeCons :: CTypeDecl -> [CConsDecl] typeCons (CType _ _ _ cs _) = cs typeCons (CTypeSyn _ _ _ _ ) = [] typeCons (CNewType _ _ _ c _) = [c] --- Returns the name of a given constructor declaration. consName :: CConsDecl -> QName consName (CCons n _ _) = n consName (CRecord n _ _) = n --- Returns the visibility of a given constructor declaration. consVis :: CConsDecl -> CVisibility consVis (CCons _ vis _) = vis consVis (CRecord _ vis _) = vis --- Returns true if the type expression is a base type. isBaseType :: CTypeExpr -> Bool isBaseType texp = case texp of CTCons _ -> True _ -> False --- Returns true if the type expression contains type variables. isPolyType :: CTypeExpr -> Bool isPolyType (CTVar _) = True isPolyType (CFuncType domain range) = isPolyType domain || isPolyType range isPolyType (CTCons _) = False isPolyType (CTApply tcon texp) = isPolyType tcon || isPolyType texp --- Returns true if the type expression is a functional type. isFunctionalType :: CTypeExpr -> Bool isFunctionalType texp = case texp of CFuncType _ _ -> True _ -> False --- Returns true if the type expression is (IO t). isIOType :: CTypeExpr -> Bool isIOType texp = case texp of CTApply (CTCons tc) _ -> tc == pre "IO" _ -> False --- Returns true if the type expression is (IO t) with t/=() and --- t is not functional isIOReturnType :: CTypeExpr -> Bool isIOReturnType (CTVar _) = False isIOReturnType (CFuncType _ _) = False isIOReturnType (CTCons _) = False isIOReturnType (CTApply tcon targ) = tcon == CTCons (pre "IO") && targ /= CTCons (pre "()") && not (isFunctionalType targ) --- Returns all argument types from a functional type argTypes :: CTypeExpr -> [CTypeExpr] argTypes texp = case texp of CFuncType t1 t2 -> t1 : argTypes t2 _ -> [] --- Return the result type from a (nested) functional type resultType :: CTypeExpr -> CTypeExpr resultType texp = case texp of CFuncType _ t2 -> resultType t2 _ -> texp --- Returns all type variables occurring in a type expression. tvarsOfType :: CTypeExpr -> [CTVarIName] tvarsOfType (CTVar v) = [v] tvarsOfType (CFuncType t1 t2) = tvarsOfType t1 ++ tvarsOfType t2 tvarsOfType (CTCons _) = [] tvarsOfType (CTApply t1 t2) = tvarsOfType t1 ++ tvarsOfType t2 --- Returns all type constructors used in the given type. tconsOfType :: CTypeExpr -> [QName] tconsOfType (CTVar _) = [] tconsOfType (CFuncType t1 t2) = tconsOfType t1 `union` tconsOfType t2 tconsOfType (CTCons tc) = [tc] tconsOfType (CTApply t1 t2) = tconsOfType t1 `union` tconsOfType t2 --- Returns all modules used in the given type. modsOfType :: CTypeExpr -> [String] modsOfType = map fst . tconsOfType --- Transforms a type constructor application into a pair of the type --- constructor and the argument types, if possible. tconsArgsOfType :: CTypeExpr -> Maybe (QName,[CTypeExpr]) tconsArgsOfType (CTVar _) = Nothing tconsArgsOfType (CFuncType _ _) = Nothing tconsArgsOfType (CTCons tc) = Just (tc,[]) tconsArgsOfType (CTApply te ta) = maybe Nothing (\ (tc,targs) -> Just (tc,targs++[ta])) (tconsArgsOfType te) ------------------------------------------------------------------------ -- Selectors for function definitions --- Returns the name of a given function declaration. funcName :: CFuncDecl -> QName funcName (CFunc n _ _ _ _) = n funcName (CmtFunc _ n _ _ _ _) = n -- Returns the visibility of a given function declaration. funcArity :: CFuncDecl -> Int funcArity (CFunc _ a _ _ _) = a funcArity (CmtFunc _ _ a _ _ _) = a --- Returns the documentation comment of a given function declaration. funcComment :: CFuncDecl -> String funcComment (CFunc _ _ _ _ _) = "" funcComment (CmtFunc cmt _ _ _ _ _) = cmt --- Returns the visibility of a given function declaration. funcVis :: CFuncDecl -> CVisibility funcVis (CFunc _ _ vis _ _) = vis funcVis (CmtFunc _ _ _ vis _ _) = vis --- Returns the type of a given function declaration. funcType :: CFuncDecl -> CQualTypeExpr funcType (CFunc _ _ _ texp _) = texp funcType (CmtFunc _ _ _ _ texp _) = texp --- Returns the rules of a given function declaration. funcRules :: CFuncDecl -> [CRule] funcRules (CFunc _ _ _ _ rules) = rules funcRules (CmtFunc _ _ _ _ _ rules) = rules ------------------------------------------------------------------------ -- Selectors for rules. --- Returns the right-hand side of a rules. ruleRHS :: CRule -> CRhs ruleRHS (CRule _ rhs) = rhs --- Returns the local declarations of given rule. ldeclsOfRule :: CRule -> [CLocalDecl] ldeclsOfRule (CRule _ (CSimpleRhs _ lDecls)) = lDecls ldeclsOfRule (CRule _ (CGuardedRhs _ lDecls)) = lDecls ------------------------------------------------------------------------ -- Operations to compute the variables occurring in a pattern or expression: --- Returns list of all variables occurring in a pattern. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfPat :: CPattern -> [CVarIName] varsOfPat (CPVar v) = [v] varsOfPat (CPLit _) = [] varsOfPat (CPComb _ pats) = concatMap varsOfPat pats varsOfPat (CPAs v pat) = v : varsOfPat pat varsOfPat (CPFuncComb _ pats) = concatMap varsOfPat pats varsOfPat (CPLazy pat) = varsOfPat pat varsOfPat (CPRecord _ recpats) = concatMap (varsOfPat . snd) recpats --- Returns list of all variables occurring in an expression. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfExp :: CExpr -> [CVarIName] varsOfExp (CVar v) = [v] varsOfExp (CLit _) = [] varsOfExp (CSymbol _) = [] varsOfExp (CApply e1 e2) = varsOfExp e1 ++ varsOfExp e2 varsOfExp (CLambda pl le) = concatMap varsOfPat pl ++ varsOfExp le varsOfExp (CLetDecl ld le) = concatMap varsOfLDecl ld ++ varsOfExp le varsOfExp (CDoExpr sl) = concatMap varsOfStat sl varsOfExp (CListComp le sl) = varsOfExp le ++ concatMap varsOfStat sl varsOfExp (CCase _ ce bl) = varsOfExp ce ++ concatMap (\ (p,rhs) -> varsOfPat p ++ varsOfRhs rhs) bl varsOfExp (CTyped te _) = varsOfExp te varsOfExp (CRecConstr _ upds) = concatMap (varsOfExp . snd) upds varsOfExp (CRecUpdate e upds) = varsOfExp e ++ concatMap (varsOfExp . snd) upds --- Returns list of all variables occurring in a right-hand side. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfRhs :: CRhs -> [CVarIName] varsOfRhs (CSimpleRhs rhs ldecls) = varsOfExp rhs ++ concatMap varsOfLDecl ldecls varsOfRhs (CGuardedRhs gs ldecls) = concatMap (\ (g,e) -> varsOfExp g ++ varsOfExp e) gs ++ concatMap varsOfLDecl ldecls --- Returns list of all variables occurring in a statement. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfStat :: CStatement -> [CVarIName] varsOfStat (CSExpr e) = varsOfExp e varsOfStat (CSPat p e) = varsOfPat p ++ varsOfExp e varsOfStat (CSLet ld) = concatMap varsOfLDecl ld --- Returns list of all variables occurring in a local declaration. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfLDecl :: CLocalDecl -> [CVarIName] varsOfLDecl (CLocalFunc f) = varsOfFDecl f varsOfLDecl (CLocalPat p rhs) = varsOfPat p ++ varsOfRhs rhs varsOfLDecl (CLocalVars lvars) = lvars --- Returns list of all variables occurring in a function declaration. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfFDecl :: CFuncDecl -> [CVarIName] varsOfFDecl (CFunc _ _ _ _ r) = concatMap varsOfRule r varsOfFDecl (CmtFunc _ _ _ _ _ r) = concatMap varsOfRule r --- Returns list of all variables occurring in a rule. --- Each occurrence corresponds to one element, i.e., the list might --- contain multiple elements. varsOfRule :: CRule -> [CVarIName] varsOfRule (CRule pats rhs) = concatMap varsOfPat pats ++ varsOfRhs rhs ------------------------------------------------------------------------ -- Operations to compute the function names declared in functions, local -- declarations and statements: --- @return The declared function name of given local declaration in a list. funcNamesOfLDecl :: CLocalDecl -> [QName] funcNamesOfLDecl lDecl = case lDecl of CLocalFunc f -> funcNamesOfFDecl f _ -> [] --- @return The declared function name of given function declaration in a list. funcNamesOfFDecl :: CFuncDecl -> [QName] funcNamesOfFDecl (CFunc qn _ _ _ _) = [qn] funcNamesOfFDecl (CmtFunc _ qn _ _ _ _) = [qn] --- @return The declared function names of given statement in a list. funcNamesOfStat :: CStatement -> [QName] funcNamesOfStat stms = case stms of CSLet ld -> concatMap funcNamesOfLDecl ld _ -> [] ------------------------------------------------------------------------ --- Tests whether a module name is the prelude. isPrelude :: String -> Bool isPrelude m = m == "Prelude" ------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/abstract-curry/src/AbstractCurry/Transform.curry000066400000000000000000000633051377556325500276770ustar00rootroot00000000000000---------------------------------------------------------------------------- --- This library provides transformation and update operations --- on AbstractCurry programs. --- Since the transformations are defined recursively on structured types, --- they are useful to construct specific transformations on AbstractCurry --- programs. --- In particular, this library contains the transformation --- `renameCurryModule` to rename an AbstractCurry module. --- --- @author Michael Hanus --- @version October 2016 --- @category meta ---------------------------------------------------------------------------- module AbstractCurry.Transform where import AbstractCurry.Types import AbstractCurry.Select import Data.List (nub, union) --- This type synonym is useful to denote the type of an update, --- where the first argument is the type of values which are updated --- by the local update (which acts on types described by the second argument). type Update a b = (b -> b) -> a -> a ---------------------------------------------------------------------------- -- CurryProg --- Transforms an AbstractCurry program. trCProg :: (String -> [String] -> (Maybe CDefaultDecl) -> [CClassDecl] -> [CInstanceDecl] -> [CTypeDecl] -> [CFuncDecl] -> [COpDecl] -> a) -> CurryProg -> a trCProg prog (CurryProg name imps dfltdecl clsdecls instdecls types funcs ops) = prog name imps dfltdecl clsdecls instdecls types funcs ops --- Updates an AbstractCurry program. updCProg :: (String -> String) -> ([String] -> [String]) -> (Maybe CDefaultDecl -> Maybe CDefaultDecl) -> ([CClassDecl] -> [CClassDecl]) -> ([CInstanceDecl] -> [CInstanceDecl]) -> ([CTypeDecl] -> [CTypeDecl]) -> ([CFuncDecl] -> [CFuncDecl]) -> ([COpDecl] -> [COpDecl]) -> CurryProg -> CurryProg updCProg fn fi fdft fcl fci ft ff fo = trCProg prog where prog name imps dfltdecl clsdecls instdecls types funcs ops = CurryProg (fn name) (fi imps) (fdft dfltdecl) (fcl clsdecls) (fci instdecls) (ft types) (ff funcs) (fo ops) --- Updates the name of a Curry program. updCProgName :: Update CurryProg String updCProgName f = updCProg f id id id id id id id ---------------------------------------------------------------------------- -- CDefaultDecl --- Transforms a default declaration. trCDefaultDecl :: ([CTypeExpr] -> a) -> CDefaultDecl -> a trCDefaultDecl defdecl (CDefaultDecl texps) = defdecl texps --- Updates a default declaration. updCDefaultDecl :: ([CTypeExpr] -> [CTypeExpr]) -> CDefaultDecl -> CDefaultDecl updCDefaultDecl fts = trCDefaultDecl (\texps -> CDefaultDecl (fts texps)) ---------------------------------------------------------------------------- -- CConstraint --- Transforms a class context. trCContext :: ([CConstraint] -> a) -> CContext -> a trCContext ctxt (CContext constrs) = ctxt constrs --- Updates a class context. updCContext :: ([CConstraint] -> [CConstraint]) -> CContext -> CContext updCContext fc = trCContext (\constrs -> CContext (fc constrs)) ---------------------------------------------------------------------------- -- CClassDecl --- Transforms a class declaration. trCClassDecl :: (QName -> CVisibility -> CContext -> CTVarIName -> [CFuncDecl] -> a) -> CClassDecl -> a trCClassDecl cls (CClass name vis ctxt tvar funcs) = cls name vis ctxt tvar funcs --- Updates an AbstractCurry program. updCClassDecl :: (QName -> QName) -> (CVisibility -> CVisibility) -> (CContext -> CContext) -> (CTVarIName -> CTVarIName) -> ([CFuncDecl] -> [CFuncDecl]) -> CClassDecl -> CClassDecl updCClassDecl fn fv fc ft ff = trCClassDecl cls where cls name vis ctxt tvar funcs = CClass (fn name) (fv vis) (fc ctxt) (ft tvar) (ff funcs) ---------------------------------------------------------------------------- -- CInstanceDecl --- Transforms a class declaration. trCInstanceDecl :: (QName -> CContext -> CTypeExpr -> [CFuncDecl] -> a) -> CInstanceDecl -> a trCInstanceDecl inst (CInstance name ctxt texp funcs) = inst name ctxt texp funcs --- Updates an AbstractCurry program. updCInstanceDecl :: (QName -> QName) -> (CContext -> CContext) -> (CTypeExpr -> CTypeExpr) -> ([CFuncDecl] -> [CFuncDecl]) -> CInstanceDecl -> CInstanceDecl updCInstanceDecl fn fc ft ff = trCInstanceDecl inst where inst name ctxt texp funcs = CInstance (fn name) (fc ctxt) (ft texp) (ff funcs) ---------------------------------------------------------------------------- -- CTypeDecl --- Transforms a type declaration. trCTypeDecl :: (QName -> CVisibility -> [CTVarIName] -> [CConsDecl] -> [QName] -> a) -> (QName -> CVisibility -> [CTVarIName] -> CTypeExpr -> a) -> (QName -> CVisibility -> [CTVarIName] -> CConsDecl -> [QName] -> a) -> CTypeDecl -> a trCTypeDecl typ _ _ (CType name vis params cs dvs) = typ name vis params cs dvs trCTypeDecl _ tsyn _ (CTypeSyn name vis params syn) = tsyn name vis params syn trCTypeDecl _ _ tntyp (CNewType name vis params nt dvs) = tntyp name vis params nt dvs --- update type declaration updCTypeDecl :: (QName -> QName) -> (CVisibility -> CVisibility) -> ([CTVarIName] -> [CTVarIName]) -> ([CConsDecl] -> [CConsDecl]) -> (CTypeExpr -> CTypeExpr) -> (CConsDecl -> CConsDecl) -> ([QName] -> [QName]) -> CTypeDecl -> CTypeDecl updCTypeDecl fn fv fp fc fs ft fd = trCTypeDecl typ tsyn tntyp where typ name vis params cs der = CType (fn name) (fv vis) (fp params) (fc cs) (fd der) tsyn name vis params syn = CTypeSyn (fn name) (fv vis) (fp params) (fs syn) tntyp name vis params ntyp der = CNewType (fn name) (fv vis) (fp params) (ft ntyp) (fd der) --- Updates the name of a type declaration. updCTypeDeclName :: Update CTypeDecl QName updCTypeDeclName f = updCTypeDecl f id id id id id id ---------------------------------------------------------------------------- -- CConsDecl --- Transforms a constructor declaration. trCConsDecl :: (QName -> CVisibility -> [CTypeExpr] -> a) -> (QName -> CVisibility -> [CFieldDecl] -> a) -> CConsDecl -> a trCConsDecl cons _ (CCons name vis args) = cons name vis args trCConsDecl _ rec (CRecord name vis args) = rec name vis args --- Updates a constructor declaration. updCConsDecl :: (QName -> QName) -> (CVisibility -> CVisibility) -> ([CTypeExpr] -> [CTypeExpr]) -> ([CFieldDecl] -> [CFieldDecl]) -> CConsDecl -> CConsDecl updCConsDecl fn fv fts ffs = trCConsDecl cons rec where cons name vis args = CCons (fn name) (fv vis) (fts args) rec name vis args = CRecord (fn name) (fv vis) (ffs args) --- Updates the name of a constructor declaration. updCConsDeclName :: Update CConsDecl QName updCConsDeclName f = updCConsDecl f id id id ---------------------------------------------------------------------------- -- CFieldDecl --- Transforms a constructor declaration. trCFieldDecl :: (QName -> CVisibility -> CTypeExpr -> a) -> CFieldDecl -> a trCFieldDecl field (CField name vis texp) = field name vis texp --- update constructor declaration updCFieldDecl :: (QName -> QName) -> (CVisibility -> CVisibility) -> (CTypeExpr -> CTypeExpr) -> CFieldDecl -> CFieldDecl updCFieldDecl fn fv ft = trCFieldDecl field where field name vis texp = CField (fn name) (fv vis) (ft texp) --- Updates the name of a constructor declaration. updCFieldDeclName :: Update CFieldDecl QName updCFieldDeclName f = updCFieldDecl f id id ---------------------------------------------------------------------------- -- CQualTypeExpr --- Transforms a default declaration. trCQualTypeExpr :: (CContext -> CTypeExpr -> a) -> CQualTypeExpr -> a trCQualTypeExpr qtexp (CQualType ctxt texp) = qtexp ctxt texp --- Updates a default declaration. updCQualTypeExpr :: (CContext -> CContext) -> (CTypeExpr -> CTypeExpr) -> CQualTypeExpr -> CQualTypeExpr updCQualTypeExpr fc ft = trCQualTypeExpr (\ctxt texp -> CQualType (fc ctxt) (ft texp)) ---------------------------------------------------------------------------- -- CTypeExpr --- Transforms a type expression. trCTypeExpr :: (CTVarIName -> a) -> (QName -> a) -> (a -> a -> a) -> (a -> a -> a) -> CTypeExpr -> a trCTypeExpr tvar tcons functype applytype texp = trTE texp where trTE (CTVar n) = tvar n trTE (CTCons name) = tcons name trTE (CFuncType from to) = functype (trTE from) (trTE to) trTE (CTApply from to) = applytype (trTE from) (trTE to) --- Updates all type constructors in a type expression. updTConsApp :: (QName -> CTypeExpr) -> CTypeExpr -> CTypeExpr updTConsApp tcons = trCTypeExpr CTVar tcons CFuncType CTApply ---------------------------------------------------------------------------- -- COpDecl --- Transforms an operator declaration. trCOpDecl :: (QName -> CFixity -> Int -> a) -> COpDecl -> a trCOpDecl op (COp name fix prec) = op name fix prec --- Updates an operator declaration. updCOpDecl :: (QName -> QName) -> (CFixity -> CFixity) -> (Int -> Int) -> COpDecl -> COpDecl updCOpDecl fn ff fp = trCOpDecl op where op name fix prec = COp (fn name) (ff fix) (fp prec) --- Updates the name of an operator declaration. updCOpName :: Update COpDecl QName updCOpName f = updCOpDecl f id id ---------------------------------------------------------------------------- -- CFuncDecl --- Transforms a function declaration trCFuncDecl :: (String -> QName -> Int -> CVisibility -> CQualTypeExpr -> [CRule] -> a) -> CFuncDecl -> a trCFuncDecl func (CFunc name arity vis t rs) = func "" name arity vis t rs trCFuncDecl func (CmtFunc cm name arity vis t rs) = func cm name arity vis t rs --- Updates a function declaration. updCFuncDecl :: (String -> String) -> (QName -> QName) -> (Int -> Int) -> (CVisibility -> CVisibility) -> (CQualTypeExpr -> CQualTypeExpr) -> ([CRule] -> [CRule]) -> CFuncDecl -> CFuncDecl updCFuncDecl fc fn fa fv ft fr = trCFuncDecl func where func cmt name arity vis t rules = if null cmt then CFunc (fn name) (fa arity) (fv vis) (ft t) (fr rules) else CmtFunc (fc cmt) (fn name) (fa arity) (fv vis) (ft t) (fr rules) ---------------------------------------------------------------------------- -- CRule --- Transform a rule. trCRule :: ([CPattern] -> CRhs -> a) -> CRule -> a trCRule rule (CRule pats rhs) = rule pats rhs --- Update a rule. updCRule :: ([CPattern] -> [CPattern]) -> (CRhs -> CRhs) -> CRule -> CRule updCRule fp fr = trCRule rule where rule pats rhs = CRule (fp pats) (fr rhs) ---------------------------------------------------------------------------- -- CRhs --- Transforms a right-hand side (of a rule or case expression). trCRhs :: (CExpr -> [CLocalDecl] -> a) -> ([(CExpr, CExpr)] -> [CLocalDecl] -> a) -> CRhs -> a trCRhs srhs _ (CSimpleRhs exp locals) = srhs exp locals trCRhs _ grhs (CGuardedRhs gexps locals) = grhs gexps locals --- Updates right-hand side. updCRhs :: (CExpr -> CExpr) -> ([(CExpr, CExpr)] -> [(CExpr, CExpr)]) -> ([CLocalDecl] -> [CLocalDecl]) -> CRhs -> CRhs updCRhs fe fg fl = trCRhs srhs grhs where srhs exp locals = CSimpleRhs (fe exp) (fl locals) grhs gexps locals = CGuardedRhs (fg gexps) (fl locals) ---------------------------------------------------------------------------- -- CLocalDecl --- Transforms a local declaration. trCLocalDecl :: (CFuncDecl -> a) -> (CPattern -> CRhs -> a) -> ([CVarIName] -> a) -> CLocalDecl -> a trCLocalDecl lfun _ _ (CLocalFunc fdecl) = lfun fdecl trCLocalDecl _ lpat _ (CLocalPat pat rhs) = lpat pat rhs trCLocalDecl _ _ vars (CLocalVars vs) = vars vs --- Updates a local declaration. updCLocalDecl :: (CFuncDecl -> CFuncDecl) -> (CPattern -> CPattern) -> (CRhs -> CRhs) -> ([CVarIName] -> [CVarIName]) -> CLocalDecl -> CLocalDecl updCLocalDecl ff fp fr fv = trCLocalDecl lfun lpat lvars where lfun fdecl = CLocalFunc (ff fdecl) lpat pat rhs = CLocalPat (fp pat) (fr rhs) lvars vars = CLocalVars (fv vars) ---------------------------------------------------------------------------- -- CPattern --- Transforms a pattern. trCPattern :: (CVarIName -> a) -> (CLiteral -> a) -> (QName -> [a] -> a) -> (CVarIName -> a -> a) -> (QName -> [a] -> a) -> (QName -> [CField a] -> a) -> CPattern -> a trCPattern fv fl fc fa ff fr pattern = trP pattern where trP (CPVar pvar) = fv pvar trP (CPLit lit) = fl lit trP (CPComb c pats) = fc c (map trP pats) trP (CPAs v pat) = fa v (trP pat) trP (CPFuncComb fn pats) = ff fn (map trP pats) trP (CPLazy pat) = trP pat trP (CPRecord r fs) = fr r (map (\(n,p) -> (n,trP p)) fs) --- Updates a pattern. updCPattern :: (CVarIName -> CVarIName) -> (CLiteral -> CLiteral) -> (QName -> QName) -> CPattern -> CPattern updCPattern fv fl fn = trCPattern pvar plit pcomb pas pfcomb prec where pvar var = CPVar (fv var) plit lit = CPLit (fl lit) pcomb c pats = CPComb (fn c) (map (updCPattern fv fl fn) pats) pas v pat = CPAs (fv v) (updCPattern fv fl fn pat) pfcomb f pats = CPFuncComb (fn f) (map (updCPattern fv fl fn) pats) prec r fields = CPRecord (fn r) (map (\ (n,p) -> (fn n, updCPattern fv fl fn p)) fields) ---------------------------------------------------------------------------- -- CExpr --- Transforms an expression. trExpr :: (CVarIName -> a) -> (CLiteral -> a) -> (QName -> a) -> (a -> a -> a) -> ([CPattern] -> a -> a) -> ([CLocalDecl] -> a -> a) -> ([CStatement] -> a) -> (a -> [CStatement] -> a) -> (CCaseType -> a -> [(CPattern, CRhs)] -> a) -> (a -> CQualTypeExpr -> a) -> (QName -> [CField a] -> a) -> (a -> [CField a] -> a) -> CExpr -> a trExpr var lit sym app lam clet cdo lcomp cas typ rcon rupd exp = trE exp where trE (CVar n) = var n trE (CLit l) = lit l trE (CSymbol n) = sym n trE (CApply e1 e2) = app (trE e1) (trE e2) trE (CLambda pats e) = lam pats (trE e) trE (CLetDecl ls e) = clet ls (trE e) trE (CDoExpr stm) = cdo stm trE (CListComp e stm) = lcomp (trE e) stm trE (CCase ct e branches) = cas ct (trE e) branches trE (CTyped e te) = typ (trE e) te trE (CRecConstr rn fds) = rcon rn (map (\ (lb,e) -> (lb, trE e)) fds) trE (CRecUpdate e fds) = rupd (trE e) (map (\ (lb,v) -> (lb, trE v)) fds) ---------------------------------------------------------------------------- -- CStatement --- Transforms a statement (occuring in do expressions or list comprehensions). trCStatement :: (CExpr -> a) -> (CPattern -> CExpr -> a) -> ([CLocalDecl] -> a) -> CStatement -> a trCStatement sexp _ _ (CSExpr exp) = sexp exp trCStatement _ spat _ (CSPat pat exp) = spat pat exp trCStatement _ _ slet (CSLet locals) = slet locals --- Updates a statement (occuring in do expressions or list comprehensions). updCStatement :: (CExpr -> CExpr) -> (CPattern -> CPattern) -> (CLocalDecl -> CLocalDecl) -> CStatement -> CStatement updCStatement fe fp fd = trCStatement sexp spat slet where sexp exp = CSExpr (fe exp) spat pat exp = CSPat (fp pat) (fe exp) slet locals = CSLet (map fd locals) ---------------------------------------------------------------------------- --- Renames a Curry module, i.e., updates the module name and all qualified --- names in a program. renameCurryModule :: String -> CurryProg -> CurryProg renameCurryModule newname prog = updCProgName (const newname) (updQNamesInCProg rnm prog) where rnm mn@(mod,n) | mod == progName prog = (newname,n) | otherwise = mn --- Updates all qualified names in a Curry program. updQNamesInCProg :: Update CurryProg QName updQNamesInCProg f = updCProg id id (updQNamesInCDefaultDecl f) (map (updQNamesInCClassDecl f)) (map (updQNamesInCInstanceDecl f)) (map (updQNamesInCTypeDecl f)) (map (updQNamesInCFuncDecl f)) (map (updCOpName f)) --- Updates all qualified names in a default declaration. updQNamesInCDefaultDecl :: Update (Maybe CDefaultDecl) QName updQNamesInCDefaultDecl f = updateDefltDecl where updateDefltDecl Nothing = Nothing updateDefltDecl (Just defdecl) = Just (updCDefaultDecl (map (updQNamesInCTypeExpr f)) defdecl) --- Updates all qualified names in a class declaration. updQNamesInCClassDecl :: Update CClassDecl QName updQNamesInCClassDecl f = updCClassDecl f id (updQNamesInCContext f) id (map (updQNamesInCFuncDecl f)) --- Updates all qualified names in an instance declaration. updQNamesInCInstanceDecl :: Update CInstanceDecl QName updQNamesInCInstanceDecl f = updCInstanceDecl f (updQNamesInCContext f) (updQNamesInCTypeExpr f) (map (updQNamesInCFuncDecl f)) --- Updates all qualified names in a type declaration. updQNamesInCTypeDecl :: Update CTypeDecl QName updQNamesInCTypeDecl f = updCTypeDecl f id id (map (updQNamesInCConsDecl f)) (updQNamesInCTypeExpr f) (updQNamesInCConsDecl f) (map f) --- Updates all qualified names in a constructor declaration. updQNamesInCConsDecl :: Update CConsDecl QName updQNamesInCConsDecl f = updCConsDecl f id (map (updQNamesInCTypeExpr f)) (map (updQNamesInCFieldDecl f)) --- Updates all qualified names in a constructor declaration. updQNamesInCContext :: Update CContext QName updQNamesInCContext f = updCContext (map updConstr) where updConstr (n,texp) = (f n, updQNamesInCTypeExpr f texp) --- Updates all qualified names in a record field declaration. updQNamesInCFieldDecl :: Update CFieldDecl QName updQNamesInCFieldDecl f = updCFieldDecl f id (updQNamesInCTypeExpr f) --- Updates all qualified names in a type expression. updQNamesInCQualTypeExpr :: Update CQualTypeExpr QName updQNamesInCQualTypeExpr f = updCQualTypeExpr (updQNamesInCContext f) (updQNamesInCTypeExpr f) --- Updates all qualified names in a type expression. updQNamesInCTypeExpr :: Update CTypeExpr QName updQNamesInCTypeExpr f = updTConsApp (CTCons . f) --- Updates all qualified names in a function declaration. updQNamesInCFuncDecl :: Update CFuncDecl QName updQNamesInCFuncDecl f = updCFuncDecl id f id id (updQNamesInCQualTypeExpr f) (map (updQNamesInCRule f)) --- Updates all qualified names in a function declaration. updQNamesInCRule :: Update CRule QName updQNamesInCRule f = updCRule (map (updQNamesInCPattern f)) (updQNamesInCRhs f) --- Updates all qualified names in a function declaration. updQNamesInCRhs :: Update CRhs QName updQNamesInCRhs f = updCRhs (updQNamesInCExpr f) (map (\ (g,e) -> (updQNamesInCExpr f g, updQNamesInCExpr f e))) (map (updQNamesInCLocalDecl f)) --- Updates all qualified names in a function declaration. updQNamesInCLocalDecl :: Update CLocalDecl QName updQNamesInCLocalDecl f = updCLocalDecl (updQNamesInCFuncDecl f) (updQNamesInCPattern f) (updQNamesInCRhs f) id --- Updates all qualified names in a function declaration. updQNamesInCPattern :: Update CPattern QName updQNamesInCPattern f = updCPattern id id f --- Updates all qualified names in a statement. updQNamesInCStatement :: Update CStatement QName updQNamesInCStatement f = updCStatement (updQNamesInCExpr f) (updQNamesInCPattern f) (updQNamesInCLocalDecl f) updQNamesInCExpr :: Update CExpr QName updQNamesInCExpr f = trExpr CVar CLit (CSymbol . f) CApply lam ldecl doexp lcomp ccase ctyped reccon recupd where lam pats exp = CLambda (map (updQNamesInCPattern f) pats) exp ldecl locals exp = CLetDecl (map (updQNamesInCLocalDecl f) locals) exp doexp stms = CDoExpr (map (updQNamesInCStatement f) stms) lcomp exp stms = CListComp exp (map (updQNamesInCStatement f) stms) ccase ct exp bs = CCase ct exp (map (\ (pat,rhs) -> (updQNamesInCPattern f pat, updQNamesInCRhs f rhs)) bs) ctyped exp texp = CTyped exp (updQNamesInCQualTypeExpr f texp) reccon rec fields = CRecConstr (f rec) (map (\ (l,e) -> (f l,e)) fields) recupd exp fields = CRecUpdate exp (map (\ (l,e) -> (f l,e)) fields) ------------------------------------------------------------------------- --- Extracts all type names occurring in a program. typesOfCurryProg :: CurryProg -> [QName] typesOfCurryProg = trCProg (\_ _ dfts cls insts types funcs _ -> typesOfDefault dfts ++ unionMap typesOfCClassDecl cls ++ unionMap typesOfCInstanceDecl insts ++ unionMap typesOfCTypeDecl types ++ unionMap typesOfCFuncDecl funcs) where typesOfDefault Nothing = [] typesOfDefault (Just (CDefaultDecl texps)) = concatMap typesOfTypeExpr texps --- Extracts all type names occurring in a class declaration. --- Class names are ignored. typesOfCClassDecl :: CClassDecl -> [QName] typesOfCClassDecl = trCClassDecl (\_ _ ctxt _ funcs -> typesOfContext ctxt ++ unionMap typesOfCFuncDecl funcs) --- Extracts all type names occurring in a class declaration. --- Class names are ignored. typesOfCInstanceDecl :: CInstanceDecl -> [QName] typesOfCInstanceDecl = trCInstanceDecl (\_ ctxt texp funcs -> typesOfContext ctxt ++ typesOfTypeExpr texp ++ unionMap typesOfCFuncDecl funcs) --- Extracts all type names occurring in a type declaration. --- Class names are ignored. typesOfCTypeDecl :: CTypeDecl -> [QName] typesOfCTypeDecl = trCTypeDecl (\qn _ _ cdecls _ -> qn : concatMap typesOfConsDecl cdecls) (\qn _ _ texp -> qn : typesOfTypeExpr texp) (\qn _ _ cdecl _ -> qn : typesOfConsDecl cdecl) typesOfConsDecl :: CConsDecl -> [QName] typesOfConsDecl = trCConsDecl (\_ _ texps -> concatMap typesOfTypeExpr texps) (\_ _ fddecls -> concatMap typesOfFieldDecl fddecls) typesOfFieldDecl :: CFieldDecl -> [QName] typesOfFieldDecl = trCFieldDecl (\_ _ texp -> typesOfTypeExpr texp) typesOfContext :: CContext -> [QName] typesOfContext = trCContext (concatMap (typesOfTypeExpr . snd)) typesOfTypeExpr :: CTypeExpr -> [QName] typesOfTypeExpr = trCTypeExpr (\_ -> []) (\qn -> [qn]) (++) (++) typesOfQualTypeExpr :: CQualTypeExpr -> [QName] typesOfQualTypeExpr = trCQualTypeExpr (\ctxt texp -> typesOfContext ctxt ++ typesOfTypeExpr texp) typesOfCFuncDecl :: CFuncDecl -> [QName] typesOfCFuncDecl = trCFuncDecl (\_ _ _ _ texp _ -> typesOfQualTypeExpr texp) -- type annotations in expressions are currently ignored -- Map a list-valued function on a list and remove duplicates. unionMap :: Eq b => (a -> [b]) -> [a] -> [b] unionMap f = foldr union [] . (map (nub . f)) ---------------------------------------------------------------------------- --- Extracts all function (and constructor) names occurring in a program. funcsOfCurryProg :: CurryProg -> [QName] funcsOfCurryProg = trCProg (\_ _ _ cls insts types funcs _ -> unionMap funcsOfCClassDecl cls ++ unionMap funcsOfCInstanceDecl insts ++ unionMap funcsOfCTypeDecl types ++ unionMap funcsOfCFuncDecl funcs) funcsOfCClassDecl :: CClassDecl -> [QName] funcsOfCClassDecl = trCClassDecl (\_ _ _ _ funcs -> unionMap funcsOfCFuncDecl funcs) funcsOfCInstanceDecl :: CInstanceDecl -> [QName] funcsOfCInstanceDecl = trCInstanceDecl (\_ _ _ funcs -> unionMap funcsOfCFuncDecl funcs) funcsOfCTypeDecl :: CTypeDecl -> [QName] funcsOfCTypeDecl = trCTypeDecl (\_ _ _ cdecls _ -> concatMap funcsOfConsDecl cdecls) (\_ _ _ _ -> []) (\_ _ _ cdecl _ -> funcsOfConsDecl cdecl) funcsOfConsDecl :: CConsDecl -> [QName] funcsOfConsDecl = trCConsDecl (\qn _ _ -> [qn]) (\qn _ fddecls -> qn : concatMap funcsOfFieldDecl fddecls) funcsOfFieldDecl :: CFieldDecl -> [QName] funcsOfFieldDecl = trCFieldDecl (\qn _ _ -> [qn]) --- Extracts all function (and constructor) names occurring in a function --- declaration. funcsOfCFuncDecl :: CFuncDecl -> [QName] funcsOfCFuncDecl = trCFuncDecl (\_ _ _ _ _ rules -> concatMap funcsOfCRule rules) funcsOfCRule :: CRule -> [QName] funcsOfCRule = trCRule (\_ rhs -> funcsOfCRhs rhs) funcsOfCRhs :: CRhs -> [QName] funcsOfCRhs = trCRhs (\e ldecls -> funcsOfExpr e ++ concatMap funcsOfLDecl ldecls) (\gs ldecls -> concatMap (\ (g,e) -> funcsOfExpr g ++ funcsOfExpr e) gs ++ concatMap funcsOfLDecl ldecls) funcsOfLDecl :: CLocalDecl -> [QName] funcsOfLDecl = trCLocalDecl funcsOfCFuncDecl (const funcsOfCRhs) (const []) funcsOfExpr :: CExpr -> [QName] funcsOfExpr = trExpr (const []) (const []) (\n -> [n]) (++) (const id) (\ldecls e -> concatMap funcsOfLDecl ldecls ++ e) (concatMap funcsOfStat) (\e stats -> e ++ concatMap funcsOfStat stats) (\_ e brs -> e ++ concatMap (funcsOfCRhs . snd) brs) (\e _ -> e) (\_ fields -> concatMap snd fields) (\e fields -> e ++ concatMap snd fields) funcsOfStat :: CStatement -> [QName] funcsOfStat = trCStatement funcsOfExpr (const funcsOfExpr) (concatMap funcsOfLDecl) ------------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/abstract-curry/src/AbstractCurry/Types.curry000066400000000000000000000275021377556325500270270ustar00rootroot00000000000000-- --------------------------------------------------------------------------- --- This library contains a definition for representing Curry programs --- in Curry. --- --- Note this defines a slightly new format for AbstractCurry --- in comparison to the first proposal of 2003. --- --- Assumption: an abstract Curry program is stored in file with --- extension .acy --- --- @author Michael Hanus, Bjoern Peemoeller, Finn Teegen --- @version November 2020 -- --------------------------------------------------------------------------- module AbstractCurry.Types where -- --------------------------------------------------------------------------- -- Definition of data types for representing abstract Curry programs: -- --------------------------------------------------------------------------- --- Current version of AbstractCurry version :: String version = "AbstractCurry 3.0" --- A module name. type MName = String --- The data type for representing qualified names. --- In AbstractCurry all names are qualified to avoid name clashes. --- The first component is the module name and the second component the --- unqualified name as it occurs in the source program. --- An exception are locally defined names where the module name is --- the empty string (to avoid name clashes with a globally defined name). type QName = (MName, String) --- Data type to specify the visibility of various entities. data CVisibility = Public -- exported entity | Private -- private entity deriving (Eq, Show) --- Data type for representing a Curry module in the intermediate form. --- A value of this data type has the form --- --- (CurryProg modname imports dfltdecl clsdecls instdecls typedecls --- funcdecls opdecls) --- --- where modname: name of this module, --- imports: list of modules names that are imported, --- dfltdecl: optional default declaration --- clsdecls: Class declarations --- instdecls: Instance declarations --- typedecls: Type declarations --- functions: Function declarations --- opdecls: Operator precedence declarations data CurryProg = CurryProg MName [MName] (Maybe CDefaultDecl) [CClassDecl] [CInstanceDecl] [CTypeDecl] [CFuncDecl] [COpDecl] deriving (Eq, Show) --- Data type for representing default declarations. data CDefaultDecl = CDefaultDecl [CTypeExpr] deriving (Eq, Show) --- Data type for representing classes declarations. --- --- A type class definition of the form --- --- class cx => c a where { ...;f :: t;... } --- --- is represented by the Curry term --- --- (CClass c v cx tv [...(CFunc f ar v t [...,CRule r,...])...]) --- --- where 'tv' is the index of the type variable 'a' and 'v' is the --- visibility of the type class resp. method. --- Note: The type variable indices are unique inside each class --- declaration and are usually numbered from 0. --- The methods' types share the type class' type variable index --- as the class variable has to occur in a method's type signature. --- The list of rules for a method's declaration may be empty if --- no default implementation is provided. The arity 'ar' is --- determined by a given default implementation or 0. --- Regardless of whether typed or untyped abstract curry is generated, --- the methods' declarations are always typed. data CClassDecl = CClass QName CVisibility CContext CTVarIName [CFuncDecl] deriving (Eq, Show) --- Data type for representing instance declarations. --- --- An instance definition of the form --- --- instance cx => c ty where { ...;fundecl;... } --- --- is represented by the Curry term --- --- (CInstance c cx ty [...fundecl...]) --- --- Note: The type variable indices are unique inside each instance --- declaration and are usually numbered from 0. --- The methods' types use the instance's type variable indices --- (if typed abstract curry is generated). data CInstanceDecl = CInstance QName CContext CTypeExpr [CFuncDecl] deriving (Eq, Show) --- Data type for representing definitions of algebraic data types --- and type synonyms. --- --- A data type definition of the form --- --- data t x1...xn = ...| c t1....tkc |... --- deriving (d1,...,dp) --- --- is represented by the Curry term --- --- (CType t v [i1,...,in] --- [...(CCons c v [t1,...,tkc])...] [d1,...,dp])) --- --- where each `ij` is the index of the type variable `xj` and 'v' is the --- visibility of the type resp. constructor. --- --- Note: the type variable indices are unique inside each type declaration --- and are usually numbered from 0 --- --- Thus, a data type declaration consists of the name of the data type, --- a list of type parameters and a list of constructor declarations. data CTypeDecl = CType QName CVisibility [CTVarIName] [CConsDecl] [QName] | CTypeSyn QName CVisibility [CTVarIName] CTypeExpr | CNewType QName CVisibility [CTVarIName] CConsDecl [QName] deriving (Eq, Show) --- The type for representing type variables. --- They are represented by (i,n) where i is a type variable index --- which is unique inside a function and n is a name (if possible, --- the name written in the source program). type CTVarIName = (Int, String) --- A constructor declaration consists of the name of the constructor --- and a list of the argument types of the constructor. --- The arity equals the number of types. data CConsDecl = CCons QName CVisibility [CTypeExpr] | CRecord QName CVisibility [CFieldDecl] deriving (Eq, Show) --- A record field declaration consists of the name of the --- the label, the visibility and its corresponding type. data CFieldDecl = CField QName CVisibility CTypeExpr deriving (Eq, Show) --- Class constraint. type CConstraint = (QName, CTypeExpr) --- Context. data CContext = CContext [CConstraint] deriving (Eq, Show) --- Type expression. --- A type expression is either a type variable, a function type, --- or a type constructor application. --- --- Note: the names of the predefined type constructors are --- "Int", "Float", "Bool", "Char", "IO", --- "()" (unit type), "(,...,)" (tuple types), "[]" (list type) data CTypeExpr = CTVar CTVarIName -- type variable | CFuncType CTypeExpr CTypeExpr -- function type t1->t2 | CTCons QName -- type constructor | CTApply CTypeExpr CTypeExpr -- type application deriving (Eq, Show) --- Qualified type expression. data CQualTypeExpr = CQualType CContext CTypeExpr deriving (Eq, Show) --- Labeled record fields type CField a = (QName, a) --- Data type for operator declarations. --- An operator declaration "fix p n" in Curry corresponds to the --- AbstractCurry term (COp n fix p). data COpDecl = COp QName CFixity Int deriving (Eq, Show) --- Data type for operator associativity data CFixity = CInfixOp -- non-associative infix operator | CInfixlOp -- left-associative infix operator | CInfixrOp -- right-associative infix operator deriving (Eq, Show) --- Function arity type Arity = Int --- Data type for representing function declarations. --- --- A function declaration in AbstractCurry is a term of the form --- --- (CFunc name arity visibility type (CRules eval [CRule rule1,...,rulek])) --- --- and represents the function `name` defined by the rules --- `rule1,...,rulek`. --- --- Note: the variable indices are unique inside each rule --- --- Thus, a function declaration consists of the name, arity, type, and --- a list of rules. The type is the function's type inferred by the --- type checker. However, if an AbstractCurry program is read with --- the operation `AbstractCurry.Files.readUntypedCurry`, the type --- is either the type signature provided by the programmer or --- the expression `(CTCons ("Prelude","untyped")` --- if the programmer has not provided an explicit type signature. --- --- A function declaration with the constructor `CmtFunc` --- is similarly to `CFunc` but has a comment --- as an additional first argument. This comment could be used --- by pretty printers that generate a readable Curry program --- containing documentation comments. data CFuncDecl = CFunc QName Arity CVisibility CQualTypeExpr [CRule] | CmtFunc String QName Arity CVisibility CQualTypeExpr [CRule] deriving (Eq, Show) --- The general form of a function rule. It consists of a list of patterns --- (left-hand side) and the right-hand side for these patterns. data CRule = CRule [CPattern] CRhs deriving (Eq, Show) --- Right-hand-side of a 'CRule' or a `case` expression. --- It is either a simple unconditional right-hand side or --- a list of guards with their corresponding right-hand sides, and --- a list of local declarations. data CRhs = CSimpleRhs CExpr [CLocalDecl] -- expr where decls | CGuardedRhs [(CExpr, CExpr)] [CLocalDecl] -- | cond = expr where decls deriving (Eq, Show) --- Data type for representing local (let/where) declarations data CLocalDecl = CLocalFunc CFuncDecl -- local function declaration | CLocalPat CPattern CRhs -- local pattern declaration | CLocalVars [CVarIName] -- local free variable declaration deriving (Eq, Show) --- Data types for representing object variables. --- Object variables occurring in expressions are represented by (Var i) --- where i is a variable index. type CVarIName = (Int,String) --- Data type for representing pattern expressions. data CPattern = CPVar CVarIName -- pattern variable (unique index / name) | CPLit CLiteral -- literal (Integer/Float/Char constant) | CPComb QName [CPattern] -- application (m.c e1 ... en) of n-ary -- constructor m.c (CPComb (m,c) [e1,...,en]) | CPAs CVarIName CPattern -- as-pattern (extended Curry) | CPFuncComb QName [CPattern] -- function pattern (extended Curry) | CPLazy CPattern -- lazy pattern (extended Curry) | CPRecord QName [CField CPattern] -- record pattern (extended Curry) deriving (Eq, Show) --- Data type for representing Curry expressions. data CExpr = CVar CVarIName -- variable (unique index / name) | CLit CLiteral -- literal (Int/Float/Char constant) | CSymbol QName -- a defined symbol (qualified name) | CApply CExpr CExpr -- application (e1 e2) | CLambda [CPattern] CExpr -- lambda abstraction | CLetDecl [CLocalDecl] CExpr -- local let declarations | CDoExpr [CStatement] -- do expression | CListComp CExpr [CStatement] -- list comprehension | CCase CCaseType CExpr [(CPattern, CRhs)] -- case expression | CTyped CExpr CQualTypeExpr -- typed expression | CRecConstr QName [CField CExpr] -- record construction | CRecUpdate CExpr [CField CExpr] -- record update deriving (Eq, Show) --- Data type for representing literals occurring in an expression. --- It is either an integer, a float, or a character constant. data CLiteral = CIntc Int | CFloatc Float | CCharc Char | CStringc String deriving (Eq, Show) --- Data type for representing statements in do expressions and --- list comprehensions. data CStatement = CSExpr CExpr -- an expression (I/O action or boolean) | CSPat CPattern CExpr -- a pattern definition | CSLet [CLocalDecl] -- a local let declaration deriving (Eq, Show) --- Type of case expressions data CCaseType = CRigid -- rigid case expression | CFlex -- flexible case expression deriving (Eq, Show) --------------------------------------------------------------------------- --- The name of the standard prelude. preludeName :: String preludeName = "Prelude" --- Converts a string into a qualified name of the Prelude. pre :: String -> QName pre f = (preludeName, f) --------------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/abstract-curry/test/000077500000000000000000000000001377556325500222275ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/abstract-curry/test/Rev.curry000066400000000000000000000005341377556325500240530ustar00rootroot00000000000000-- Concatenating two lists: -- (predefined as `++' in the standard prelude) append :: [t] -> [t] -> [t] append [] x = x append (x:xs) ys = x : append xs ys -- Reverse the order of elements in a list: rev :: [t] -> [t] rev [] = [] rev (x:xs) = append (rev xs) [x] goal1 = append [1,2] [3,4] goal2 = rev [1,2,3,4] -- end of program curry-tools-v3.3.0/cpm/vendor/abstract-curry/test/TestAbstractCurry.curry000066400000000000000000000034401377556325500267460ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some tests for AbstractCurry libraries. --- --- To run all tests automatically by the currycheck tool, use the command: --- "curry-check testAbstractCurry" --- --- @author Michael Hanus --- @version November 2020 ------------------------------------------------------------------------------ import Control.Monad ( unless ) import Test.Prop import AbstractCurry.Files import AbstractCurry.Pretty import AbstractCurry.Types import System.Directory --- Test for equality of an AbstractCurry program with the same program --- after pretty printing and reading this AbstractCurry program: readAndTestEqualFcy :: String -> IO Bool readAndTestEqualFcy mod = do prog1 <- readAbstractCurryStrict mod let modcurry = mod ++ ".curry" modbak = mod ++ ".BAK" renameFile modcurry modbak copyFile modbak modcurry let modpp = mod ++ ".PP" readCurry mod >>= writeFile modpp . showCProg removeFile modcurry renameFile modpp modcurry prog2 <- readAbstractCurryStrict mod removeFile modcurry renameFile modbak modcurry let abstractequal = prog1 == prog2 unless abstractequal $ do putStrLn $ unlines [ "Differences in programs occurred:" , "Original AbstractCurry program:", show prog1 , "Pretty printed AbstractCurry program:", show prog2 ] return abstractequal -- Strictly read a AbstractCurry program in order to avoid race conditions -- due to copying/moving source files: readAbstractCurryStrict :: String -> IO CurryProg readAbstractCurryStrict mod = do prog <- readCurry mod id $!! prog `seq` return prog testAbstractCurryPretty_rev = (readAndTestEqualFcy "Rev") `returns` True --testAbstractCurryPretty_TestAbstractCurry = -- (readAndTestEqualFcy "TestAbstractCurry") `returns` True curry-tools-v3.3.0/cpm/vendor/boxes/000077500000000000000000000000001377556325500174235ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/boxes/README.md000066400000000000000000000037611377556325500207110ustar00rootroot00000000000000# boxes - A Pretty Printer for Two Dimensions boxes is a pretty-printing library for laying out text in two dimensions. It is a direct port of the Haskell library [boxes](1) by Brent Yorgey. boxes' core data type is the `Box`, which has a width, a height and some contents. A box's contents can be text or other boxes. There are functions for creating boxes from text and for combining boxes into bigger boxes. ## Creating Boxes The `text` function can be used to create a box from a string, which will have height 1 and length N, where N is the length of the string (Nx1). `char` creates a 1x1 box containing a single character. `emptyBox` creates an empty box of arbitrary width and height. `para :: Alignment -> Int -> String -> Box` creates a box from a string with a specific width. The box will be as high as necessary to fit the text, which is layed out according to the given alignment. ## Combining Boxes The `<>` and `<+>` operators combine boxes horizontally with and without a column of space between both boxes, respectively. The `//` and `/+/` operators are similar, but combine boxes vertically instead of horizontally. `hcat` and `vcat` are versions of `<>` and `//` that combine whole lists of boxes instead of two at a time. `hsep` and `vsep` are versions of `<+>` and `/+/` that operate on lists, with a configurable amount of space between each two boxes. `punctuateH` and `punctuateV` also combine lists of boxes horizontally and vertically, but allow us to specify another box which is copied in between each two boxes. The `align`, `alignVert` and `alignHoriz` functions can be used to create new boxes which contain other boxes in some alignment. `moveUp`, `moveLeft`, `moveDown` and `moveRight` move boxes by some amount inside larger boxes. `table` creates a table from a list of rows and a list of widths for each column. ## Rendering Boxes The `render` function renders a box to a string. The `printBox` function prints a box to stdout. [1]: https://hackage.haskell.org/package/boxes curry-tools-v3.3.0/cpm/vendor/boxes/package.json000066400000000000000000000010031377556325500217030ustar00rootroot00000000000000{ "name": "boxes", "version": "3.0.0", "author": "Jonas Oberschweiber ", "category": [ "Printing" ], "synopsis": "A pretty printer for boxes", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": ["Boxes"], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/boxes.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/boxes/src/000077500000000000000000000000001377556325500202125ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/boxes/src/Boxes.curry000066400000000000000000000257461377556325500223760ustar00rootroot00000000000000module Boxes where -- Adapted from the Haskell boxes library by Brent Yorgey import Data.List (intersperse, transpose) --- A box has a defined size (rows x cols) and some content. data Box = Box { rows :: Int , cols :: Int , content :: Content } --- Box alignment. --- --- @cons AlignFirst - align at top/left --- @cons AlignCenter1 - centered, but biased to top/left --- @cons AlignCenter2 - centered, but biased to bottom/right --- @cons AlignLast - align at bottom/right data Alignment = AlignFirst | AlignCenter1 | AlignCenter2 | AlignLast --- Top alignment. top :: Alignment top = AlignFirst --- Botton alignment. bottom :: Alignment bottom = AlignLast --- Left alignment. left :: Alignment left = AlignFirst --- Right alignment. right :: Alignment right = AlignLast --- Center-top/left alignment. center1 :: Alignment center1 = AlignCenter1 --- Center-bottom/right alignment. center2 :: Alignment center2 = AlignCenter2 --- Content of a box. --- --- @cons Blank - no content --- @cons Text - a string --- @cons Row - a row of boxes --- @cons Col - a column of boxes --- @cons SubBox - an aligned subbox data Content = Blank | Text String | Row [Box] | Col [Box] | SubBox Alignment Alignment Box --- Creates an empty 0x0 box. nullBox :: Box nullBox = emptyBox 0 0 --- Creates an empty box with the given size. --- --- @param r number of rows --- @param c number of columns emptyBox :: Int -> Int -> Box emptyBox r c = Box r c Blank --- Creates a 1x1 box from a character. char :: Char -> Box char c = Box 1 1 (Text [c]) --- Creates a Nx1 box from a string of length N. text :: String -> Box text t = Box 1 (length t) (Text t) --- Combine two boxes horizontally with top alignment. (<>) :: Box -> Box -> Box l <> r = hcat top [l, r] --- Combine two boxes horizontally with top alignment and leave one column --- between the boxes. (<+>) :: Box -> Box -> Box l <+> r = hcat top [l, emptyBox 0 1, r] --- Combine two boxes vertically with left alignment. (//) :: Box -> Box -> Box t // b = vcat left [t, b] --- Combine two boxes vertically with left alignment and leave one row between --- the boxes. (/+/) :: Box -> Box -> Box t /+/ b = vcat left [t, emptyBox 1 0, b] --- Combines a list of boxes horizontally with the given alignment. hcat :: Alignment -> [Box] -> Box hcat a bs = Box h w (Row $ map (alignVert a h) bs) where (w, h) = sumMax cols 0 rows bs --- Combines a list of boxes horizontally with the given alignment and space --- between all boxes. hsep :: Int -> Alignment -> [Box] -> Box hsep sep a bs = punctuateH a (emptyBox 0 sep) bs --- Combines a list of boxes vertically with the given alignment. vcat :: Alignment -> [Box] -> Box vcat a bs = Box h w (Col $ map (alignHoriz a w) bs) where (h, w) = sumMax rows 0 cols bs --- Calculate sum and maximum of a list. sumMax :: Ord b => (a -> Int) -> b -> (a -> b) -> [a] -> (Int, b) sumMax f defaultMax g as = foldr go (,) as 0 defaultMax where go a r n b = (r $! f a + n) $! g a `max` b --- Combines a list of boxes vertically with the given alignment and space --- between all boxes. vsep :: Int -> Alignment -> [Box] -> Box vsep sep a bs = punctuateV a (emptyBox sep 0) bs --- Combine a list of boxes horizontally with the given alignment and a copy of --- the given box between each two boxes. punctuateH :: Alignment -> Box -> [Box] -> Box punctuateH a p bs = hcat a (intersperse p bs) --- Combine a list of boxes vertically with the given alignment and a copy of --- the given box between each two boxes. punctuateV :: Alignment -> Box -> [Box] -> Box punctuateV a p bs = vcat a (intersperse p bs) paraFill :: Alignment -> Int -> String -> Box paraFill a n t = (\ss -> mkParaBoxFill a (length ss) n ss) $ flow n t mkParaBoxFill :: Alignment -> Int -> Int -> [String] -> Box mkParaBoxFill a h w = align AlignFirst a h w . vcat a . map text --- Create a box of the given width, containing a specific text. The text is --- flowed to fit the width according to the alignment. --- --- @param a the alignment of the text --- @param w the box's width --- @param c the box's contents para :: Alignment -> Int -> String -> Box para a n t = (\ss -> mkParaBox a (length ss) ss) $ flow n t --- Creates a list of boxes, each of a specific width and height. The given --- text is flowed into as many columns as necessary according to the given --- alignment. columns :: Alignment -> Int -> Int -> String -> [Box] columns a w h t = map (mkParaBox a h) . chunksOf h $ flow w t --- Creates a box of a specific height that contains a list of texts. mkParaBox :: Alignment -> Int -> [String] -> Box mkParaBox a n = alignVert top n . vcat a . map text --- Flows a given text into a given width, creating many different strings. flow :: Int -> String -> [String] flow n t = map (take n) . getLines $ foldl addWordP (emptyPara n) (map mkWord . words $ t) --- A paragraph has a width and some content. data Para = Para { paraWidth :: Int , paraContent :: ParaContent } --- A paragraph's content is a block consisting of many full lines and a single --- last line. data ParaContent = Block { fullLines :: [Line] , lastLine :: Line } --- Creates an empty paragraph of the given width. emptyPara :: Int -> Para emptyPara pw = Para pw (Block [] (Line 0 [])) --- Returns all lines of a paragraph. getLines :: Para -> [String] getLines (Para _ (Block ls l)) | lLen l == 0 = process ls | otherwise = process (l:ls) where process = map (unwords . reverse . map getWord . getWords) . reverse --- A line has a length and a list of words. data Line = Line { lLen :: Int , getWords :: [Word] } --- Creates a line from a list of words. mkLine :: [Word] -> Line mkLine ws = Line (sum (map ((+1) . wLen) ws) - 1) ws --- Creates a line from a single word. startLine :: Word -> Line startLine = mkLine . (:[]) --- A word has a length and its contents. data Word = Word { wLen :: Int , getWord :: String } --- Creates a word from a string. mkWord :: String -> Word mkWord w = Word (length w) w --- Adds a word to a paragraph. addWordP :: Para -> Word -> Para addWordP (Para pw (Block fl l)) w | wordFits pw w l = Para pw (Block fl (addWordL w l)) | otherwise = Para pw (Block (l:fl) (startLine w)) --- Adds a word to a line. addWordL :: Word -> Line -> Line addWordL w (Line len ws) = Line (len + wLen w + 1) (w:ws) --- Checks whether a word fits into a line. wordFits :: Int -> Word -> Line -> Bool wordFits pw w l = lLen l == 0 || lLen l + wLen w + 1 <= pw --- Creates a box of a specific width containing another box's content aligned --- according to the given alignment. alignHoriz :: Alignment -> Int -> Box -> Box alignHoriz a c b = align a AlignFirst (rows b) c b --- Creates a box of a specific height containing another box's content aligned --- according to the given alignment. alignVert :: Alignment -> Int -> Box -> Box alignVert a r b = align AlignFirst a r (cols b) b --- Creates a box of a specific width and height containing another box's --- content aligned according to the given alignment. align :: Alignment -> Alignment -> Int -> Int -> Box -> Box align ah av r c = Box r c . SubBox ah av --- Move a box up by putting it into a larger box with extra rows, aligned to --- the top. See remarks for moveLeft. moveUp :: Int -> Box -> Box moveUp n b = alignVert top (rows b + n) b --- Move a box down by putting it into a larger box with extra rows, aligned to --- the bottom. See remarks for moveLeft. moveDown :: Int -> Box -> Box moveDown n b = alignVert bottom (rows b + n) b --- Move a box left by putting it into a larger box with extra columns, aligned --- to the left. Note that this will only move the box by the specified amount --- if it is already in a larger right-aligned box. moveLeft :: Int -> Box -> Box moveLeft n b = alignHoriz left (cols b + n) b --- Move a box right by putting it into a larger box with extra columns, aligned --- to the right. See remarks for moveRight. moveRight :: Int -> Box -> Box moveRight n b = alignHoriz right (cols b + n) b --- Create a table from a list of rows. A fixed width for each column must be --- specified. table :: [[String]] -> [Int] -> Box table rows widths = vcat left $ map (hcat left . map (uncurry $ paraFill left)) withLengths where withLengths = map (zip widths) rows --- Render a box to a string. render :: Box -> String render = unlines . renderBox --- Takes a number of elements from a list. If the list is shorter than that --- number, fill the rest with a filler. takeP :: a -> Int -> [a] -> [a] takeP b n xs | n <= 0 = [] | otherwise = case xs of [] -> replicate n b (y:ys) -> y : takeP b (n - 1) ys fReverse :: ([a], b) -> ([a], b) fReverse (xs, y) = (reverse xs, y) (***) :: (a -> b) -> (c -> d) -> ((a, c) -> (b, d)) f1 *** f2 = \(x, y) -> (f1 x, f2 y) takePA :: Alignment -> a -> Int -> [a] -> [a] takePA c b x = glue . (takeP b (numRev c x) *** takeP b (numFwd c x)) . split where split t = fReverse . splitAt (numRev c (length t)) $ t glue = uncurry (++) . fReverse numFwd AlignFirst n = n numFwd AlignLast _ = 0 numFwd AlignCenter1 n = n `div` 2 numFwd AlignCenter2 n = (n + 1) `div` 2 numRev AlignFirst _ = 0 numRev AlignLast n = n numRev AlignCenter1 n = (n + 1) `div` 2 numRev AlignCenter2 n = n `div` 2 --- Generates a string of spaces. blanks :: Int -> String blanks = flip replicate ' ' --- Render a box as a list of lines. renderBox :: Box -> [String] renderBox (Box r c Blank) = resizeBox r c [""] renderBox (Box r c (Text t)) = resizeBox r c [t] renderBox (Box r c (Row bs)) = resizeBox r c . merge . map (renderBoxWithRows r) $ bs where merge = foldr (zipWith (++)) (repeat []) renderBox (Box r c (Col bs)) = resizeBox r c . concatMap (renderBoxWithCols c) $ bs renderBox (Box r c (SubBox ha va b)) = resizeBoxAligned r c ha va . renderBox $ b --- Render a box as a list of lines with a given number of rows. renderBoxWithRows :: Int -> Box -> [String] renderBoxWithRows r b = renderBox (b { rows = r }) --- Render a box as a list of lines with a given number of columns. renderBoxWithCols :: Int -> Box -> [String] renderBoxWithCols c b = renderBox (b { cols = c }) --- Resize a rendered list of lines. resizeBox :: Int -> Int -> [String] -> [String] resizeBox r c = takeP (blanks c) r . map (takeP ' ' c) --- Resize a rendered list of lines using the given alignments. resizeBoxAligned :: Int -> Int -> Alignment -> Alignment -> [String] -> [String] resizeBoxAligned r c ha va = takePA va (blanks c) r . map (takePA ha ' ' c) --- Print a box to stdout. printBox :: Box -> IO () printBox = putStr . render -- From Haskell's Data.List.Split chunksOf :: Int -> [a] -> [[a]] chunksOf n xs = map (take n) (xs:(partials xs)) where partials [] = [] partials ys@(_:_) = let ys' = drop n ys in case ys' of [] -> [] (_:_) -> (ys':(partials ys')) sum :: [Int] -> Int sum = foldl (+) 0 curry-tools-v3.3.0/cpm/vendor/cass-analysis/000077500000000000000000000000001377556325500210555ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/cass-analysis/LICENSE000066400000000000000000000027351377556325500220710ustar00rootroot00000000000000Copyright (c) 2017, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/cass-analysis/README.md000066400000000000000000000003721377556325500223360ustar00rootroot00000000000000# cass-analysis - Base libraries and implementation of program analyses for CASS This directory contains the implementation of various program analyses which can be used with CASS (the Curry Analysis Server System), available in the package `cass`. curry-tools-v3.3.0/cpm/vendor/cass-analysis/package.json000066400000000000000000000017511377556325500233470ustar00rootroot00000000000000{ "name": "cass-analysis", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Libraries with various compile-time analyses for Curry", "category": [ "Analysis" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "currypath" : ">= 3.0.0, < 4.0.0", "containers" : ">= 3.0.0, < 4.0.0", "directory" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0", "flatcurry" : ">= 3.0.0, < 4.0.0", "global" : ">= 3.0.0, < 4.0.0", "read-legacy": ">= 3.0.0, < 4.0.0", "scc" : ">= 3.0.0, < 4.0.0", "xml" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/cass-analysis.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/000077500000000000000000000000001377556325500216445ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/000077500000000000000000000000001377556325500234275ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/Demandedness.curry000066400000000000000000000076041377556325500271160ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Demandedness analysis: --- checks whether functions demands a particular argument, i.e., --- delivers only bottom if some argument is bottom. --- --- @author Michael Hanus --- @version May 2013 ------------------------------------------------------------------------------ module Analysis.Demandedness where import Analysis.Types import FlatCurry.Types import FlatCurry.Goodies import Data.List ( (\\), intercalate ) ------------------------------------------------------------------------------ --- Data type to represent information about demanded arguments. --- Demanded arguments are represented as a list of indices --- for the arguments, where arguments are numbered from 1. type DemandedArgs = [Int] -- Show determinism information as a string. showDemand :: AOutFormat -> DemandedArgs -> String showDemand AText [] = "no demanded arguments" showDemand ANote [] = "" showDemand fmt (x:xs) = (if fmt==AText then "demanded arguments: " else "") ++ intercalate "," (map show (x:xs)) -- Abstract demand domain. data DemandDomain = Bot | Top deriving Eq -- Least upper bound on abstract demand domain. lub :: DemandDomain -> DemandDomain -> DemandDomain lub Bot x = x lub Top _ = Top --- Demandedness analysis. demandAnalysis :: Analysis DemandedArgs demandAnalysis = dependencyFuncAnalysis "Demand" [1..] daFunc -- We define the demanded arguments of some primitive prelude operations. -- Otherwise, we analyse the right-hand sides of the rule. daFunc :: FuncDecl -> [(QName,DemandedArgs)] -> DemandedArgs daFunc (Func (m,f) _ _ _ rule) calledFuncs | f `elem` prelude2s && m==prelude = [1,2] | f `elem` prelude1s && m==prelude = [1] | otherwise = daFuncRule calledFuncs rule where prelude2s = ["==","=:=","compare","<=","$#","$##","$!","$!!", "+","-","*","div","mod","divMod","quot","rem","quotRem"] prelude1s = ["seq","ensureNotFree","apply","cond","=:<=","negateFloat"] -- TODO: >>= catch catchFail daFuncRule :: [(QName,DemandedArgs)] -> Rule -> DemandedArgs daFuncRule _ (External _) = [] -- nothing known about other externals daFuncRule calledFuncs (Rule args rhs) = map fst (filter ((==Bot) . snd) (map (\botarg -> (botarg, absEvalExpr rhs [botarg])) args)) where -- abstract evaluation of an expression w.r.t. variables assumed to be Bot absEvalExpr (Var i) bvs = if i `elem` bvs then Bot else Top absEvalExpr (Lit _) _ = Top absEvalExpr (Comb ct g es) bvs = if ct == FuncCall then if g == (prelude,"failed") then Bot -- Prelude.failed never returns a value else maybe (error $ "Abstract value of " ++ show g ++ " not found!") (\gdas -> let curargs = map (\ (i,e) -> (i,absEvalExpr e bvs)) (zip [1..] es) cdas = gdas \\ map fst (filter ((/=Bot) . snd) curargs) in if null cdas then Top else Bot) (lookup g calledFuncs) else Top absEvalExpr (Free _ e) bvs = absEvalExpr e bvs absEvalExpr (Let bs e) bvs = absEvalExpr e (absEvalBindings bs bvs) absEvalExpr (Or e1 e2) bvs = lub (absEvalExpr e1 bvs) (absEvalExpr e2 bvs) absEvalExpr (Case _ e bs) bvs = if absEvalExpr e bvs == Bot then Bot else foldr lub Bot (map absEvalBranch bs) where absEvalBranch (Branch _ be) = absEvalExpr be bvs absEvalExpr (Typed e _) bvs = absEvalExpr e bvs -- could be improved with local fixpoint computation absEvalBindings [] bvs = bvs absEvalBindings ((i,exp) : bs) bvs = let ival = absEvalExpr exp bvs in if ival==Bot then absEvalBindings bs (i:bvs) else absEvalBindings bs bvs prelude :: String prelude = "Prelude" ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/Deterministic.curry000066400000000000000000000251401377556325500273220ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Determinism analysis: --- checks whether functions are deterministic or nondeterministic, i.e., --- whether its evaluation on ground argument terms might cause --- different computation paths. --- --- @author Michael Hanus --- @version August 2016 ------------------------------------------------------------------------------ module Analysis.Deterministic ( overlapAnalysis, showOverlap, showDet , functionalAnalysis, showFunctional , Deterministic(..),nondetAnalysis , showNonDetDeps, nondetDepAnalysis, nondetDepAllAnalysis ) where import Analysis.Types import FlatCurry.Types import FlatCurry.Goodies import Data.List import Data.Char (isDigit) ------------------------------------------------------------------------------ -- The overlapping analysis can be applied to individual functions. -- It assigns to a FlatCurry function definition a flag which is True -- if this function is defined with overlapping left-hand sides. overlapAnalysis :: Analysis Bool overlapAnalysis = simpleFuncAnalysis "Overlapping" isOverlappingFunction isOverlappingFunction :: FuncDecl -> Bool isOverlappingFunction (Func _ _ _ _ (Rule _ e)) = orInExpr e isOverlappingFunction (Func f _ _ _ (External _)) = f==("Prelude","?") -- Check an expression for occurrences of OR: orInExpr :: Expr -> Bool orInExpr (Var _) = False orInExpr (Lit _) = False orInExpr (Comb _ f es) = f==(pre "?") || any orInExpr es orInExpr (Free _ e) = orInExpr e orInExpr (Let bs e) = any orInExpr (map snd bs) || orInExpr e orInExpr (Or _ _) = True orInExpr (Case _ e bs) = orInExpr e || any orInBranch bs where orInBranch (Branch _ be) = orInExpr be orInExpr (Typed e _) = orInExpr e -- Show overlapping information as a string. showOverlap :: AOutFormat -> Bool -> String showOverlap _ True = "overlapping" showOverlap AText False = "non-overlapping" showOverlap ANote False = "" ------------------------------------------------------------------------------ -- The functional analysis is a global function dependency analysis. -- It assigns to a FlatCurry function definition a flag which is True -- if this function is purely functional defined, i.e., its definition -- does not depend on operation containing overlapping rules or free variables. functionalAnalysis :: Analysis Bool functionalAnalysis = dependencyFuncAnalysis "Functional" True isFuncDefined -- Show functionally defined information as a string. showFunctional :: AOutFormat -> Bool -> String showFunctional _ True = "functional" showFunctional AText False = "defined with logic features" showFunctional ANote False = "" -- An operation is functionally defined if its definition is not -- non-deterministic (no overlapping rules, no extra variables) and -- it depends only on functionally defined operations. isFuncDefined :: FuncDecl -> [(QName,Bool)] -> Bool isFuncDefined func calledFuncs = not (isNondetDefined func) && and (map snd calledFuncs) -- Is a function f defined to be potentially non-deterministic, i.e., -- is the rule non-deterministic or does it contain extra variables? isNondetDefined :: FuncDecl -> Bool isNondetDefined (Func f _ _ _ rule) = f `notElem` (map pre ["failed","$!!","$##","normalForm","groundNormalForm"]) -- these operations are internally defined in PAKCS with extra variables && isNondetRule rule where isNondetRule (Rule _ e) = orInExpr e || extraVarInExpr e isNondetRule (External _) = f==("Prelude","?") -- check an expression for occurrences of extra variables: extraVarInExpr :: Expr -> Bool extraVarInExpr (Var _) = False extraVarInExpr (Lit _) = False extraVarInExpr (Comb _ _ es) = or (map extraVarInExpr es) extraVarInExpr (Free vars e) = (not (null vars)) || extraVarInExpr e extraVarInExpr (Let bs e) = any extraVarInExpr (map snd bs) || extraVarInExpr e extraVarInExpr (Or e1 e2) = extraVarInExpr e1 || extraVarInExpr e2 extraVarInExpr (Case _ e bs) = extraVarInExpr e || any extraVarInBranch bs where extraVarInBranch (Branch _ be) = extraVarInExpr be extraVarInExpr (Typed e _) = extraVarInExpr e ------------------------------------------------------------------------------ -- The determinism analysis is a global function dependency analysis. -- It assigns to a function a flag which indicates whether is function -- might be non-deterministic, i.e., might reduce in different ways -- for given ground arguments. -- If the non-determinism is encapsulated (set functions, AllSolutions), -- it is classified as deterministic. --- Data type to represent determinism information. data Deterministic = NDet | Det deriving (Eq, Ord, Show, Read) -- Show determinism information as a string. showDet :: AOutFormat -> Deterministic -> String showDet _ NDet = "non-deterministic" showDet AText Det = "deterministic" showDet ANote Det = "" nondetAnalysis :: Analysis Deterministic nondetAnalysis = dependencyFuncAnalysis "Deterministic" Det nondetFunc -- An operation is non-deterministic if its definition is potentially -- non-deterministic or it calls a non-deterministic operation -- where the non-deterministic call is not encapsulated. nondetFunc :: FuncDecl -> [(QName,Deterministic)] -> Deterministic nondetFunc func@(Func _ _ _ _ rule) calledFuncs = if isNondetDefined func || callsNDOpInRule rule then NDet else Det where callsNDOpInRule (Rule _ e) = callsNDOp e callsNDOpInRule (External _) = False callsNDOp (Var _) = False callsNDOp (Lit _) = False callsNDOp (Free _ e) = callsNDOp e callsNDOp (Let bs e) = any callsNDOp (map snd bs) || callsNDOp e callsNDOp (Or _ _) = True callsNDOp (Case _ e bs) = callsNDOp e || any (\ (Branch _ be) -> callsNDOp be) bs callsNDOp (Typed e _) = callsNDOp e callsNDOp (Comb _ qf@(mn,fn) es) | mn == "SetFunctions" && take 3 fn == "set" && all isDigit (drop 3 fn) = -- non-determinism of function (first argument) is encapsulated so that -- its called ND functions are not relevant: if null es then False -- this case should not occur else any callsNDOp (tail es) | mn == "AllSolutions" -- && fn `elem`== "getAllValues" = -- non-determinism of argument is encapsulated so that -- its called ND functions are not relevant: False | otherwise = maybe False (==NDet) (lookup qf calledFuncs) || any callsNDOp es ------------------------------------------------------------------------------ --- Data type to represent information about non-deterministic dependencies. --- Basically, it is the set (represented as a sorted list) of --- all function names that are defined by overlapping rules or rules --- containing free variables which might be called. --- In addition, the second component is (possibly) the list of --- functions from which this non-deterministic function is called. --- The length of this list is limited by 'maxDepsLength' in the --- `NonDetAllDeps` analysis or to 1 (i.e., only the direct caller is --- stored) in the `NonDetDeps` analysis. type NonDetDeps = [(QName,[QName])] --- The maximal length of a call chain associated with a non-deterministic --- operation dependency. We limit the length in order to avoid large --- analysis times for the `NonDetAllDeps` analysis. maxDepsLength :: Int maxDepsLength = 10 -- Show determinism dependency information as a string. showNonDetDeps :: AOutFormat -> NonDetDeps -> String showNonDetDeps AText [] = "deterministic" showNonDetDeps ANote [] = "" showNonDetDeps ANote xs@(_:_) = intercalate " " (nub (map (snd . fst) xs)) showNonDetDeps AText xs@(_:_) = "depends on non-det. operations: " ++ intercalate ", " (map showNDOpInfo xs) where showNDOpInfo (ndop,cfs) = showQName ndop ++ (if null cfs then "" else " (called from " ++ intercalate " -> " (map showQName cfs) ++ ")") showQName (mn,fn) = mn++"."++fn --- Non-deterministic dependency analysis. --- The analysis computes for each operation the set of operations --- with a non-deterministic definition which might be called by this --- operation. Non-deterministic operations that are called by other --- non-deterministic operations are ignored so that only the first --- (w.r.t. the call sequence) non-deterministic operations are returned. nondetDepAnalysis :: Analysis NonDetDeps nondetDepAnalysis = dependencyFuncAnalysis "NonDetDeps" [] (nondetDeps False) --- Non-deterministic dependency analysis. --- The analysis computes for each operation the set of *all* operations --- with a non-deterministic definition which might be called by this --- operation. nondetDepAllAnalysis :: Analysis NonDetDeps nondetDepAllAnalysis = dependencyFuncAnalysis "NonDetAllDeps" [] (nondetDeps True) -- An operation is non-deterministic if its definition is potentially -- non-deterministic (i.e., the dependency is the operation itself) -- or it depends on some called non-deterministic function. nondetDeps :: Bool -> FuncDecl -> [(QName,NonDetDeps)] -> NonDetDeps nondetDeps alldeps func@(Func f _ _ _ rule) calledFuncs = let calledndfuncs = sort (nub (map addCaller (calledNDFuncsInRule rule))) addCaller (ndf,cfs) | null cfs = (ndf,[f]) | alldeps && f `notElem` cfs && length cfs < maxDepsLength = (ndf,f:cfs) | otherwise = (ndf,cfs) in if isNondetDefined func then (f,[]) : (if alldeps then calledndfuncs else []) else calledndfuncs where calledNDFuncsInRule (Rule _ e) = calledNDFuncs e calledNDFuncsInRule (External _) = [] calledNDFuncs (Var _) = [] calledNDFuncs (Lit _) = [] calledNDFuncs (Free _ e) = calledNDFuncs e calledNDFuncs (Let bs e) = concatMap calledNDFuncs (map snd bs) ++ calledNDFuncs e calledNDFuncs (Or e1 e2) = calledNDFuncs e1 ++ calledNDFuncs e2 calledNDFuncs (Case _ e bs) = calledNDFuncs e ++ concatMap (\ (Branch _ be) -> calledNDFuncs be) bs calledNDFuncs (Typed e _) = calledNDFuncs e calledNDFuncs (Comb _ qf@(mn,fn) es) | mn == "SetFunctions" && take 3 fn == "set" && all isDigit (drop 3 fn) = -- non-determinism of function (first argument) is encapsulated so that -- its called ND functions are not relevant: if null es then [] -- this case should not occur else concatMap calledNDFuncs (tail es) | mn == "AllSolutions" -- && fn `elem`== "getAllValues" = -- non-determinism of argument is encapsulated so that -- its called ND functions are not relevant: [] | otherwise = maybe [] id (lookup qf calledFuncs) ++ concatMap calledNDFuncs es ------------------------------------------------------------------------------ pre :: String -> QName pre n = ("Prelude",n) ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/Files.curry000066400000000000000000000233741377556325500255700ustar00rootroot00000000000000-------------------------------------------------------------------------- --- This module contains operations to load and store analysis information --- persistently in files. --- --- @author Heiko Hoffmann, Michael Hanus --- @version December 2020 -------------------------------------------------------------------------- module Analysis.Files where import Curry.Compiler.Distribution ( curryCompiler, curryCompilerMajorVersion , curryCompilerMinorVersion , curryCompilerRevisionVersion, installDir ) import System.Directory import System.FilePath import Data.List ( intercalate, isPrefixOf, isSuffixOf ) import Data.Time ( ClockTime ) import Control.Monad ( when, unless ) import ReadShowTerm ( readQTerm, showQTerm ) import FlatCurry.Files import FlatCurry.Goodies ( progImports ) import FlatCurry.Types ( Prog, QName ) import System.CurryPath ( lookupModuleSourceInLoadPath, stripCurrySuffix ) import Analysis.Logging ( debugMessage ) import Analysis.ProgInfo --- Get the file name in which analysis results are stored --- (without suffix ".pub" or ".priv") getAnalysisBaseFile :: String -> String -> IO String getAnalysisBaseFile moduleName anaName = do analysisDirectory <- getAnalysisDirectory currentDir <- getCurrentDirectory >>= return . dropDrive let modAnaName = moduleName <.> anaName (fileDir,_) <- findModuleSourceInLoadPath moduleName if isAbsolute fileDir then return (analysisDirectory dropDrive fileDir modAnaName) else return (analysisDirectory currentDir fileDir modAnaName) --- Get the file name in which public analysis results are stored. getAnalysisPublicFile :: String -> String -> IO String getAnalysisPublicFile modname ananame = do getAnalysisBaseFile modname ananame >>= return . (<.> "pub") -- Cache directory where analysis info files are stored. -- If $HOME exists, it is ~/.curryanalysis_cache getAnalysisDirectory :: IO String getAnalysisDirectory = do homedir <- getHomeDirectory hashomedir <- doesDirectoryExist homedir let cassStoreDir = if hashomedir then homedir else installDir return $ cassStoreDir ".curryanalysis_cache" syspath where syspath = curryCompiler ++ "-" ++ intercalate "." (map show [ curryCompilerMajorVersion , curryCompilerMinorVersion , curryCompilerRevisionVersion ]) -- loads analysis results for a list of modules getInterfaceInfos :: Read a => String -> [String] -> IO (ProgInfo a) getInterfaceInfos _ [] = return emptyProgInfo getInterfaceInfos anaName (mod:mods) = do modInfo <- loadPublicAnalysis anaName mod modsInfo <- getInterfaceInfos anaName mods return (combineProgInfo modInfo modsInfo) --- Gets the file name in which default analysis values different from --- standard start values are stored. Typically, such a file contains --- specific analysis information for external operations. --- The file must contain a term of the type `[(String,a)]` where --- the first component of each pair is the name of the operation --- (it is assumed that this denotes an operation of the current module) --- and the second component is an analysis value. loadDefaultAnalysisValues :: String -> String -> IO [(QName,a)] loadDefaultAnalysisValues anaName moduleName = do (_,fileName) <- findModuleSourceInLoadPath moduleName let defaultFileName = stripCurrySuffix fileName ++ ".defaults." ++ anaName fileExists <- doesFileExist defaultFileName if fileExists then do debugMessage 3 ("Load default values from " ++ defaultFileName) defaultValues <- readFile defaultFileName >>= return . readQTerm return (map (\ (f,a) -> ((moduleName,f),a)) defaultValues) else return [] --- Loads the currently stored analysis information for a module. loadCompleteAnalysis :: Read a => String -> String -> IO (ProgInfo a) loadCompleteAnalysis ananame mainModule = getAnalysisBaseFile mainModule ananame >>= readAnalysisFiles --- Reads analysis result from file for the public entities of a given module. loadPublicAnalysis:: Read a => String -> String -> IO (ProgInfo a) loadPublicAnalysis anaName moduleName = do getAnalysisPublicFile moduleName anaName >>= readAnalysisPublicFile --- Store current import dependencies. storeImportModuleList :: String -> [String] -> IO () storeImportModuleList modname modlist = do importListFile <- getAnalysisBaseFile modname "IMPORTLIST" createDirectoryR (dropFileName importListFile) writeFile importListFile (showQTerm modlist) --- Gets the file containing import dependencies for a main module --- (if it exists). getImportModuleListFile :: String -> IO (Maybe String) getImportModuleListFile modname = do importListFile <- getAnalysisBaseFile modname "IMPORTLIST" iflExists <- doesFileExist importListFile return $ if iflExists then Just importListFile else Nothing --- Store an analysis results in a file and create directories if neccesssary. --- The first argument is the analysis name. storeAnalysisResult :: Show a => String -> String -> ProgInfo a -> IO () storeAnalysisResult ananame moduleName result = do baseFileName <- getAnalysisBaseFile moduleName ananame createDirectoryR (dropFileName baseFileName) debugMessage 4 ("Analysis result: " ++ showProgInfo result) writeAnalysisFiles baseFileName result -- creates directory (and all needed root-directories) recursively createDirectoryR :: String -> IO () createDirectoryR maindir = let (drv,dir) = splitDrive maindir in createDirectories drv (splitDirectories dir) where createDirectories _ [] = return () createDirectories dirname (dir:dirs) = do let createdDir = dirname dir dirExists <- doesDirectoryExist createdDir unless dirExists $ do debugMessage 3 ("Creating directory '" ++ createdDir ++ "'...") createDirectory createdDir createDirectories createdDir dirs --- Deletes all analysis files for a given analysis name. deleteAllAnalysisFiles :: String -> IO () deleteAllAnalysisFiles ananame = do analysisDir <- getAnalysisDirectory deleteAllInDir analysisDir where deleteAllInDir dir = do dircont <- getDirectoryContents dir mapM_ processDirElem (filter (not . isPrefixOf ".") dircont) where processDirElem f = do let fullname = dir f when (isAnaFile f) $ do putStrLn ("DELETE: " ++ fullname) removeFile fullname isdir <- doesDirectoryExist fullname when isdir $ deleteAllInDir fullname isAnaFile f = (".pub" `isSuffixOf` f && ('.':ananame) `isSuffixOf` dropExtension f) || (".priv" `isSuffixOf` f && ('.':ananame) `isSuffixOf` dropExtension f) -------------------------------------------------------------------------- -- Auxiliaries for dealing with Curry files. --- Returns a directory name and the actual source file name for a module --- by looking up the module source in the current load path. --- If the module is hierarchical, the directory is the top directory --- of the hierarchy. --- An error is raised if there is no corresponding source file. findModuleSourceInLoadPath :: String -> IO (String,String) findModuleSourceInLoadPath modname = lookupModuleSourceInLoadPath modname >>= maybe (error $ "Source file for module '"++modname++"' not found!") return --- Get the imports of a module. getImports :: String -> IO [String] getImports moduleName = do debugMessage 3 ("Reading interface of module "++moduleName) readNewestFlatCurryInt moduleName >>= return . progImports -- Get timestamp of a Curry source module file (together with the module name) getSourceFileTime :: String -> IO (String,ClockTime) getSourceFileTime moduleName = do (_,fileName) <- findModuleSourceInLoadPath moduleName time <- getModificationTime fileName return (moduleName,time) -- Get timestamp of FlatCurry file (together with the module name) getFlatCurryFileTime :: String -> IO (String,Maybe ClockTime) getFlatCurryFileTime modname = lookupFlatCurryFileInLoadPath modname >>= maybe (return (modname, Nothing)) (\fcyFileName -> do ftime <- getModificationTime fcyFileName return (modname, Just ftime)) --- Returns name of the FlatCurry file of a module if this file exists --- and is newer than the source file. flatCurryFileNewer :: String -> IO (Maybe String) flatCurryFileNewer modname = do (_,sourceFileName) <- findModuleSourceInLoadPath modname stime <- getModificationTime sourceFileName lookupFlatCurryFileInLoadPath modname >>= maybe (return Nothing) (\fcyFileName -> do itime <- getModificationTime fcyFileName return (if itime >= stime then Just fcyFileName else Nothing)) --- Returns the newest FlatCurry program for a module. --- The source program is parsed if the interface older than the source, --- otherwise the FlatCurry program is read without parsing --- (note that this returns only the correct version if the --- imported modules are already parsed or are not relevant here). readNewestFlatCurry :: String -> IO Prog readNewestFlatCurry modname = flatCurryFileNewer modname >>= maybe (readFlatCurry modname) readFlatCurryFile --- Returns the newest FlatCurry interface for a module. --- The source program is parsed if the interface older than the source, --- otherwise the FlatCurry interface file is read without parsing --- (note that this returns only the correct version if the --- imported modules are already parsed or are not relevant here). readNewestFlatCurryInt :: String -> IO Prog readNewestFlatCurryInt modname = flatCurryFileNewer modname >>= maybe (readFlatCurryInt modname) (readFlatCurryFile . flat2intName) --- Translates FlatCurry file name to corresponding FlatCurry interface --- file name. flat2intName :: String -> String flat2intName fn = reverse ("tnif" ++ drop 3 (reverse fn)) curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/Groundness.curry000066400000000000000000000241161377556325500266500ustar00rootroot00000000000000------------------------------------------------------------------------ --- Groundness/non-determinism effect analysis based on --- [Brassel/Hanus'05](http://www.informatik.uni-kiel.de/~mh/papers/ICLP05.html). --- --- @author Michael Hanus --- @version May 2013 ------------------------------------------------------------------------ module Analysis.Groundness ( Ground(..), showGround, groundAnalysis , NDEffect(..), showNDEffect, ndEffectAnalysis ) where import FlatCurry.Types import Data.List import Analysis.Types import Analysis.ProgInfo ------------------------------------------------------------------------ -- Analyze the groundness of functions. ------------------------------------------------------------------------ --- Type to represent groundness information. --- Definitely ground (G), maybe non-ground (A), or maybe non-ground --- if i-th argument is non-ground (P [...,i,...]). data Ground = G | A | P [Int] deriving (Show, Read, Eq) -- Show groundness information as a string. showGround :: AOutFormat -> Ground -> String showGround ANote G = "G" showGround AText G = "always ground result" showGround ANote A = "A" showGround AText A = "possibly non-ground result" showGround ANote (P ps) = show ps showGround AText (P ps) = "ground if argument" ++ (if length ps == 1 then ' ' : show (head ps) ++ " is ground" else "s " ++ show ps ++ " are ground") -- Lowest upper bound on groundness information. lubG :: Ground -> Ground -> Ground lubG G y = y lubG A _ = A lubG (P ps) G = P ps lubG (P _ ) A = A lubG (P ps) (P qs) = P (mergeInts ps qs) ------------------------------------------------------------------------ -- Analyze the groundness information of functions. groundAnalysis :: Analysis Ground groundAnalysis = dependencyFuncAnalysis "Groundness" G groundFunc groundFunc :: FuncDecl -> [(QName,Ground)] -> Ground groundFunc (Func (m,f) _ _ _ rule) calledFuncs | m==prelude && f `elem` preludeGroundFuncs = G | m==prelude = maybe anaresult id (lookup f preludeFuncs) | otherwise = anaresult where anaresult = groundFuncRule calledFuncs rule preludeFuncs = [("cond",P [2]),("seq",P [2]),("ensureNotFree",P [1])] preludeGroundFuncs = ["+","-","*","div","mod","divMod","quot","rem","quotRem","negateFloat", "==","=:=","=:<=","compare","<",">","<=",">=","failed","error"] groundFuncRule :: [(QName,Ground)] -> Rule -> Ground groundFuncRule _ (External _) = A -- nothing known about other externals groundFuncRule calledFuncs (Rule args rhs) = absEvalExpr (zip args (map (\i->P [i]) [1..])) rhs where -- abstract evaluation of an expression w.r.t. groundness environment absEvalExpr env (Var i) = maybe A -- occurs in case of recursive lets id (lookup i env) absEvalExpr _ (Lit _) = G absEvalExpr env (Comb ct g es) = if ct == FuncCall then maybe (error $ "Abstract value of " ++ show g ++ " not found!") (\gd -> let curargs = zip [1..] (map (absEvalExpr env) es) in groundApply gd curargs) (lookup g calledFuncs) else foldr lubG G (map (absEvalExpr env) es) absEvalExpr env (Free vs e) = absEvalExpr (zip vs (repeat A) ++ env) e absEvalExpr env (Let bs e) = absEvalExpr (absEvalBindings env bs) e absEvalExpr env (Or e1 e2) = lubG (absEvalExpr env e1) (absEvalExpr env e2) absEvalExpr env (Typed e _) = absEvalExpr env e absEvalExpr env (Case _ e bs) = foldr lubG G (map absEvalBranch bs) where gcase = absEvalExpr env e absEvalBranch (Branch (LPattern _) be) = absEvalExpr env be absEvalBranch (Branch (Pattern _ pargs) be) = absEvalExpr (map (\pi -> (pi,gcase)) pargs ++ env) be -- could be improved for recursive lets with local fixpoint computation absEvalBindings env [] = env absEvalBindings env ((i,exp):bs) = absEvalBindings ((i, absEvalExpr env exp) : env) bs -- compute groundness information for an application groundApply :: Ground -> [(Int,Ground)] -> Ground groundApply G _ = G groundApply A _ = A groundApply (P ps) gargs = foldr lubG G (map (\p -> maybe A id (lookup p gargs)) ps) ----------------------------------------------------------------------- -- Non-determinism effect analysis ----------------------------------------------------------------------- --- Type to represent non-determinism effects. --- A non-determinism effect can be due to an Or (first argument), --- due to a narrowing step (second argument), or if i-th argument --- is non-ground (if i is a member of the third argument). data NDEffect = NDEffect Bool Bool [Int] deriving (Eq, Ord, Show, Read) noEffect :: NDEffect noEffect = NDEffect False False [] orEffect :: NDEffect orEffect = NDEffect True False [] narrEffect :: NDEffect narrEffect = NDEffect False True [] narrIfEffect :: [Int] -> NDEffect narrIfEffect = NDEffect False False -- Show non-determinitic effect information as a string. showNDEffect :: AOutFormat -> NDEffect -> String showNDEffect ANote (NDEffect ornd narr ifs) = intercalate " " $ (if ornd then ["choice"] else []) ++ (if narr then ["narr"] else []) ++ (if not (null ifs) then ["narrIf"++show ifs] else []) showNDEffect AText (NDEffect ornd narr ifs) = intercalate " / " $ (if ornd then ["choice"] else []) ++ (if narr then ["possibly non-deterministic narrowing steps"] else []) ++ (if not (null ifs) then ["non-deterministic narrowing if argument" ++ (if length ifs == 1 then ' ' : show (head ifs) ++ " is non-ground" else "s " ++ show ifs ++ " are non-ground")] else []) -- Lowest upper bound on non-determinism effects. lubE :: NDEffect -> NDEffect -> NDEffect lubE (NDEffect ornd1 narr1 ifs1) (NDEffect ornd2 narr2 ifs2) = NDEffect (ornd1 || ornd2) narr (if narr then [] else mergeInts ifs1 ifs2) where narr = narr1 || narr2 -- Lowest upper bound on groundness/non-determinism effects. lubGE :: (Ground,NDEffect) -> (Ground,NDEffect) -> (Ground,NDEffect) lubGE (g1,ne1) (g2,ne2) = (lubG g1 g2, lubE ne1 ne2) ------------------------------------------------------------------------ -- Analyze the non-determinism effect of functions. ndEffectAnalysis :: Analysis NDEffect ndEffectAnalysis = combinedDependencyFuncAnalysis "NDEffect" groundAnalysis noEffect ndEffectFunc ndEffectFunc :: ProgInfo Ground -> FuncDecl -> [(QName,NDEffect)] -> NDEffect ndEffectFunc groundinfo (Func (m,f) _ _ _ rule) calledFuncs | m==prelude = maybe anaresult id (lookup f preludeFuncs) | otherwise = anaresult where anaresult = ndEffectFuncRule groundinfo calledFuncs rule preludeFuncs = [("?",orEffect)] ndEffectFuncRule :: ProgInfo Ground -> [(QName,NDEffect)] -> Rule -> NDEffect ndEffectFuncRule _ _ (External _) = noEffect -- externals are deterministic ndEffectFuncRule groundinfo calledFuncs (Rule args rhs) = snd (absEvalExpr (zip args (map (\i->(P [i],noEffect)) [1..])) rhs) where -- abstract evaluation of an expression w.r.t. NDEffect environment absEvalExpr env (Var i) = maybe (A,noEffect) id (lookup i env) absEvalExpr _ (Lit _) = (G,noEffect) absEvalExpr env (Comb ct g es) = if ct == FuncCall then maybe (error $ "Abstract value of " ++ show g ++ " not found!") (\gnd -> let curargs = zip [1..] (map (absEvalExpr env) es) in maybe (error $ "Ground value of " ++ show g ++ " not found!") (\ggd -> ndEffectApply (ggd,gnd) curargs) (lookupProgInfo g groundinfo)) (lookup g calledFuncs) else foldr lubGE (G,noEffect) (map (absEvalExpr env) es) absEvalExpr env (Free vs e) = absEvalExpr (zip vs (repeat (A,noEffect)) ++ env) e absEvalExpr env (Let bs e) = absEvalExpr (absEvalBindings env bs) e absEvalExpr env (Or e1 e2) = let (g1,nd1) = absEvalExpr env e1 (g2,nd2) = absEvalExpr env e2 in (lubG g1 g2, lubE orEffect (lubE nd1 nd2)) absEvalExpr env (Typed e _) = absEvalExpr env e absEvalExpr env (Case ctype e bs) = if ctype==Rigid {- not really for KiCS2 -} || gcase==G || length bs == 1 then (gbrs, lubE ndbrs ndcase) else (gbrs, lubE (ground2nondet gcase) (lubE ndbrs ndcase)) where (gcase,ndcase) = absEvalExpr env e (gbrs,ndbrs) = foldr lubGE (G,noEffect) (map absEvalBranch bs) ground2nondet G = noEffect ground2nondet A = narrEffect ground2nondet (P ps) = narrIfEffect ps absEvalBranch (Branch (LPattern _) be) = absEvalExpr env be absEvalBranch (Branch (Pattern _ pargs) be) = absEvalExpr (map (\pi -> (pi,(gcase,noEffect))) pargs ++ env) be -- could be improved for recursive lets with local fixpoint computation absEvalBindings env [] = env absEvalBindings env ((i,exp):bs) = absEvalBindings ((i, absEvalExpr env exp) : env) bs -- compute ground/nondet effect information for an application ndEffectApply :: (Ground,NDEffect) -> [(Int,(Ground,NDEffect))] -> (Ground,NDEffect) ndEffectApply (fgd,fnd) argsgnd = let (argsgd,argsnd) = unzip (map (\ (i,(gd,nd)) -> ((i,gd),nd)) argsgnd) in (groundApply fgd argsgd, foldr lubE (ndEffectReplace argsgd fnd) argsnd) -- replace (narrIf i) by i-th ground value ndEffectReplace :: [(Int,Ground)] -> NDEffect -> NDEffect ndEffectReplace argsgd (NDEffect ornd narrnd ifs) = replaceProjs [] ifs where -- replace i by i-th ground value replaceProjs ps [] = NDEffect ornd narrnd ps replaceProjs ps (i:is) = maybe (error $ "Ground value of argument " ++ show i ++ " not found!") (\g -> case g of G -> replaceProjs ps is A -> NDEffect ornd True [] P ips -> replaceProjs (mergeInts ips ps) is) (lookup i argsgd) ----------------------------------------------------------------------- -- merge ascending lists of integers and remove duplicates mergeInts :: [Int] -> [Int] -> [Int] mergeInts [] ys = ys mergeInts (x:xs) [] = x:xs mergeInts (x:xs) (y:ys) | x==y = x : mergeInts xs ys | xy = y : mergeInts (x:xs) ys prelude :: String prelude = "Prelude" ----------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/HigherOrder.curry000066400000000000000000000061521377556325500267230ustar00rootroot00000000000000------------------------------------------------------------------------ --- Analysis of higher-order properties of types and operations. ------------------------------------------------------------------------ module Analysis.HigherOrder (Order(..),showOrder,hiOrdType,hiOrdCons,hiOrdFunc) where import Analysis.Types import Analysis.ProgInfo import FlatCurry.Types import FlatCurry.Goodies import Data.Maybe -- datatype order: higher-order or first-order data Order = HO | FO deriving (Show, Read, Eq) -- Show higher-order information as a string. showOrder :: AOutFormat -> Order -> String showOrder _ HO = "higher-order" showOrder _ FO = "first-order" hoOr :: Order -> Order -> Order hoOr HO _ = HO hoOr FO x = x ------------------------------------------------------------------------ -- higher-order data type analysis hiOrdType :: Analysis Order hiOrdType = dependencyTypeAnalysis "HiOrderType" FO orderOfType orderOfType :: TypeDecl -> [(QName,Order)] -> Order orderOfType (Type _ _ _ conDecls) usedtypes = hoOr (foldr hoOr FO (map orderOfConsDecl conDecls)) (foldr hoOr FO (map snd usedtypes)) where orderOfConsDecl (Cons _ _ _ typeExprs) = foldr hoOr FO (map orderOfTypeExpr typeExprs) orderOfType (TypeSyn _ _ _ typeExpr) usedtypes = hoOr (orderOfTypeExpr typeExpr) (foldr hoOr FO (map snd usedtypes)) orderOfType (TypeNew _ _ _ (NewCons _ _ typeExpr)) usedtypes = hoOr (orderOfTypeExpr typeExpr) (foldr hoOr FO (map snd usedtypes)) -- compute the order of a type expression (ignore the type constructors, -- i.e., check whether this expression contains a `FuncType`). orderOfTypeExpr :: TypeExpr -> Order orderOfTypeExpr (TVar _) = FO orderOfTypeExpr (FuncType _ _) = HO orderOfTypeExpr (TCons _ typeExprs) = foldr hoOr FO (map orderOfTypeExpr typeExprs) orderOfTypeExpr (ForallType _ texp) = orderOfTypeExpr texp ----------------------------------------------------------------------- -- higher-order constructor analysis hiOrdCons :: Analysis Order hiOrdCons = simpleConstructorAnalysis "HiOrderConstr" orderOfConsDecl where orderOfConsDecl (Cons _ _ _ typeExprs) _ = foldr hoOr FO (map orderOfTypeExpr typeExprs) ----------------------------------------------------------------------- -- higher-order function analysis hiOrdFunc :: Analysis Order hiOrdFunc = combinedSimpleFuncAnalysis "HiOrderFunc" hiOrdType orderOfFunc orderOfFunc :: ProgInfo Order -> FuncDecl-> Order orderOfFunc orderMap func = orderOfFuncTypeArity orderMap (funcType func) (funcArity func) orderOfFuncTypeArity :: ProgInfo Order -> TypeExpr -> Int -> Order orderOfFuncTypeArity orderMap functype arity = if arity==0 then case functype of FuncType _ _ -> HO TVar (-42) -> HO TCons x (y:ys) -> hoOr (orderOfFuncTypeArity orderMap y 0) (orderOfFuncTypeArity orderMap (TCons x ys) 0) TCons tc [] -> fromMaybe FO (lookupProgInfo tc orderMap) _ -> FO else let (FuncType x y) = functype in hoOr (orderOfFuncTypeArity orderMap x 0) (orderOfFuncTypeArity orderMap y (arity-1)) ----------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/Indeterministic.curry000066400000000000000000000052241377556325500276520ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Indeterminism analysis: --- check whether functions are indeterministic, i.e., might deliver --- different results for different runs of a program. --- This could be the case if there are explicit or implicit calls --- to `SetFunctions.select` or to a committed choice. --- --- @author Michael Hanus --- @version April 2013 ------------------------------------------------------------------------------ module Analysis.Indeterministic(indetAnalysis,showIndet) where import Analysis.Types import FlatCurry.Types ------------------------------------------------------------------------------ --- The indeterminism analysis is a global function dependency analysis. --- It assigns to a function a flag which is True if this function --- might be indeterministic (i.e., calls directly or indirectly --- a select or committed choice operation). indetAnalysis :: Analysis Bool indetAnalysis = dependencyFuncAnalysis "Indeterministic" False indetFunc --- An operation is indeterministic if it calls a select or committed choice --- or depends on some indeterministic operation. indetFunc :: FuncDecl -> [(QName,Bool)] -> Bool indetFunc func calledFuncs = hasIndetRules func || any snd calledFuncs -- Show right-linearity information as a string. showIndet :: AOutFormat -> Bool -> String showIndet AText True = "impure (indeterministic) operation" showIndet ANote True = "indeterministic" showIndet AText False = "referentially transparent operation" showIndet ANote False = "" ------------------------------------------------------------------------------ -- The right-linearity analysis can also be applied to individual functions. -- It returns True for a function if it is defined by right-linear rules. hasIndetRules :: FuncDecl -> Bool hasIndetRules (Func _ _ _ _ (Rule _ e)) = choiceInExpr e hasIndetRules (Func _ _ _ _ (External _)) = False -- check an expression for occurrences of select, committed choice, or send: choiceInExpr :: Expr -> Bool choiceInExpr (Var _) = False choiceInExpr (Lit _) = False choiceInExpr (Comb _ f es) = f `elem` indetFuns || any choiceInExpr es choiceInExpr (Free _ e) = choiceInExpr e choiceInExpr (Let bs e) = any choiceInExpr (map snd bs) || choiceInExpr e choiceInExpr (Or e1 e2) = choiceInExpr e1 || choiceInExpr e2 choiceInExpr (Case _ e bs) = choiceInExpr e || any choiceInBranch bs where choiceInBranch (Branch _ be) = choiceInExpr be choiceInExpr (Typed e _) = choiceInExpr e indetFuns :: [QName] indetFuns = [("Prelude","commit"), ("Ports","send"),("Ports","doSend"), ("SetFunctions","select")] -- end of Indeterministic curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/Logging.curry000066400000000000000000000030221377556325500261000ustar00rootroot00000000000000-------------------------------------------------------------------------- --- This module provides operation for log messages and setting --- the log level for the analyses. --- --- @author Michael Hanus --- @version March 2017 -------------------------------------------------------------------------- module Analysis.Logging ( getDebugLevel, setDebugLevel, debugMessage, debugString ) where import Control.Monad import Global -------------------------------------------------------------------------- --- Global variable to store the debug level. --- Debug levels: --- 0 : show nothing --- 1 : show worker activity, e.g., timings --- 2 : show server communication --- 3 : ...and show read/store information --- 4 : ...show also stored/computed analysis data debugLevel :: Global Int debugLevel = global 1 Temporary --- Gets the current debug level. getDebugLevel :: IO Int getDebugLevel = readGlobal debugLevel --- Sets the debug level to a new value. setDebugLevel :: Int -> IO () setDebugLevel l = writeGlobal debugLevel l -------------------------------------------------------------------------- --- Prints a message line if debugging level is at least n: debugMessage :: Int -> String -> IO () debugMessage n message = debugString n (message++"\n") --- Prints a string if debugging level (as specified in the Config file) --- is at least n: debugString :: Int -> String -> IO () debugString n message = do dl <- getDebugLevel when (dl>=n) $ putStr message -------------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/ProgInfo.curry000066400000000000000000000113601377556325500262410ustar00rootroot00000000000000----------------------------------------------------------------------- --- This module defines a datatype to represent the analysis information. --- --- @author Heiko Hoffmann, Michael Hanus --- @version January 2019 ----------------------------------------------------------------------- module Analysis.ProgInfo ( ProgInfo, emptyProgInfo, lookupProgInfo, combineProgInfo , lists2ProgInfo, publicListFromProgInfo, progInfo2Lists, progInfo2XML , mapProgInfo, publicProgInfo , showProgInfo, equalProgInfo , readAnalysisFiles, readAnalysisPublicFile, writeAnalysisFiles ) where import Prelude hiding (empty, lookup) import System.Directory (removeFile) import System.FilePath ((<.>)) import Data.Map import FlatCurry.Types import XML import Analysis.Logging (debugMessage) --- Type to represent analysis information. --- The first component are public declarations, the second the private ones. data ProgInfo a = ProgInfo (Map QName a) (Map QName a) --- The empty program information. emptyProgInfo:: ProgInfo a emptyProgInfo = ProgInfo empty empty --- Gets the information about an entity. lookupProgInfo:: QName -> ProgInfo a -> Maybe a lookupProgInfo key (ProgInfo map1 map2) = case lookup key map1 of Just x -> Just x Nothing -> lookup key map2 --- Combines two analysis informations. combineProgInfo :: ProgInfo a -> ProgInfo a -> ProgInfo a combineProgInfo (ProgInfo x1 x2) (ProgInfo y1 y2) = ProgInfo (union x1 y1) (union x2 y2) --- Converts a public and a private analysis list into a program info. lists2ProgInfo :: ([(QName,a)],[(QName,a)]) -> ProgInfo a lists2ProgInfo (xs,ys) = ProgInfo (fromList xs) (fromList ys) --- Returns the infos of public operations as a list. publicListFromProgInfo:: ProgInfo a -> [(QName,a)] publicListFromProgInfo (ProgInfo fm1 _) = toList fm1 --- Transforms a program information into a pair of lists --- containing the information about public and private entities. progInfo2Lists :: ProgInfo a -> ([(QName,a)],[(QName,a)]) progInfo2Lists (ProgInfo map1 map2)= (toList map1,toList map2) --- Transforms analysis information into XML format. progInfo2XML :: ProgInfo String -> ([XmlExp],[XmlExp]) progInfo2XML (ProgInfo map1 map2) = (foldrWithKey entry2xml [] map1, foldrWithKey entry2xml [] map2) where entry2xml (mname,name) value xmlList = (xml "operation" [xml "module" [xtxt mname], xml "name" [xtxt name], xml "result" [xtxt value]]) : xmlList mapProgInfo:: (a->b) -> ProgInfo a -> ProgInfo b mapProgInfo func (ProgInfo map1 map2) = ProgInfo (mapWithKey (\_ b->func b) map1) (mapWithKey (\_ b->func b) map2) --- Transforms a program information into a program information --- about interface entities only. publicProgInfo :: ProgInfo a -> ProgInfo a publicProgInfo (ProgInfo pub _) = ProgInfo pub empty --- Show a ProgInfo as a string (used for debugging only). showProgInfo :: Show a => ProgInfo a -> String showProgInfo (ProgInfo fm1 fm2) = "Public: "++show fm1++"\nPrivate: "++show fm2 -- Equality on ProgInfo equalProgInfo :: Eq a => ProgInfo a -> ProgInfo a -> Bool equalProgInfo (ProgInfo pi1p pi1v) (ProgInfo pi2p pi2v) = pi1p == pi2p && pi1v == pi2v --- Writes a ProgInfo into a file. writeAnalysisFiles :: Show a => String -> ProgInfo a -> IO () writeAnalysisFiles basefname (ProgInfo pub priv) = do debugMessage 3 $ "Writing analysis files '"++basefname++"'..." writeFile (basefname <.> "priv") (show priv) writeFile (basefname <.> "pub") (show pub) --- Reads a ProgInfo from the analysis files where the base file name is given. readAnalysisFiles :: Read a => String -> IO (ProgInfo a) readAnalysisFiles basefname = do debugMessage 3 $ "Reading analysis files '"++basefname++"'..." let pubcontfile = basefname <.> "pub" privcontfile = basefname <.> "priv" pubcont <- readFile pubcontfile privcont <- readFile privcontfile let pinfo = ProgInfo (read pubcont) (read privcont) catch (return $!! pinfo) (\err -> do putStrLn ("Buggy analysis files detected and removed:\n"++ basefname) mapM_ removeFile [pubcontfile,privcontfile] putStrLn "Please try to re-run the analysis!" ioError err) --- Reads the public ProgInfo from the public analysis file. readAnalysisPublicFile :: Read a => String -> IO (ProgInfo a) readAnalysisPublicFile fname = do debugMessage 3 $ "Reading public analysis file '"++fname++"'..." fcont <- readFile fname let pinfo = ProgInfo (read fcont) empty catch (return $!! pinfo) (\err -> do putStrLn ("Buggy analysis files detected and removed:\n"++fname) removeFile fname putStrLn "Please try to re-run the analysis!" ioError err) ----------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/RequiredValue.curry000066400000000000000000000301311377556325500272700ustar00rootroot00000000000000----------------------------------------------------------------------------- --- Required value analysis for Curry programs --- --- This analysis checks for each function in a Curry program whether --- the arguments of a function must have a particular shape in order to --- compute some value of this function. --- For instance, the negation operation `not` requires the argument --- value `False` in order to compute the result `True` and it requires --- the argument `True` to compute the result `False`. --- --- @author Michael Hanus --- @version April 2018 ----------------------------------------------------------------------------- module Analysis.RequiredValue (AType(..), showAType, AFType(..), showAFType, lubAType, reqValueAnalysis) where import Analysis.Types import Analysis.ProgInfo import Analysis.TotallyDefined(siblingCons) import FlatCurry.Types import FlatCurry.Goodies import Data.List ------------------------------------------------------------------------------ -- Our abstract (non-standard) type domain. -- `Any` represents any expression, -- `AnyC` represents any value (i.e., constructor-rooted term), -- `Cons c` a value rooted by the constructor `c`, and -- `Empty` represents no possible value. data AType = Any | AnyC | Cons QName | Empty deriving (Eq, Ord, Show, Read) --- Is some abstract type a constructor? isConsValue :: AType -> Bool isConsValue av = case av of Cons _ -> True _ -> False --- Least upper bound of abstract values. lubAType :: AType -> AType -> AType lubAType Any _ = Any lubAType AnyC Any = Any lubAType AnyC AnyC = AnyC lubAType AnyC (Cons _) = AnyC lubAType AnyC Empty = AnyC lubAType (Cons _) Any = Any lubAType (Cons _) AnyC = AnyC lubAType (Cons c) (Cons d) = if c==d then Cons c else AnyC lubAType (Cons c) Empty = Cons c lubAType Empty av = av --- Join two abstract values. The result is `Empty` if they are not compatible. joinAType :: AType -> AType -> AType joinAType Any av = av joinAType AnyC Any = AnyC joinAType AnyC AnyC = AnyC joinAType AnyC (Cons c) = Cons c joinAType AnyC Empty = Empty joinAType (Cons c) Any = Cons c joinAType (Cons c) AnyC = Cons c joinAType (Cons c) (Cons d) = if c==d then Cons c else Empty joinAType (Cons _) Empty = Empty joinAType Empty _ = Empty --- Are two abstract types compatible, i.e., describe common values? compatibleType :: AType -> AType -> Bool compatibleType t1 t2 = joinAType t1 t2 /= Empty -- Shows an abstract value. showAType :: AOutFormat -> AType -> String showAType _ Any = "any" showAType _ AnyC = "cons" showAType _ (Cons (_,n)) = n --q++"."++n showAType _ Empty = "_|_" --- The abstract type of a function. --- It is either `EmptyFunc`, i.e., contains no information about --- the possible result of the function, --- or a list of possible argument/result type pairs. data AFType = EmptyFunc | AFType [([AType],AType)] deriving (Read, Show, Eq, Ord) -- Shows an abstract value. showAFType :: AOutFormat -> AFType -> String showAFType _ EmptyFunc = "EmptyFunc" showAFType aof (AFType fts) = intercalate " | " (map showFType fts) where showFType (targs,tres) = "(" ++ intercalate "," (map (showAType aof) targs) ++ " -> " ++ showAType aof tres ++ ")" showCalledFuncs :: [(QName,AFType)] -> String showCalledFuncs = intercalate "|" . map (\ ((_,f),at) -> f++"::"++showAFType _ at) ------------------------------------------------------------------------------ --- An abstract environments used in the analysis of a function associates --- to each variable (index) an abstract type. type AEnv = [(Int,AType)] --- Extend an abstract environment with variables of any type: extendEnv :: AEnv -> [Int] -> AEnv extendEnv env vars = zip vars (repeat Any) ++ env --- Update a variable in an abstract environment: updateVarInEnv :: AEnv -> Int -> AType -> AEnv updateVarInEnv [] v _ = error ("Variable "++show v++" not found in environment") updateVarInEnv ((i,ov):env) v nv = if i==v then (i,nv) : env else (i,ov) : updateVarInEnv env v nv --- Drop the first n elements from the environment component --- of an environment/type pair: dropEnv :: Int -> ([a],b) -> ([a],b) dropEnv n (env,rtype) = (drop n env, rtype) -- Sorts a list of environment/type pairs by the type. sortEnvTypes :: [(AEnv,AType)] -> [(AEnv,AType)] sortEnvTypes = sortBy (\ (e1,t1) (e2,t2) -> (t1,e1) <= (t2,e2)) ------------------------------------------------------------------------------ --- The maximum number of different constructors considered for the --- required value analysis. If a type has more constructors than --- specified here, it will not be analyzed for individual required --- constructor values. maxReqValues :: Int maxReqValues = 3 --- Required value analysis. reqValueAnalysis :: Analysis AFType reqValueAnalysis = combinedDependencyFuncAnalysis "RequiredValue" siblingCons EmptyFunc analyseReqVal analyseReqVal :: ProgInfo [(QName,Int)] -> FuncDecl -> [(QName,AFType)] -> AFType analyseReqVal consinfo (Func (m,f) arity _ _ rule) calledfuncs | m==prelude = maybe (anaresult rule) id (lookup f preludeFuncs) | otherwise = --trace ("Analyze "++f++"\n"++showCalledFuncs calledfuncs++ -- "\nRESULT: "++showAFType _ (anaresult rule)) $ anaresult rule where anaresult (External _) = AFType [(take arity (repeat Any),AnyC)] anaresult (Rule args rhs) = analyseReqValRule consinfo calledfuncs args rhs -- add special results for prelude functions here: preludeFuncs = [("failed",AFType [([],Empty)]) ,("==",AFType [([AnyC,AnyC],AnyC)]) ,("=:=",AFType [([AnyC,AnyC],AnyC)]) ,("$",AFType [([AnyC,Any],AnyC)]) ,("$!",AFType [([AnyC,AnyC],AnyC)]) ,("$!!",AFType [([AnyC,AnyC],AnyC)]) ,("$#",AFType [([AnyC,AnyC],AnyC)]) ,("$##",AFType [([AnyC,AnyC],AnyC)]) ,("compare",AFType [([AnyC,AnyC],AnyC)]) ] analyseReqValRule :: ProgInfo [(QName,Int)] -> [(QName,AFType)] -> [Int] -> Expr -> AFType analyseReqValRule consinfo calledfuncs args rhs = let initenv = extendEnv [] args envtypes = reqValExp initenv rhs AnyC rtypes = map snd envtypes in -- If some result is `AnyC` and another result is a constructor, then -- analyze again for all constructors as required results -- in order to get more precise information. if any (==AnyC) rtypes && any isConsValue rtypes then let somecons = maybe (error "Internal error") (\ (Cons c) -> c) (find isConsValue rtypes) othercons = maybe [] (map fst) (lookupProgInfo somecons consinfo) consenvtypes = foldr lubEnvTypes [] (map (\rt -> reqValExp initenv rhs rt) (map Cons (somecons:othercons))) in AFType (map (\ (env,rtype) -> (map snd env, rtype)) (lubAnyEnvTypes (if length othercons >= maxReqValues then envtypes else consenvtypes))) else AFType (map (\ (env,rtype) -> (map snd env, rtype)) (lubAnyEnvTypes envtypes)) where reqValExp env exp reqtype = case exp of Var v -> [(updateVarInEnv env v reqtype, reqtype)] Lit _ -> [(env, AnyC)] -- too many literal constants... Comb ConsCall c _ -> [(env, Cons c)] -- analysis of arguments superfluous Comb FuncCall qf funargs -> if qf==(prelude,"?") && length funargs == 2 then -- use intended definition of Prelude.? for more precise analysis: reqValExp env (Or (head funargs) (funargs!!1)) reqtype else maybe [(env, AnyC)] (\ftype -> case ftype of EmptyFunc -> [(env, Empty)] -- no information available AFType ftypes -> let matchingtypes = filter (compatibleType reqtype . snd) ftypes -- for all matching types analyze arguments -- where a constructor value is required: matchingenvs = map (\ (ts,rt) -> let argenvs = concatMap (envForConsArg env) (zip ts funargs) in (foldr joinEnv env argenvs, rt)) matchingtypes in if null matchingtypes then [(env, Empty)] else matchingenvs ) (lookup qf calledfuncs) Comb _ _ _ -> [(env, AnyC)] -- no reasonable info for partial applications Or e1 e2 -> lubEnvTypes (reqValExp env e1 reqtype) (reqValExp env e2 reqtype) Case _ e branches -> let -- filter non-failing branches: nfbranches = filter (\ (Branch _ be) -> be /= Comb FuncCall (prelude,"failed") []) branches reqenvs = filter (not . null) (map (envForBranch env reqtype e) nfbranches) in if null reqenvs then [(env, Empty)] else foldr1 lubEnvTypes reqenvs Free vars e -> map (dropEnv (length vars)) (reqValExp (extendEnv env vars) e reqtype) Let bindings e -> -- bindings are not analyzed since we don't know whether they are used: map (dropEnv (length bindings)) (reqValExp (extendEnv env (map fst bindings)) e reqtype) Typed e _ -> reqValExp env e reqtype -- compute an expression environment for a function argument if this -- argument is required to be a constructor: envForConsArg env (reqtype,exp) = case reqtype of AnyC -> [foldr1 lubEnv (map fst (reqValExp env exp AnyC))] Cons qc -> [foldr1 lubEnv (map fst (reqValExp env exp (Cons qc)))] _ -> [] -- compute an expression environment and required type for an applied branch envForBranch env reqtype exp (Branch pat bexp) = filter (\ (_,rt) -> compatibleType rt reqtype) branchtypes where branchtypes = case pat of LPattern _ -> reqValExp env bexp reqtype Pattern qc pvars -> let caseenvs = map fst (reqValExp env exp (Cons qc)) branchenvs = foldr lubEnvTypes [] (map (\caseenv -> reqValExp (extendEnv caseenv pvars) bexp reqtype) caseenvs) in map (dropEnv (length pvars)) branchenvs --- "lub" two environment lists. All environment lists are ordered --- by the result type. lubEnvTypes :: [(AEnv,AType)] -> [(AEnv,AType)] -> [(AEnv,AType)] lubEnvTypes [] ets2 = ets2 lubEnvTypes ets1@(_:_) [] = ets1 lubEnvTypes ((env1,t1):ets1) ((env2,t2):ets2) | t1==Empty = lubEnvTypes ets1 ((env2,t2):ets2) -- ignore "empty" infos | t2==Empty = lubEnvTypes ((env1,t1):ets1) ets2 | t1==t2 = (lubEnv env1 env2, t1) : lubEnvTypes ets1 ets2 | t1 [(AEnv,AType)] lubAnyEnvTypes envtypes = if null envtypes || snd (head envtypes) /= AnyC then envtypes else foldr1 lubEnvType envtypes : tail envtypes lubEnvType :: (AEnv,AType) -> (AEnv,AType) -> (AEnv,AType) lubEnvType (env1,t1) (env2,t2) = (lubEnv env1 env2, lubAType t1 t2) lubEnv :: AEnv -> AEnv -> AEnv lubEnv [] _ = [] lubEnv (_:_) [] = [] lubEnv ((i1,v1):env1) env2@(_:_) = maybe (lubEnv env1 env2) (\v2 -> (i1, lubAType v1 v2) : lubEnv env1 env2) (lookup i1 env2) joinEnv :: AEnv -> AEnv -> AEnv joinEnv [] _ = [] joinEnv (_:_) [] = [] joinEnv ((i1,v1):env1) env2@(_:_) = maybe (joinEnv env1 env2) (\v2 -> (i1, joinAType v1 v2) : joinEnv env1 env2) (lookup i1 env2) -- Name of the standard prelude: prelude :: String prelude = "Prelude" curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/RequiredValues.curry000066400000000000000000000317451377556325500274670ustar00rootroot00000000000000----------------------------------------------------------------------------- --- Required value analysis for Curry programs --- --- This analysis checks for each function in a Curry program whether --- the arguments of a function must have a particular shape in order to --- compute some value of this function. --- For instance, the negation operation `not` requires the argument --- value `False` in order to compute the result `True` and it requires --- the argument `True` to compute the result `False`. --- --- @author Michael Hanus --- @version April 2018 ----------------------------------------------------------------------------- module Analysis.RequiredValues (AType(..), showAType, AFType(..), showAFType, lubAType, reqValueAnalysis) where import Analysis.Types import Analysis.ProgInfo import Analysis.TotallyDefined(siblingCons) import FlatCurry.Types import FlatCurry.Goodies import Data.List hiding (union,intersect) ------------------------------------------------------------------------------ -- Our abstract (non-standard) type domain. -- `Any` represents any expression, -- `AnyC` represents any value (i.e., constructor-rooted term), -- `Cons cs` a value rooted by some of the constructor `cs`, and data AType = Cons [QName] | AnyC | Any deriving (Eq, Ord, Show, Read) --- Abstract representation of no possible value. empty :: AType empty = Cons [] --- Is some abstract type a constructor? isConsValue :: AType -> Bool isConsValue av = case av of Cons cs -> not (null cs) _ -> False --- Least upper bound of abstract values. lubAType :: AType -> AType -> AType lubAType Any _ = Any lubAType AnyC Any = Any lubAType AnyC AnyC = AnyC lubAType AnyC (Cons _) = AnyC lubAType (Cons _) Any = Any lubAType (Cons _) AnyC = AnyC lubAType (Cons c) (Cons d) = Cons (union c d) -- replace previous rule by following rule in order to use singleton sets: --lubAType (Cons c) (Cons d) = if c==d then Cons c else AnyC --- Join two abstract values. The result is `Empty` if they are not compatible. joinAType :: AType -> AType -> AType joinAType Any av = av joinAType AnyC Any = AnyC joinAType AnyC AnyC = AnyC joinAType AnyC (Cons c) = Cons c joinAType (Cons c) Any = Cons c joinAType (Cons c) AnyC = Cons c joinAType (Cons c) (Cons d) = Cons (intersect c d) -- replace previous rule by following rule in order to use singleton sets: --joinAType (Cons c) (Cons d) = if c==d then Cons c else Cons [] --- Are two abstract types compatible, i.e., describe common values? compatibleType :: AType -> AType -> Bool compatibleType t1 t2 = joinAType t1 t2 /= empty -- Shows an abstract value. showAType :: AOutFormat -> AType -> String showAType _ Any = "any" showAType _ AnyC = "cons" showAType _ (Cons cs) = "{" ++ intercalate "," (map snd cs) ++ "}" --- The abstract type of a function. --- It is either `EmptyFunc`, i.e., contains no information about --- the possible result of the function, --- or a list of possible argument/result type pairs. data AFType = EmptyFunc | AFType [([AType],AType)] deriving (Eq, Ord, Show, Read) -- Shows an abstract value. showAFType :: AOutFormat -> AFType -> String showAFType _ EmptyFunc = "EmptyFunc" showAFType aof (AFType fts) = intercalate " | " (map showFType fts) where showFType (targs,tres) = "(" ++ intercalate "," (map (showAType aof) targs) ++ " -> " ++ showAType aof tres ++ ")" showCalledFuncs :: [(QName,AFType)] -> String showCalledFuncs = intercalate "|" . map (\ ((_,f),at) -> f++"::"++showAFType _ at) ------------------------------------------------------------------------------ --- An abstract environments used in the analysis of a function associates --- to each variable (index) an abstract type. type AEnv = [(Int,AType)] --- Extend an abstract environment with variables of any type: extendEnv :: AEnv -> [Int] -> AEnv extendEnv env vars = zip vars (repeat Any) ++ env --- Update a variable in an abstract environment: updateVarInEnv :: AEnv -> Int -> AType -> AEnv updateVarInEnv [] v _ = error ("Variable "++show v++" not found in environment") updateVarInEnv ((i,ov):env) v nv = if i==v then (i,nv) : env else (i,ov) : updateVarInEnv env v nv --- Drop the first n elements from the environment component --- of an environment/type pair: dropEnv :: Int -> ([a],b) -> ([a],b) dropEnv n (env,rtype) = (drop n env, rtype) -- Sorts a list of environment/type pairs by the type. sortEnvTypes :: [(AEnv,AType)] -> [(AEnv,AType)] sortEnvTypes = sortBy (\ (e1,t1) (e2,t2) -> (t1,e1) <= (t2,e2)) ------------------------------------------------------------------------------ --- The maximum number of different constructors considered for the --- required value analysis. If a type has more constructors than --- specified here, it will not be analyzed for individual required --- constructor values. maxReqValues :: Int maxReqValues = 3 --- Required value analysis. reqValueAnalysis :: Analysis AFType reqValueAnalysis = combinedDependencyFuncAnalysis "RequiredValues" siblingCons EmptyFunc analyseReqVal analyseReqVal :: ProgInfo [(QName,Int)] -> FuncDecl -> [(QName,AFType)] -> AFType analyseReqVal consinfo (Func (m,f) arity _ _ rule) calledfuncs | m==prelude = maybe (anaresult rule) id (lookup f preludeFuncs) | otherwise = --trace ("Analyze "++f++"\n"++showCalledFuncs calledfuncs++ -- "\nRESULT: "++showAFType _ (anaresult rule)) $ anaresult rule where anaresult (External _) = AFType [(take arity (repeat Any),AnyC)] anaresult (Rule args rhs) = analyseReqValRule consinfo calledfuncs args rhs -- add special results for prelude functions here: preludeFuncs = [("failed",AFType [([],empty)]) ,("==",AFType [([AnyC,AnyC],AnyC)]) ,("=:=",AFType [([AnyC,AnyC],AnyC)]) ,("$",AFType [([AnyC,Any],AnyC)]) ,("$!",AFType [([AnyC,AnyC],AnyC)]) ,("$!!",AFType [([AnyC,AnyC],AnyC)]) ,("$#",AFType [([AnyC,AnyC],AnyC)]) ,("$##",AFType [([AnyC,AnyC],AnyC)]) ,("compare",AFType [([AnyC,AnyC],AnyC)]) ] analyseReqValRule :: ProgInfo [(QName,Int)] -> [(QName,AFType)] -> [Int] -> Expr -> AFType analyseReqValRule consinfo calledfuncs args rhs = let initenv = extendEnv [] args envtypes = reqValExp initenv rhs AnyC rtypes = map snd envtypes in -- If some result is `AnyC` and another result is a constructor, then -- analyze again for all constructors as required results -- in order to get more precise information. if any (==AnyC) rtypes && any isConsValue rtypes then let somecons = maybe (error "Internal error") (\ (Cons (c:_)) -> c) (find isConsValue rtypes) othercons = maybe [] (map fst) (lookupProgInfo somecons consinfo) consenvtypes = foldr lubEnvTypes [] (map (\rt -> reqValExp initenv rhs rt) (map (\c -> Cons [c]) (somecons:othercons))) in AFType (map (\ (env,rtype) -> (map snd env, rtype)) (lubAnyEnvTypes (if length othercons >= maxReqValues then envtypes else consenvtypes))) else AFType (map (\ (env,rtype) -> (map snd env, rtype)) (lubAnyEnvTypes envtypes)) where reqValExp env exp reqtype = case exp of Var v -> [(updateVarInEnv env v reqtype, reqtype)] Lit _ -> [(env, AnyC)] -- too many literal constants... Comb ConsCall c _ -> [(env, Cons [c])] -- analysis of arguments superfluous Comb FuncCall qf funargs -> if qf==(prelude,"?") && length funargs == 2 then -- use intended definition of Prelude.? for more precise analysis: reqValExp env (Or (head funargs) (funargs!!1)) reqtype else maybe [(env, AnyC)] (\ftype -> case ftype of EmptyFunc -> [(env, empty)] -- no information available AFType ftypes -> let matchingtypes = filter (compatibleType reqtype . snd) ftypes -- for all matching types analyze arguments -- where a constructor value is required: matchingenvs = map (\ (ts,rt) -> let argenvs = concatMap (envForConsArg env) (zip ts funargs) in (foldr joinEnv env argenvs, rt)) matchingtypes in if null matchingtypes then [(env, empty)] else matchingenvs ) (lookup qf calledfuncs) Comb _ _ _ -> [(env, AnyC)] -- no reasonable info for partial applications Or e1 e2 -> lubEnvTypes (reqValExp env e1 reqtype) (reqValExp env e2 reqtype) Case _ e branches -> let -- filter non-failing branches: nfbranches = filter (\ (Branch _ be) -> be /= Comb FuncCall (prelude,"failed") []) branches reqenvs = filter (not . null) (map (envForBranch env reqtype e) nfbranches) in if null reqenvs then [(env, empty)] else foldr1 lubEnvTypes reqenvs Free vars e -> map (dropEnv (length vars)) (reqValExp (extendEnv env vars) e reqtype) Let bindings e -> -- bindings are not analyzed since we don't know whether they are used: map (dropEnv (length bindings)) (reqValExp (extendEnv env (map fst bindings)) e reqtype) Typed e _ -> reqValExp env e reqtype -- compute an expression environment for a function argument if this -- argument is required to be a constructor: envForConsArg env (reqtype,exp) = case reqtype of AnyC -> [foldr1 lubEnv (map fst (reqValExp env exp AnyC))] Cons qc -> [foldr1 lubEnv (map fst (reqValExp env exp (Cons qc)))] _ -> [] -- compute an expression environment and required type for an applied branch envForBranch env reqtype exp (Branch pat bexp) = filter (\ (_,rt) -> compatibleType rt reqtype) branchtypes where branchtypes = case pat of LPattern _ -> reqValExp env bexp reqtype Pattern qc pvars -> let caseenvs = map fst (reqValExp env exp (Cons [qc])) branchenvs = foldr lubEnvTypes [] (map (\caseenv -> reqValExp (extendEnv caseenv pvars) bexp reqtype) caseenvs) in map (dropEnv (length pvars)) branchenvs --- "lub" two environment lists. All environment lists are ordered --- by the result type. lubEnvTypes :: [(AEnv,AType)] -> [(AEnv,AType)] -> [(AEnv,AType)] lubEnvTypes [] ets2 = ets2 lubEnvTypes ets1@(_:_) [] = ets1 lubEnvTypes ((env1,t1):ets1) ((env2,t2):ets2) | t1==empty = lubEnvTypes ets1 ((env2,t2):ets2) -- ignore "empty" infos | t2==empty = lubEnvTypes ((env1,t1):ets1) ets2 | t1==t2 = (lubEnv env1 env2, t1) : lubEnvTypes ets1 ets2 | t1 < t2 = (env1,t1) : lubEnvTypes ets1 ((env2,t2):ets2) | otherwise = (env2,t2) : lubEnvTypes ((env1,t1):ets1) ets2 --- "lub" the environments of the more specific types to the AnyC type --- (if present). lubAnyEnvTypes :: [(AEnv,AType)] -> [(AEnv,AType)] lubAnyEnvTypes envtypes = if null envtypes || snd (head envtypes) /= AnyC then envtypes else foldr1 lubEnvType envtypes : tail envtypes lubEnvType :: (AEnv,AType) -> (AEnv,AType) -> (AEnv,AType) lubEnvType (env1,t1) (env2,t2) = (lubEnv env1 env2, lubAType t1 t2) lubEnv :: AEnv -> AEnv -> AEnv lubEnv [] _ = [] lubEnv (_:_) [] = [] lubEnv ((i1,v1):env1) env2@(_:_) = maybe (lubEnv env1 env2) (\v2 -> (i1, lubAType v1 v2) : lubEnv env1 env2) (lookup i1 env2) joinEnv :: AEnv -> AEnv -> AEnv joinEnv [] _ = [] joinEnv (_:_) [] = [] joinEnv ((i1,v1):env1) env2@(_:_) = maybe (joinEnv env1 env2) (\v2 -> (i1, joinAType v1 v2) : joinEnv env1 env2) (lookup i1 env2) -- Name of the standard prelude: prelude :: String prelude = "Prelude" ------------------------------------------------------------------------------ -- Auxiliaries: -- Union on sorted lists: union :: Ord a => [a] -> [a] -> [a] union [] ys = ys union xs@(_:_) [] = xs union (x:xs) (y:ys) | x==y = x : union xs ys | x [a] -> [a] -> [a] intersect [] _ = [] intersect (_:_) [] = [] intersect (x:xs) (y:ys) | x==y = x : intersect xs ys | x ResiduationInfo -> ResiduationInfo lubNRI MayResiduate _ = MayResiduate lubNRI NoResInfo nri = nri lubNRI (NoResiduateIf _ ) MayResiduate = MayResiduate lubNRI (NoResiduateIf xs) NoResInfo = NoResiduateIf xs lubNRI (NoResiduateIf xs) (NoResiduateIf ys) = NoResiduateIf (unionS xs ys) -- union on sorted lists: unionS :: Ord a => [a] -> [a] -> [a] unionS [] ys = ys unionS (x:xs) [] = x:xs unionS (x:xs) (y:ys) | x==y = x : unionS xs ys | xy = y : unionS (x:xs) ys -- Show non-residuation information as a string. showResInfo :: AOutFormat -> ResiduationInfo -> String showResInfo AText MayResiduate = "may residuate or has non-ground result" showResInfo ANote MayResiduate = "residuate" showResInfo AText (NoResiduateIf xs) = "does not residuate" ++ case xs of [] -> "" [x] -> " if argument " ++ show x ++ " is ground" _ -> " if arguments " ++ intercalate "," (map show xs) ++ " are ground" showResInfo ANote (NoResiduateIf xs) = "non-residuating" ++ if null xs then "" else " if " ++ intercalate "," (map show xs) showResInfo AText NoResInfo = "unknown residuation behavior" showResInfo ANote NoResInfo = "???" --- Non-residuation analysis. residuationAnalysis :: Analysis ResiduationInfo residuationAnalysis = dependencyFuncAnalysis "Residuation" NoResInfo nrFunc -- We define the demanded arguments of some primitive prelude operations. -- Otherwise, we analyse the right-hand sides of the rule. nrFunc :: FuncDecl -> [(QName,ResiduationInfo)] -> ResiduationInfo nrFunc (Func fn ar _ _ rule) calledFuncs = nrFuncRule fn ar calledFuncs rule nrFuncRule :: QName -> Int -> [(QName,ResiduationInfo)] -> Rule -> ResiduationInfo -- We assume that all external operations do not residuate if all -- arguments are non-residuating and ground. -- This is true for all known standard external operations. -- If this does not hold for some unusual operation, -- it must be specified here. nrFuncRule _ farity _ (External _) = NoResiduateIf [1 .. farity] nrFuncRule _ _ calledFuncs (Rule args rhs) = nrExp (map (\i -> (i, NoResiduateIf [i])) args) rhs where -- Analyze residuation behavior of an expression. -- The first argument maps variables to their non-residuating conditions -- if these variables are used in an expression. nrExp _ (Lit _) = NoResiduateIf [] nrExp amap (Var i) = maybe MayResiduate id (lookup i amap) nrExp amap (Comb ct g es) = case ct of FuncCall -> maybe NoResInfo checkNonResArgs (lookup g calledFuncs) FuncPartCall _ -> maybe NoResInfo checkNonResPartArgs (lookup g calledFuncs) _ -> if null es then NoResiduateIf [] else foldr1 lubNRI (map (nrExp amap) es) where checkNonResArgs NoResInfo = NoResInfo checkNonResArgs MayResiduate = MayResiduate checkNonResArgs (NoResiduateIf xs) = if null xs then NoResiduateIf [] else foldr1 lubNRI (map (\i -> nrExp amap (es!!(i-1))) xs) checkNonResPartArgs NoResInfo = NoResInfo checkNonResPartArgs MayResiduate = MayResiduate checkNonResPartArgs (NoResiduateIf xs) = let pxs = filter (<= length es) xs in if null pxs then NoResiduateIf [] else foldr1 lubNRI (map (\i -> nrExp amap (es!!(i-1))) pxs) nrExp amap (Case _ e bs) = foldr lubNRI nrcexp (map nrBranch bs) where nrcexp = nrExp amap e -- non-res. condition of discriminating expression nrBranch (Branch (LPattern _) be) = nrExp amap be nrBranch (Branch (Pattern _ xs) be) = nrExp (map (\x -> (x,nrcexp)) xs ++ amap) be nrExp amap (Free _ e) = nrExp amap e -- could be improved by sorting bindings by their variable dependencies -- (which seems already done by the front-end) nrExp amap (Let bindings e) = -- initialize all bound variables with `NoResInfo` which is meaningful -- for recursive bindings: let initamap = map (\ (v,_) -> (v,NoResInfo)) bindings ++ amap in nrExp (addBindings initamap bindings) e where addBindings amp [] = amp addBindings amp ((v,be):bs) = addBindings ((v, nrExp amp be) : amp) bs nrExp amap (Or e1 e2) = lubNRI (nrExp amap e1) (nrExp amap e2) nrExp amap (Typed e _) = nrExp amap e prelude :: String prelude = "Prelude" ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/RightLinearity.curry000066400000000000000000000066521377556325500274640ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Right-linearity analysis: --- check whether functions are defined by right-linear rules. --- --- @author Michael Hanus --- @version April 2013 ------------------------------------------------------------------------------ module Analysis.RightLinearity (rlinAnalysis,hasRightLinearRules,linearExpr,showRightLinear) where import Analysis.Types import FlatCurry.Types import Data.Maybe import Data.List ------------------------------------------------------------------------------ --- The right-linearity analysis is a global function dependency analysis. --- It assigns to a function a flag which is True if this function --- is right-linear, i.e., defined by right-linear rules and depend only on --- functions defined by right-linear rules. rlinAnalysis :: Analysis Bool rlinAnalysis = dependencyFuncAnalysis "RightLinear" True rlFunc --- An operation is right-linear if it is defined by right-linear rules --- and depends only on right-linear operations. rlFunc :: FuncDecl -> [(QName,Bool)] -> Bool rlFunc func calledFuncs = hasRightLinearRules func && all snd calledFuncs -- Show right-linearity information as a string. showRightLinear :: AOutFormat -> Bool -> String showRightLinear _ True = "right-linear" showRightLinear AText False = "not defined by right-linear rules" showRightLinear ANote False = "" ------------------------------------------------------------------------------ -- The right-linearity analysis can also be applied to individual functions. -- It returns True for a function if it is defined by right-linear rules. hasRightLinearRules :: FuncDecl -> Bool hasRightLinearRules (Func _ _ _ _ rule) = isRightLinearRule rule isRightLinearRule :: Rule -> Bool isRightLinearRule (Rule _ e) = linearExpr e isRightLinearRule (External _) = True -------------------------------------------------------------------------- -- Check an expression for linearity: linearExpr :: Expr -> Bool linearExpr e = maybe False (const True) (linearVariables e) -- Return list of variables in an expression, if it is linear, -- otherwise: Nothing linearVariables :: Expr -> Maybe [Int] linearVariables (Var i) = Just [i] linearVariables (Lit _) = Just [] linearVariables (Comb _ f es) | f==("Prelude","?") && length es == 2 -- treat "?" as Or: = linearVariables (Or (head es) (head (tail es))) | otherwise = mapM linearVariables es >>= \esvars -> let vars = concat esvars in if nub vars == vars then Just vars else Nothing linearVariables (Free vs e) = linearVariables e >>= \evars -> Just (evars \\ vs) linearVariables (Let bs e) = mapM linearVariables (map snd bs) >>= \bsvars -> linearVariables e >>= \evars -> let vars = concat (evars : bsvars) in if nub vars == vars then Just (vars \\ (map fst bs)) else Nothing linearVariables (Or e1 e2) = linearVariables e1 >>= \e1vars -> linearVariables e2 >>= \e2vars -> Just (union e1vars e2vars) linearVariables (Case _ e bs) = linearVariables e >>= \evars -> mapM linearVariables (map (\ (Branch _ be) -> be) bs) >>= \bsvars -> let vars = foldr union [] (map (\ (branch,bsv) -> bsv \\ patternVars branch) (zip bs bsvars)) ++ evars in if nub vars == vars then Just vars else Nothing where patternVars (Branch (Pattern _ vs) _) = vs patternVars (Branch (LPattern _) _) = [] linearVariables (Typed e _) = linearVariables e curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/RootReplaced.curry000066400000000000000000000107761377556325500271130ustar00rootroot00000000000000------------------------------------------------------------------------------ --- RootReplaced analysis: --- This analysis returns for each function f all functions to which this can --- be replaced at the root. For instance, if there are the definitions: --- --- f x = g x --- g x = h x --- h x = k x : [] --- --- then the root replacements of f are [g,h]. --- --- This analysis could be useful to detect simple loops, e.g., if --- a function is in its root replacement. This is the purpose --- of the analysis `RootCyclic` which assigns `True` to some --- operation if this operation might cause a cyclic root replacement. --- --- @author Michael Hanus --- @version January 2017 ------------------------------------------------------------------------------ module Analysis.RootReplaced ( rootReplAnalysis, showRootRepl , rootCyclicAnalysis, showRootCyclic ) where import Analysis.Types import Analysis.ProgInfo import FlatCurry.Types import Data.List ------------------------------------------------------------------------------ --- Data type to represent root replacement information. --- Basically, it is the set (represented as a sorted list) of --- all function names to which a function can be replaced (directly --- or by several steps) at the root --- together with a list of arguments (which are numbered from 0) --- which might be projected into the result. --- The latter is necessary to compute the root replacement --- information for definitions like `look = id loop`. type RootReplaced = ([QName],[Int]) -- Show root-replacement information as a string. showRootRepl :: AOutFormat -> RootReplaced -> String showRootRepl AText ([],_) = "no root replacements" showRootRepl ANote ([],_) = "" showRootRepl AText (xs@(_:_),_) = "root replacements: " ++ intercalate "," (map (\ (mn,fn) -> mn++"."++fn) xs) showRootRepl ANote (xs@(_:_),_) = "[" ++ intercalate "," (map snd xs) ++ "]" --- Root replacement analysis. rootReplAnalysis :: Analysis RootReplaced rootReplAnalysis = dependencyFuncAnalysis "RootReplaced" ([],[]) rrFunc rrFunc :: FuncDecl -> [(QName,RootReplaced)] -> RootReplaced rrFunc (Func _ _ _ _ rule) calledFuncs = rrFuncRule calledFuncs rule rrFuncRule :: [(QName,RootReplaced)] -> Rule -> RootReplaced rrFuncRule _ (External _) = ([],[]) -- nothing known about external functions rrFuncRule calledFuncs (Rule args rhs) = rrOfExp rhs where rrOfExp exp = case exp of Var v -> maybe ([],[]) (\i -> ([],[i])) (elemIndex v args) Lit _ -> ([],[]) Comb ct g gargs -> if ct == FuncCall then maybe (error $ "Abstract value of " ++ show g ++ " not found!") (\ (grrs,gps) -> foldr lub (if g `elem` grrs then grrs else insertBy (<=) g grrs, []) (map (\pi -> rrOfExp (gargs!!pi)) gps)) (lookup g calledFuncs) else ([],[]) Typed e _ -> rrOfExp e Free _ e -> rrOfExp e Let _ e -> rrOfExp e Or e1 e2 -> lub (rrOfExp e1) (rrOfExp e2) Case _ e bs -> foldr lub (rrOfExp e) (map (\ (Branch _ be) -> rrOfExp be) bs) lub (rr1,p1) (rr2,p2) = (sort (union rr1 rr2), sort (union p1 p2)) ------------------------------------------------------------------------------ -- Show root-cyclic information as a string. showRootCyclic :: AOutFormat -> Bool -> String showRootCyclic AText False = "no cycles at the root" showRootCyclic ANote False = "" showRootCyclic AText True = "possible cyclic root replacement" showRootCyclic ANote True = "root-cyclic" --- Root cyclic analysis. rootCyclicAnalysis :: Analysis Bool rootCyclicAnalysis = combinedSimpleFuncAnalysis "RootCyclic" rootReplAnalysis rcFunc rcFunc :: ProgInfo RootReplaced -> FuncDecl -> Bool -- we assume that external functions are not root cyclic: rcFunc _ (Func _ _ _ _ (External _)) = False -- otherwise we check whether the operation is in its set of root replacements: rcFunc rrinfo (Func qf _ _ _ (Rule _ _)) = maybe True -- no information, but this case should not occur (\rrfuncs -> qf `elem` (fst rrfuncs) -- direct cycle -- or cycle in some root-replacement: || any (\rrf -> maybe True (\fs -> rrf `elem` (fst fs)) (lookupProgInfo rrf rrinfo)) (fst rrfuncs)) (lookupProgInfo qf rrinfo) ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/SensibleTypes.curry000066400000000000000000000063241377556325500273130ustar00rootroot00000000000000------------------------------------------------------------------------ --- A type is sensible if there exists at least one value of this type. --- This module contains an analysis which associates to each type --- constructor the following information: --- * sensible, i.e., there is always some value of this type --- * parametric sensible, i.e., it is sensible of all type arguments --- are instantiated with sensible types --- * not sensible, i.e., maybe not sensible ------------------------------------------------------------------------ module Analysis.SensibleTypes ( Sensible(..), showSensible, sensibleType ) where import Analysis.Types import Analysis.ProgInfo import FlatCurry.Types import FlatCurry.Goodies import Data.Maybe --- Datatype to represent sensible type information. data Sensible = NotSensible | PSensible | Sensible deriving (Show, Read, Eq) -- Show higher-order information as a string. showSensible :: AOutFormat -> Sensible -> String showSensible _ Sensible = "sensible" showSensible _ PSensible = "parametric sensible" showSensible _ NotSensible = "not sensible" lubSens :: Sensible -> Sensible -> Sensible lubSens Sensible _ = Sensible lubSens PSensible Sensible = Sensible lubSens PSensible PSensible = PSensible lubSens PSensible NotSensible = PSensible lubSens NotSensible x = x ------------------------------------------------------------------------ -- Analysis of sensible types sensibleType :: Analysis Sensible sensibleType = dependencyTypeAnalysis "SensibleType" NotSensible sensOfType -- predefined sensible data types predefinedSensibles :: [QName] predefinedSensibles = [pre "Int", pre "Float", pre "Char", pre "IO"] where pre tc = ("Prelude",tc) sensOfType :: TypeDecl -> [(QName,Sensible)] -> Sensible sensOfType (TypeSyn _ _ _ typeExpr) usedtypes = sensOfTypeExpr usedtypes typeExpr sensOfType (TypeNew _ _ _ (NewCons _ _ typeExpr)) usedtypes = sensOfTypeExpr usedtypes typeExpr sensOfType (Type tc _ _ conDecls) usedtypes | tc `elem` predefinedSensibles = Sensible | otherwise = foldr lubSens NotSensible (map sensOfConsDecl conDecls) where sensOfConsDecl (Cons _ _ _ typeExprs) | all (== Sensible) senstargs = Sensible | all (/= NotSensible) senstargs = PSensible | otherwise = NotSensible where senstargs = map (sensOfTypeExpr usedtypes) typeExprs -- Compute the sensibility of a type expression which depends on the -- information about type cosntructors. sensOfTypeExpr :: [(QName,Sensible)] -> TypeExpr -> Sensible sensOfTypeExpr _ (TVar _) = PSensible sensOfTypeExpr _ (FuncType _ _) = NotSensible -- we do not know which functions -- of some type exists... sensOfTypeExpr usedtypes (TCons tc typeExprs) | senstc == Sensible || (senstc == PSensible && all (==Sensible) senstargs) = Sensible | senstc == PSensible && all (/=NotSensible) senstargs = PSensible | otherwise = NotSensible where senstc = maybe NotSensible id (lookup tc usedtypes) senstargs = map (sensOfTypeExpr usedtypes) typeExprs sensOfTypeExpr usedtypes (ForallType _ texp) = sensOfTypeExpr usedtypes texp ----------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/SolutionCompleteness.curry000066400000000000000000000045351377556325500307220ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Analysis for solution completeness: --- check whether functions are solution complete, i.e., calls only --- non-rigid functions --- --- @author Michael Hanus --- @version April 2013 ------------------------------------------------------------------------------ module Analysis.SolutionCompleteness(solcompAnalysis,showSolComplete) where import Analysis.Types import FlatCurry.Types import Data.List ------------------------------------------------------------------------------ --- The completeness analysis is a global function dependency analysis. --- It assigns to a function a flag which is True if this function --- is operationally complete, i.e., does not call (explicitly or implicitly) --- a rigid function. solcompAnalysis :: Analysis Bool solcompAnalysis = dependencyFuncAnalysis "SolComplete" True scFunc --- An operation is solution complete if it is defined with flexible --- rules and depends only on solution complete operations. scFunc :: FuncDecl -> [(QName,Bool)] -> Bool scFunc func calledFuncs = isFlexDefined func && all snd calledFuncs -- (isFlexDefined fundecl): -- Is a function defined by a flexible rule? isFlexDefined :: FuncDecl -> Bool isFlexDefined (Func _ _ _ _ (Rule _ e)) = isFlexExpr e isFlexDefined (Func f _ _ _ (External _)) = f `elem` map pre ["=:=","success","&","&>","return"] -- Checks whether an expression is flexible, i.e., can only suspend -- because of calls to other possibly rigid functions. isFlexExpr :: Expr -> Bool isFlexExpr (Var _) = True isFlexExpr (Lit _) = True isFlexExpr (Comb _ f args) = f/=(pre "apply") -- apply suspends if arg 1 is unbound && f/=(pre "commit") && all isFlexExpr args isFlexExpr (Free _ e) = isFlexExpr e isFlexExpr (Let bs e) = all isFlexExpr (map snd bs) && isFlexExpr e isFlexExpr (Or e1 e2) = isFlexExpr e1 && isFlexExpr e2 isFlexExpr (Case ctype e bs) = ctype==Flex && all isFlexExpr (e : map (\(Branch _ be)->be) bs) isFlexExpr (Typed e _) = isFlexExpr e -- Show solution completeness information as a string. showSolComplete :: AOutFormat -> Bool -> String showSolComplete _ True = "solution complete" showSolComplete _ False = "maybe suspend" pre :: String -> QName pre n = ("Prelude",n) -- end of SolutionCompleteness curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/Termination.curry000066400000000000000000000204651377556325500270150ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Termination analysis: --- checks whether an operation is terminating, i.e., --- whether all evaluations on ground argument terms are finite. --- The method used here checks whether the arguments in all recursive --- calls of an operation are smaller than the arguments passed to --- the operation. --- --- @author Michael Hanus --- @version February 2017 ------------------------------------------------------------------------------ module Analysis.Termination ( terminationAnalysis, showTermination , productivityAnalysis, showProductivity, Productivity(..) ) where import Analysis.Types import Analysis.ProgInfo import Analysis.RootReplaced (rootCyclicAnalysis) import Data.Char (isDigit) import Data.List import FlatCurry.Types import FlatCurry.Goodies import Data.SCC (scc) ------------------------------------------------------------------------------ -- The termination analysis is a global function dependency analysis. -- It assigns to a FlatCurry function definition a flag which is True -- if this operation is terminating, i.e., whether all evaluations terminationAnalysis :: Analysis Bool terminationAnalysis = dependencyFuncAnalysis "Terminating" False isTerminating -- Show termination information as a string. showTermination :: AOutFormat -> Bool -> String showTermination AText True = "terminating" showTermination ANote True = "" showTermination AText False = "possibly non-terminating" showTermination ANote False = "maybe not term." -- An operation is functionally defined if its definition is not -- non-deterministic (no overlapping rules, no extra variables) and -- it depends only on functionally defined operations. isTerminating :: FuncDecl -> [(QName,Bool)] -> Bool isTerminating (Func qfunc _ _ _ rule) calledFuncs = hasTermRule rule where hasTermRule (Rule args e) = hasTermExp (map (\a -> (a,[])) args) e -- we assume that all externally defined operations are terminating: hasTermRule (External _) = True hasTermExp _ (Var _) = True hasTermExp _ (Lit _) = True hasTermExp _ (Free _ _) = False -- could be improved if the domain is finite hasTermExp args (Let bs e) = -- compute strongly connected components of local let declarationss -- in order to check for recursive lets let sccs = scc ((:[]) . fst) (allVars . snd) bs in if any (\scc -> any (`elem` concatMap allVars (map snd scc)) (map fst scc)) sccs then False -- non-terminating due to recursive let else all (hasTermExp args) (e : map snd bs) hasTermExp args (Or e1 e2) = hasTermExp args e1 && hasTermExp args e2 hasTermExp args (Case _ e bs) = hasTermExp args e && all (\ (Branch pt be) -> hasTermExp (addSmallerArgs args e pt) be) bs hasTermExp args (Typed e _) = hasTermExp args e hasTermExp args (Comb ct qf es) = case ct of ConsCall -> all (hasTermExp args) es ConsPartCall _ -> all (hasTermExp args) es _ -> (if qf == qfunc -- is this a recursive call? then any isSmallerArg (zip args es) else maybe False id (lookup qf calledFuncs)) && all (hasTermExp args) es isSmallerArg ((_,sargs),exp) = case exp of Var v -> v `elem` sargs _ -> False -- compute smaller args w.r.t. a given discriminating expression and -- branch pattern addSmallerArgs :: [(Int, [Int])] -> Expr -> Pattern -> [(Int, [Int])] addSmallerArgs args de pat = case de of Var v -> maybe args (\argpos -> let (av,vs) = args!!argpos in replace (av, varsOf pat ++ vs) argpos args) (findIndex (isInArg v) args) _ -> args -- other expression, no definite smaller expressions where varsOf (LPattern _) = [] varsOf (Pattern _ pargs) = pargs isInArg v (argv,svs) = v==argv || v `elem` svs ------------------------------------------------------------------------------ -- The productivity analysis is a global function dependency analysis -- which depends on the termination analysis. -- An operation is considered as being productive if it cannot -- perform an infinite number of steps without producing -- outermost constructors. -- It assigns to a FlatCurry function definition an abstract value -- indicating whether the function is looping or productive. --- Data type to represent productivity status of an operation. data Productivity = NoInfo | Terminating -- definitely terminating operation | DCalls [QName] -- possible direct (top-level) calls to operations that may -- not terminate, which corresponds to being productive | Looping -- possibly looping deriving (Eq, Ord, Show, Read) productivityAnalysis :: Analysis Productivity productivityAnalysis = combinedDependencyFuncAnalysis "Productive" terminationAnalysis NoInfo isProductive -- Show productivity information as a string. showProductivity :: AOutFormat -> Productivity -> String showProductivity _ NoInfo = "no info" showProductivity _ Terminating = "terminating" showProductivity _ (DCalls qfs) = "productive / calls: " ++ "[" ++ intercalate ", " (map snd qfs) ++ "]" showProductivity _ Looping = "possibly looping" lubProd :: Productivity -> Productivity -> Productivity lubProd Looping _ = Looping lubProd (DCalls _ ) Looping = Looping lubProd (DCalls xs) (DCalls ys) = DCalls (sort (union xs ys)) lubProd (DCalls xs) Terminating = DCalls xs lubProd (DCalls xs) NoInfo = DCalls xs lubProd Terminating p = if p==NoInfo then Terminating else p lubProd NoInfo p = p -- An operation is productive if its recursive calls are below -- a constructor (except for calls to terminating operations so that -- this property is also checked). isProductive :: ProgInfo Bool -> FuncDecl -> [(QName,Productivity)] -> Productivity isProductive terminfo (Func qf _ _ _ rule) calledFuncs = hasProdRule rule where -- we assume that all externally defined operations are terminating: hasProdRule (External _) = Terminating hasProdRule (Rule _ e) = case hasProdExp False e of DCalls fs -> if qf `elem` fs then Looping else DCalls fs prodinfo -> prodinfo -- first argument: True if we are below a constructor hasProdExp _ (Var _) = Terminating hasProdExp _ (Lit _) = Terminating hasProdExp bc (Free _ e) = -- could be improved for finite domains: lubProd (DCalls []) (hasProdExp bc e) hasProdExp bc (Let bs e) = -- compute strongly connected components of local let declarationss -- in order to check for recursive lets let sccs = scc ((:[]) . fst) (allVars . snd) bs in if any (\scc -> any (`elem` concatMap allVars (map snd scc)) (map fst scc)) sccs then Looping -- improve: check for variable occs under constructors else foldr lubProd (hasProdExp bc e) (map (\ (_,be) -> hasProdExp bc be) bs) hasProdExp bc (Or e1 e2) = lubProd (hasProdExp bc e1) (hasProdExp bc e2) hasProdExp bc (Case _ e bs) = foldr lubProd (hasProdExp bc e) (map (\ (Branch _ be) -> hasProdExp bc be) bs) hasProdExp bc (Typed e _) = hasProdExp bc e hasProdExp bc (Comb ct qg es) = case ct of ConsCall -> cprodargs ConsPartCall _ -> cprodargs FuncCall -> if qg == ("Prelude","?") then fprodargs -- equivalent to Or else funCallInfo FuncPartCall _ -> funCallInfo where cprodargs = foldr lubProd NoInfo (map (hasProdExp True) es) fprodargs = foldr lubProd NoInfo (map (hasProdExp bc ) es) funCallInfo = let prodinfo = if fprodargs <= Terminating then if maybe False id (lookupProgInfo qg terminfo) then Terminating else lubProd (DCalls [qg]) (maybe Looping id (lookup qg calledFuncs)) else Looping -- worst case assumption, could be improved... in if not bc then prodinfo else case prodinfo of DCalls _ -> DCalls [] _ -> prodinfo ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/TotallyDefined.curry000066400000000000000000000135141377556325500274300ustar00rootroot00000000000000----------------------------------------------------------------------------- --- Pattern completeness and totally definedness analysis for Curry programs --- --- This analysis checks for each function in a Curry program whether --- this function is completely defined, i.e., reducible on all ground --- constructor terms --- --- @author Johannes Koj, Michael Hanus --- @version April 2018 ----------------------------------------------------------------------------- module Analysis.TotallyDefined ( siblingCons, showSibling, Completeness(..), showComplete, showTotally , patCompAnalysis, totalAnalysis ) where import Analysis.ProgInfo import Analysis.Types import FlatCurry.Types import FlatCurry.Goodies import Data.List (delete) ----------------------------------------------------------------------- --- An analysis to compute the sibling constructors (belonging to the --- same data type) for a data constructor. --- Shows the result of the sibling constructors analysis, i.e., --- shows a list of constructor names together with their arities. showSibling :: AOutFormat -> [(QName,Int)] -> String showSibling _ = show siblingCons :: Analysis [(QName,Int)] siblingCons = simpleConstructorAnalysis "SiblingCons" consNamesArOfType where -- get all constructor names and arities of a datatype declaration consNamesArOfType cdecl (Type _ _ _ consDecls) = map (\cd -> (consName cd, consArity cd)) (filter (\cd -> consName cd /= consName cdecl) consDecls) consNamesArOfType _ (TypeSyn _ _ _ _) = [] consNamesArOfType _ (TypeNew _ _ _ _) = [] ------------------------------------------------------------------------------ -- The completeness analysis assigns to an operation a flag indicating -- whether this operation is completely defined on its input types, -- i.e., reducible for all ground data terms. -- The possible outcomes of the completeness analysis: data Completeness = Complete -- completely defined | InComplete -- incompletely defined | InCompleteOr -- incompletely defined in each branch of an "Or" deriving (Eq, Show, Read) --- A function is totally defined if it is pattern complete and depends --- only on totally defined functions. totalAnalysis :: Analysis Bool totalAnalysis = combinedDependencyFuncAnalysis "Total" patCompAnalysis True analyseTotally analyseTotally :: ProgInfo Completeness -> FuncDecl -> [(QName,Bool)] -> Bool analyseTotally pcinfo fdecl calledfuncs = (maybe False (\c->c==Complete) (lookupProgInfo (funcName fdecl) pcinfo)) && all snd calledfuncs -- Shows the result of the totally-defined analysis. showTotally :: AOutFormat -> Bool -> String showTotally AText True = "totally defined" showTotally ANote True = "" showTotally _ False = "partially defined" ------------------------------------------------------------------------------ --- Pattern completeness analysis patCompAnalysis :: Analysis Completeness patCompAnalysis = combinedSimpleFuncAnalysis "PatComplete" siblingCons analysePatComplete -- Shows the result of the completeness analysis. showComplete :: AOutFormat -> Completeness -> String showComplete AText Complete = "complete" showComplete ANote Complete = "" showComplete _ InComplete = "incomplete" showComplete _ InCompleteOr = "incomplete in each disjunction" analysePatComplete :: ProgInfo [(QName,Int)] -> FuncDecl -> Completeness analysePatComplete consinfo fdecl = anaFun fdecl where anaFun (Func _ _ _ _ (Rule _ e)) = isComplete consinfo e anaFun (Func _ _ _ _ (External _)) = Complete isComplete :: ProgInfo [(QName,Int)] -> Expr -> Completeness isComplete _ (Var _) = Complete isComplete _ (Lit _) = Complete isComplete consinfo (Comb _ f es) = if f==("Prelude","commit") && length es == 1 then isComplete consinfo (head es) else Complete isComplete _ (Free _ _) = Complete isComplete _ (Let _ _) = Complete isComplete consinfo (Or e1 e2) = combineOrResults (isComplete consinfo e1) (isComplete consinfo e2) -- if there is no branch, it is incomplete: isComplete _ (Case _ _ []) = InComplete -- for literal branches we assume that not all alternatives are provided: isComplete _ (Case _ _ (Branch (LPattern _) _ : _)) = InComplete isComplete consinfo (Case _ _ (Branch (Pattern cons _) bexp : ces)) = combineAndResults (checkAllCons (maybe [] (map fst) (lookupProgInfo cons consinfo)) ces) (isComplete consinfo bexp) where -- check for occurrences of all constructors in each case branch: checkAllCons [] _ = Complete checkAllCons (_:_) [] = InComplete checkAllCons (_:_) (Branch (LPattern _) _ : _) = InComplete -- should not occur checkAllCons (c:cs) (Branch (Pattern i _) e : ps) = combineAndResults (checkAllCons (delete i (c:cs)) ps) (isComplete consinfo e) isComplete consinfo (Typed e _) = isComplete consinfo e -- Combines the completeness results in different Or branches. combineOrResults :: Completeness -> Completeness -> Completeness combineOrResults Complete _ = Complete combineOrResults InComplete Complete = Complete combineOrResults InComplete InComplete = InCompleteOr combineOrResults InComplete InCompleteOr = InCompleteOr combineOrResults InCompleteOr Complete = Complete combineOrResults InCompleteOr InComplete = InCompleteOr combineOrResults InCompleteOr InCompleteOr = InCompleteOr -- Combines the completeness results in different case branches. combineAndResults :: Completeness -> Completeness -> Completeness combineAndResults InComplete _ = InComplete combineAndResults Complete Complete = Complete combineAndResults Complete InComplete = InComplete combineAndResults Complete InCompleteOr = InCompleteOr combineAndResults InCompleteOr Complete = InCompleteOr combineAndResults InCompleteOr InComplete = InComplete combineAndResults InCompleteOr InCompleteOr = InCompleteOr curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/TypeUsage.curry000066400000000000000000000043321377556325500264250ustar00rootroot00000000000000------------------------------------------------------------------------ --- Analysis of properties related to the usage and occurrences of types. --- --- @author Michael Hanus --- @version February 2017 ------------------------------------------------------------------------ module Analysis.TypeUsage(showTypeNames,typesInValuesAnalysis) where import Analysis.Types import FlatCurry.Types import Data.List (intercalate) ------------------------------------------------------------------------ -- This analysis associates to each type the types which might occur -- in values of this type. If a type occurs in its associated types, -- it is a recursive type. typesInValuesAnalysis :: Analysis [QName] typesInValuesAnalysis = dependencyTypeAnalysis "TypesInValues" [] typesInTypeDecl -- Show a list of type constructor names as a string. showTypeNames :: AOutFormat -> [QName] -> String showTypeNames _ tcs = intercalate ", " $ map (\ (mn,fn) -> mn ++ "." ++ fn) tcs typesInTypeDecl :: TypeDecl -> [(QName,[QName])] -> [QName] typesInTypeDecl (Type _ _ _ conDecls) usedtypes = foldr join [] $ map typesInConsDecl conDecls where typesInConsDecl (Cons _ _ _ typeExprs) = foldr join [] $ map (typesInTypeExpr usedtypes) typeExprs typesInTypeDecl (TypeSyn _ _ _ typeExpr) usedtypes = typesInTypeExpr usedtypes typeExpr typesInTypeDecl (TypeNew _ _ _ (NewCons _ _ typeExpr)) usedtypes = typesInTypeExpr usedtypes typeExpr -- Computes all type constructors occurring in a type expression. typesInTypeExpr :: [(QName,[QName])] -> TypeExpr -> [QName] typesInTypeExpr _ (TVar _) = [] typesInTypeExpr usedtypes (FuncType t1 t2) = join (typesInTypeExpr usedtypes t1) (typesInTypeExpr usedtypes t2) typesInTypeExpr usedtypes (TCons tc texps) = foldr join (join [tc] (maybe [] id (lookup tc usedtypes))) (map (typesInTypeExpr usedtypes) texps) typesInTypeExpr usedtypes (ForallType _ t) = typesInTypeExpr usedtypes t join :: [QName] -> [QName] -> [QName] join tcs1 tcs2 = foldr insert tcs2 tcs1 where insert x [] = [x] insert x (y:ys) | x == y = y : ys | x < y = x : y : ys | otherwise = y : insert x ys ----------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/Types.curry000066400000000000000000000335341377556325500256310ustar00rootroot00000000000000------------------------------------------------------------------------- --- This module contains the datatypes, constructors, and other --- operations to create and process analyses used in the --- generic analysis system. --- --- Each analysis has a name which is used to identify the analysis --- stored in files, when passing analysis information between workers etc. --- --- **Important:** Use the constructor operations to define new analyses --- (instead of the data constructors). --- --- @author Heiko Hoffmann, Michael Hanus --- @version June 2018 ------------------------------------------------------------------------- module Analysis.Types ( Analysis(..) , simpleFuncAnalysis, simpleTypeAnalysis, simpleConstructorAnalysis , dependencyFuncAnalysis, dependencyTypeAnalysis , combinedSimpleFuncAnalysis, combined2SimpleFuncAnalysis , combinedSimpleTypeAnalysis , combinedDependencyFuncAnalysis, combinedDependencyTypeAnalysis , simpleModuleAnalysis, dependencyModuleAnalysis , isSimpleAnalysis, isCombinedAnalysis, isFunctionAnalysis , analysisName, baseAnalysisNames, startValue , AOutFormat(..) ) where import FlatCurry.Types ( Prog, ConsDecl, FuncDecl, TypeDecl, QName ) import FlatCurry.Goodies ( progImports ) import Analysis.ProgInfo ( ProgInfo, combineProgInfo, lookupProgInfo ) import Analysis.Files ( getImports, loadCompleteAnalysis, getInterfaceInfos ) --- Datatype representing a program analysis to be used in the --- generic analysis system. The datatype is abstract so that --- one has to use one of the constructor operations to create --- an analysis. data Analysis a = SimpleFuncAnalysis String (FuncDecl -> a) | SimpleTypeAnalysis String (TypeDecl -> a) | SimpleConstructorAnalysis String (ConsDecl -> TypeDecl -> a) | DependencyFuncAnalysis String a (FuncDecl -> [(QName,a)] -> a) | DependencyTypeAnalysis String a (TypeDecl -> [(QName,a)] -> a) | CombinedSimpleFuncAnalysis [String] String Bool (String -> IO (FuncDecl -> a)) | CombinedSimpleTypeAnalysis [String] String Bool (String -> IO (TypeDecl -> a)) | CombinedDependencyFuncAnalysis [String] String Bool a (String -> IO (FuncDecl -> [(QName,a)] -> a)) | CombinedDependencyTypeAnalysis [String] String Bool a (String -> IO (TypeDecl -> [(QName,a)] -> a)) | SimpleModuleAnalysis String (Prog -> a) | DependencyModuleAnalysis String (Prog -> [(String,a)] -> a) --- A simple analysis for functions takes an operation that computes --- some information from a given function declaration. simpleFuncAnalysis :: String -> (FuncDecl -> a) -> Analysis a simpleFuncAnalysis anaName anaFunc = SimpleFuncAnalysis anaName anaFunc --- A simple analysis for types takes an operation that computes --- some information from a given type declaration. simpleTypeAnalysis :: String -> (TypeDecl -> a) -> Analysis a simpleTypeAnalysis anaName anaFunc = SimpleTypeAnalysis anaName anaFunc --- A simple analysis for data constructors takes an operation that computes --- some information for a constructor declaration and its type declaration --- to which it belongs. simpleConstructorAnalysis :: String -> (ConsDecl -> TypeDecl -> a) -> Analysis a simpleConstructorAnalysis anaName anaFunc = SimpleConstructorAnalysis anaName anaFunc --- Construct a function analysis with dependencies. --- The analysis has a name, a start value (representing "no initial --- information") and an operation to process a function declaration --- with analysis information --- for the operations directly called in this function declaration. --- The analysis will be performed by a fixpoint iteration --- starting with the given start value. dependencyFuncAnalysis :: String -> a -> (FuncDecl -> [(QName,a)] -> a) -> Analysis a dependencyFuncAnalysis anaName startval anaFunc = DependencyFuncAnalysis anaName startval anaFunc --- Construct a type analysis with dependencies. --- The analysis has a name, a start value (representing "no initial --- information") and an operation to process a type declaration --- with analysis information --- for the type constructors occurring in the type declaration. --- The analysis will be performed by a fixpoint iteration --- starting with the given start value. dependencyTypeAnalysis :: String -> a -> (TypeDecl -> [(QName,a)] -> a) -> Analysis a dependencyTypeAnalysis anaName startval anaType = DependencyTypeAnalysis anaName startval anaType --- A simple combined analysis for functions. --- The analysis is based on an operation that computes --- some information from a given function declaration --- and information provided by some base analysis. --- The base analysis is provided as the second argument. combinedSimpleFuncAnalysis :: Read b => String -> Analysis b -> (ProgInfo b -> FuncDecl -> a) -> Analysis a combinedSimpleFuncAnalysis ananame baseAnalysis anaFunc = CombinedSimpleFuncAnalysis [analysisName baseAnalysis] ananame True (runWithBaseAnalysis baseAnalysis anaFunc) --- A simple combined analysis for functions. --- The analysis is based on an operation that computes --- some information from a given function declaration --- and information provided by two base analyses. --- The base analyses are provided as the second and third argument. combined2SimpleFuncAnalysis :: (Read b, Read c) => String -> Analysis b -> Analysis c -> (ProgInfo b -> ProgInfo c -> FuncDecl -> a) -> Analysis a combined2SimpleFuncAnalysis ananame baseAnalysisA baseAnalysisB anaFunc = CombinedSimpleFuncAnalysis [analysisName baseAnalysisA, analysisName baseAnalysisB] ananame True (runWith2BaseAnalyses baseAnalysisA baseAnalysisB anaFunc) --- A simple combined analysis for types. --- The analysis is based on an operation that computes --- some information from a given type declaration --- and information provided by some base analysis. --- The base analysis is provided as the second argument. combinedSimpleTypeAnalysis :: Read b => String -> Analysis b -> (ProgInfo b -> TypeDecl -> a) -> Analysis a combinedSimpleTypeAnalysis ananame baseAnalysis anaFunc = CombinedSimpleTypeAnalysis [analysisName baseAnalysis] ananame True (runWithBaseAnalysis baseAnalysis anaFunc) --- A combined analysis for functions with dependencies. --- The analysis is based on an operation that computes --- from information provided by some base analysis --- for each function declaration and information about its --- directly called operation some information for the declared function. --- The analysis will be performed by a fixpoint iteration --- starting with the given start value (fourth argument). --- The base analysis is provided as the second argument. combinedDependencyFuncAnalysis :: Read b => String -> Analysis b -> a -> (ProgInfo b -> FuncDecl -> [(QName,a)] -> a) -> Analysis a combinedDependencyFuncAnalysis ananame baseAnalysis startval anaFunc = CombinedDependencyFuncAnalysis [analysisName baseAnalysis] ananame True startval (runWithBaseAnalysis baseAnalysis anaFunc) --- A combined analysis for types with dependencies. --- The analysis is based on an operation that computes --- from information provided by some base analysis --- for each type declaration and information about its --- directly used types some information for the declared type. --- The analysis will be performed by a fixpoint iteration --- starting with the given start value (fourth argument). --- The base analysis is provided as the second argument. combinedDependencyTypeAnalysis :: Read b => String -> Analysis b -> a -> (ProgInfo b -> TypeDecl -> [(QName,a)] -> a) -> Analysis a combinedDependencyTypeAnalysis ananame baseAnalysis startval anaType = CombinedDependencyTypeAnalysis [analysisName baseAnalysis] ananame True startval (runWithBaseAnalysis baseAnalysis anaType) --- Construct a simple analysis for entire modules. --- The analysis has a name and takes an operation that computes --- some information from a given module. simpleModuleAnalysis :: String -> (Prog -> a) -> Analysis a simpleModuleAnalysis anaName anaFunc = SimpleModuleAnalysis anaName anaFunc --- Construct a module analysis which uses analysis information on --- imported modules. --- The analysis has a name and an operation to analyze a module. --- The analysis operation could use already computed information --- of imported modules, represented as a list of module name/information pairs. --- Note that a fixpoint iteration is not necessary --- since module dependencies must be acyclic. dependencyModuleAnalysis :: String -> (Prog -> [(String,a)] -> a) -> Analysis a dependencyModuleAnalysis anaName anaFunc = DependencyModuleAnalysis anaName anaFunc ------------------------------------------------------------------------- --- Is the analysis a simple analysis? --- Otherwise, it is a dependency analysis which requires a fixpoint --- computation to compute the results. isSimpleAnalysis :: Analysis a -> Bool isSimpleAnalysis analysis = case analysis of SimpleFuncAnalysis _ _ -> True SimpleTypeAnalysis _ _ -> True SimpleConstructorAnalysis _ _ -> True CombinedSimpleFuncAnalysis _ _ _ _ -> True CombinedSimpleTypeAnalysis _ _ _ _ -> True _ -> False --- Is the analysis a combined analysis? isCombinedAnalysis :: Analysis a -> Bool isCombinedAnalysis analysis = case analysis of CombinedSimpleFuncAnalysis _ _ _ _ -> True CombinedSimpleTypeAnalysis _ _ _ _ -> True CombinedDependencyFuncAnalysis _ _ _ _ _ -> True CombinedDependencyTypeAnalysis _ _ _ _ _ -> True _ -> False --- Is the analysis a function analysis? --- Otherwise, it is a type or constructor analysis. isFunctionAnalysis :: Analysis a -> Bool isFunctionAnalysis analysis = case analysis of SimpleFuncAnalysis _ _ -> True DependencyFuncAnalysis _ _ _ -> True CombinedSimpleFuncAnalysis _ _ _ _ -> True CombinedDependencyFuncAnalysis _ _ _ _ _ -> True _ -> False --- Name of the analysis to be used in server communication and --- analysis files. analysisName :: Analysis a -> String analysisName (SimpleFuncAnalysis name _ ) = name analysisName (SimpleTypeAnalysis name _ ) = name analysisName (SimpleConstructorAnalysis name _ ) = name analysisName (DependencyFuncAnalysis name _ _) = name analysisName (DependencyTypeAnalysis name _ _) = name analysisName (CombinedSimpleFuncAnalysis _ nameB _ _) = nameB analysisName (CombinedSimpleTypeAnalysis _ nameB _ _) = nameB analysisName (CombinedDependencyFuncAnalysis _ nameB _ _ _) = nameB analysisName (CombinedDependencyTypeAnalysis _ nameB _ _ _) = nameB analysisName (SimpleModuleAnalysis name _) = name analysisName (DependencyModuleAnalysis name _) = name --- Names of the base analyses of a combined analysis. baseAnalysisNames :: Analysis a -> [String] baseAnalysisNames ana = case ana of CombinedSimpleFuncAnalysis bnames _ _ _ -> bnames CombinedSimpleTypeAnalysis bnames _ _ _ -> bnames CombinedDependencyFuncAnalysis bnames _ _ _ _ -> bnames CombinedDependencyTypeAnalysis bnames _ _ _ _ -> bnames _ -> [] --- Start value of a dependency analysis. startValue :: Analysis a -> a startValue ana = case ana of DependencyFuncAnalysis _ startval _ -> startval DependencyTypeAnalysis _ startval _ -> startval CombinedDependencyFuncAnalysis _ _ _ startval _ -> startval CombinedDependencyTypeAnalysis _ _ _ startval _ -> startval _ -> error "Internal error in Analysis.startValue" ------------------------------------------------------------------------- --- The desired kind of output of an analysis result. --- `AText` denotes a standard textual representation. --- `ANote` denotes a short note that is empty in case of irrelevant --- information. For instance, this is used in the CurryBrowser --- to get a quick overview of the analysis results of all operations --- in a module. data AOutFormat = AText | ANote deriving Eq ------------------------------------------------------------------------- --- Loads the results of the base analysis and put it as the first --- argument of the main analysis operation which is returned. runWithBaseAnalysis :: Read a => Analysis a -> (ProgInfo a -> (input -> b)) -> String -> IO (input -> b) runWithBaseAnalysis baseAnalysis analysisFunction moduleName = do importedModules <- getImports moduleName let baseananame = analysisName baseAnalysis impbaseinfos <- getInterfaceInfos baseananame importedModules mainbaseinfos <- loadCompleteAnalysis baseananame moduleName let baseinfos = combineProgInfo impbaseinfos mainbaseinfos return (analysisFunction baseinfos) --- Loads the results of the base analysis and put it as the first --- argument of the main analysis operation which is returned. runWith2BaseAnalyses :: (Read a, Read b) => Analysis a -> Analysis b -> (ProgInfo a -> ProgInfo b -> (input -> c)) -> String -> IO (input -> c) runWith2BaseAnalyses baseanaA baseanaB analysisFunction moduleName = do importedModules <- getImports moduleName let baseananameA = analysisName baseanaA baseananameB = analysisName baseanaB impbaseinfosA <- getInterfaceInfos baseananameA importedModules mainbaseinfosA <- loadCompleteAnalysis baseananameA moduleName impbaseinfosB <- getInterfaceInfos baseananameB importedModules mainbaseinfosB <- loadCompleteAnalysis baseananameB moduleName let baseinfosA = combineProgInfo impbaseinfosA mainbaseinfosA baseinfosB = combineProgInfo impbaseinfosB mainbaseinfosB return (analysisFunction baseinfosA baseinfosB) curry-tools-v3.3.0/cpm/vendor/cass-analysis/src/Analysis/UnsafeModule.curry000066400000000000000000000034721377556325500271120ustar00rootroot00000000000000------------------------------------------------------------------------ --- An analysis which returns information whether a module is unsafe, i.e., --- it imports directly or indirectly the module `Unsafe`. --- --- @author Michael Hanus --- @version November 2020 ------------------------------------------------------------------------ module Analysis.UnsafeModule ( showUnsafe, unsafeModuleAnalysis ) where import Data.List ( isInfixOf, nub ) import Analysis.Types import FlatCurry.Goodies ( progImports, progName ) import FlatCurry.Types ------------------------------------------------------------------------ --- This analysis associates to a module the list of the names of all --- modules which directly imports the module `Unsafe`. --- Such modules might hide dangerous operations in --- purely functional operations. --- Thus, a module is safe if the analysis result is the empty list. unsafeModuleAnalysis :: Analysis [String] unsafeModuleAnalysis = dependencyModuleAnalysis "UnsafeModule" importsUnsafe -- Show a list of type constructor names as a string. showUnsafe :: AOutFormat -> [String] -> String showUnsafe _ [] = "safe" showUnsafe ANote (_:_) = "unsafe" showUnsafe AText [mod] = "unsafe (due to module " ++ mod ++ ")" showUnsafe AText ms@(_:_:_) = "unsafe (due to modules " ++ unwords ms ++ ")" -- Does the module import the module `Unsafe` or any other unsafe module? -- TODO: to be real safe, one also has to check external operations! importsUnsafe :: Prog -> [(String,[String])] -> [String] importsUnsafe prog impinfos = let unsafemods = (if any ("Unsafe" `isInfixOf`) (progImports prog) then [progName prog] else []) ++ concatMap snd impinfos in nub unsafemods ----------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cass/000077500000000000000000000000001377556325500172345ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/cass/LICENSE000066400000000000000000000027351377556325500202500ustar00rootroot00000000000000Copyright (c) 2017, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/cass/Protocol.txt000066400000000000000000000026111377556325500215760ustar00rootroot00000000000000Protocol to communicate with the analysis server ================================================ Server commands: ---------------- GetAnalysis SetCurryPath ::... StopServer AnalyzeModule AnalyzeInterface AnalyzeFunction AnalyzeDataConstructor AnalyzeTypeConstructor Server answers: --------------- error ... ok \n (here denotes the number of lines in ) The answer to the command `GetAnalysis` is a list of all available analyses. The list has the form " ". For instance, a communication could be: > GetAnalysis < ok 5 < Deterministic CurryTerm < Deterministic Text < Deterministic XML < HigherOrder CurryTerm < DependsOn CurryTerm Further examples for server requests: > AnalyzeModule Deterministic CurryTerm SolverServer > AnalyzeModule Deterministic Text SolverServer > AnalyzeModule Deterministic XML SolverServer > AnalyzeFunction Deterministic XML SolverServer main > AnalyzeDataConstructor HigherOrder CurryTerm Prelude Just > AnalyzeFunction DependsOn CurryTerm SolverServer main curry-tools-v3.3.0/cpm/vendor/cass/README.md000066400000000000000000000043411377556325500205150ustar00rootroot00000000000000CASS: The Curry Analysis Server System ====================================== This directory contains the implementation of CASS, a generic and distributed analysis system for Curry programs. The analysis system is structured as a worker/server application where the workers are triggered by the main server to analyse individual modules. The analysis system can also be used as a client from other application programs by a socket interface. The protocol of this interface is described in `Protocol.txt`. The server is explicitly started by the program `cass` (generated via `make`) or implicitly by application programs that use of the operation `Configuration.getServerPortNumber` to find out the port number to connect to the analysis server. The port number can either be explicitly specified the starting the main server program via cass -p or a free port number is chosen when the analysis server is started. The current port and process numbers of a running analysis server are temporarily stored in the file `$HOME/.curryanalysis.port` (in the tuple format `(port,pid)`). The program `cass` can also be started on a console with arguments: cass In this case, the analysis with the specified name is applied to the specified module without the use of the server protocol and the output is shown on stdout. Run the command cass --help to get a description of the arguments and a list of registered analysis names. The analysis system can be configured in the file `$HOME/.curryanalysisrc` which is installed after the first run of the system. The implementations of the individual analysis are usually defined in the package `cass-analysis`). Description of some Curry modules: ---------------------------------- * `CASS.Registry`: All available analyses must be registered here. * `CASS.Server`: The main module implementing the use of the server. * `CASS.ServerFormats`: Definition and implementation of output formats. * `CASS.WorkerFunctions`: Implementation of the analysis workers (in particular, alternative fixpoint iterations to compute dependency analyses, see option `fixpoint` in the configuration file, must be inserted here). Contact: [Michael Hanus](http://www.informatik.uni-kiel.de/~mh) curry-tools-v3.3.0/cpm/vendor/cass/curryanalysisrc000066400000000000000000000022151377556325500224140ustar00rootroot00000000000000# The initial default path when the system is started: # (this path is added at the end of an existing CURRYPATH value) path= # The number of workers (if value=0, no further processes are started): numberOfWorkers=0 # The method to compute the fixpoint in dependency analyses. Possible values: # simple : simple fixpoint iteration # wlist : fixpoint iteration with working lists # wlistscc : fixpoint iteration with working lists where strongly connected # components are computed to guide the individual iterations fixpoint=wlist # The command to be used to wrap the server when the system is started # in server mode: terminalCommand=gnome-terminal -e # The debugging level (between 0 and 4) to show informative debugging infos. # Meaning of the debug level: # 0 : show nothing # 1 : show worker activity, e.g., timings # 2 : show server communication # 3 : ...and show read/store information # 4 : ...show also stored/computed analysis data debugLevel=0 # Should the prelude be analyzed? Usually, it should be "yes". # The value "no" is only reasonable for experimental purposes # (e.g., to test new analyses on small programs). prelude=yes curry-tools-v3.3.0/cpm/vendor/cass/docs/000077500000000000000000000000001377556325500201645ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/cass/docs/Demand.md000066400000000000000000000003411377556325500216740ustar00rootroot00000000000000Demand analysis --------------- This analysis assigns to each operation a list of argument positions (e.g., [1] for the first argument) which are demanded in order to reduce this operation to some constructor-rooted value. curry-tools-v3.3.0/cpm/vendor/cass/docs/Deterministic.md000066400000000000000000000013151377556325500233110ustar00rootroot00000000000000Analysis of deterministic operations ------------------------------------ This analysis checks whether an operation is deterministically defined. Intuitively, an operation is deterministic if the evaluation of this operation applied to ground terms does not cause any non-determinism. The determinism analysis returns `nondeterministic` for a given operation if its definition contains overlapping left-hand sides or free variables, or if it depends on some non-deterministic operation. If calls to non-deterministic operations are encapsulated (by the use of set functions or operations from module `AllSolutions`), then it is classified as deterministic since the non-determinism does not occur at the top-level. curry-tools-v3.3.0/cpm/vendor/cass/docs/Functional.md000066400000000000000000000011711377556325500226100ustar00rootroot00000000000000Analysis of functionally defined operations ------------------------------------------- This analysis checks whether an operation is defined in a pure functional manner. An operation is functionally defined if its definition does not contain overlapping left-hand sides or free variables, and it depends only on functionally defined operations. This analysis is stronger than the `Deterministic` analysis, since the latter classifies an operation as deterministic if calls to possibly non-deterministic operations are wrapped with encapsulated search operators, whereas this analysis does not allow the use of any logic features. curry-tools-v3.3.0/cpm/vendor/cass/docs/Groundness.md000066400000000000000000000006321377556325500226360ustar00rootroot00000000000000Groundness analysis ------------------- This analysis assigns to each operation the conditions under which a ground (non-free) result is computed. The analysis results can be "always ground result", "possibly non-ground result", or "ground if arguments x1,..,xn are ground". The idea and details of this analysis can be found in the [ICLP'05 paper](http://www.informatik.uni-kiel.de/~mh/papers/ICLP05.html). curry-tools-v3.3.0/cpm/vendor/cass/docs/HiOrderConstr.md000066400000000000000000000003421377556325500232320ustar00rootroot00000000000000Higher-order constructor analysis --------------------------------- This analysis is a simple analysis for data constructors. It associates to each data constructor a flag indicating whether some argument contains functions. curry-tools-v3.3.0/cpm/vendor/cass/docs/HiOrderFunc.md000066400000000000000000000004331377556325500226560ustar00rootroot00000000000000Higher-order property analysis ------------------------------ This analysis analyzes the higher-order status of an operation. It classifies an operations as higher-order since if it has functional arguments or results, or or it processes data structures with functional components. curry-tools-v3.3.0/cpm/vendor/cass/docs/HiOrderType.md000066400000000000000000000003241377556325500227030ustar00rootroot00000000000000Higher-order type analysis -------------------------- This analysis analyzes the higher-order status of type constructors, i.e., it shows whether some constructor of a type constructor has functional arguments. curry-tools-v3.3.0/cpm/vendor/cass/docs/Indeterministic.md000066400000000000000000000005431377556325500236420ustar00rootroot00000000000000Indeterminism analysis ---------------------- This analysis assigns to each operation a flag which is `True` if this operation might be indeterministic, i.e., calls directly or indirectly a select or committed choice operation. Thus, an indeterministic is not referentially transparent since it might deliver different results on different program runs. curry-tools-v3.3.0/cpm/vendor/cass/docs/NDEffect.md000066400000000000000000000012471377556325500221300ustar00rootroot00000000000000Groundness/non-determinism effect analysis ------------------------------------------ This analysis assigns to each operation the conditions under which the evaluation of this operation might perform non-deterministic steps. The non-deterministic steps might be due to a `choice` (overlapping rules) or narrowing steps, where the latter might depend on the non-groundness of particular arguments. For instance, the operation not True = False not False = True is performs non-deterministic steps if the first argument is non-ground. The idea and details of this analysis can be found in the [ICLP'05 paper](http://www.informatik.uni-kiel.de/~mh/papers/ICLP05.html). curry-tools-v3.3.0/cpm/vendor/cass/docs/NonDetAllDeps.md000066400000000000000000000025321377556325500231440ustar00rootroot00000000000000Analysis of dependencies on all non-deterministic operations ------------------------------------------------------------ This analysis is useful if some operation has a non-deterministic behavior and one wants to find the reason for this behavior. For this purpose, the analysis computes for each operation the set of operations with a non-deterministic definition that might be called by this operation. An operation has a non-deterministic definition if its definition contains overlapping left-hand sides or free variables. If the non-determinism of an operation is encapsulated by a set function or an encapsulated search operation of the module `AllSolutions`, it is considered as deterministic. For instance, consider the operations last xs | _ ++ [x] == xs = x where x free coin = 0 ? 1 lastCoin = id (last [coin]) Then the operation `lastCoin` depends on the non-deterministic operations `last` and `coin`. Now consider the operations f x = x ? lastCoin g x = f x Then the operation `g` depends on the non-deterministic operation `f`, and also on the non-deterministic operations `last` and `coin`. In the long analysis output (produced by CASS in batch mode), the non-deterministic operations are shown together with the sequence of operations (limited to a length of 10) which calls the non-deterministic operation. curry-tools-v3.3.0/cpm/vendor/cass/docs/NonDetDeps.md000066400000000000000000000030221377556325500225060ustar00rootroot00000000000000Analysis of dependencies on non-deterministic operations -------------------------------------------------------- This analysis is useful if some operation has a non-deterministic behavior and one wants to find the reason for this behavior. For this purpose, the analysis computes for each operation the set of operations with a non-deterministic definition that might be called by this operation. An operation has a non-deterministic definition if its definition contains overlapping left-hand sides or free variables. Non-deterministic operations that are called by other non-deterministic operations are ignored so that only the first (w.r.t. the call sequence) non-deterministic operations are returned. Moreover, if the non-determinism of an operation is encapsulated by a set function or an encapsulated search operation of the module `AllSolutions`, it is considered as deterministic. For instance, consider the operations last xs | _ ++ [x] == xs = x where x free coin = 0 ? 1 lastCoin = id (last [coin]) Then the operation `lastCoin` depends on the non-deterministic operations `last` and `coin`. Now consider the operations f x = x ? lastCoin g x = f x Then the operation `g` depends on the non-deterministic operation `f`, but the dependency on the non-deterministic operations `last` and `coin` is not reported. In the long analysis output (produced by CASS in batch mode), the non-deterministic operations are shown together with the operation which directly calls the non-deterministic operation. curry-tools-v3.3.0/cpm/vendor/cass/docs/Overlapping.md000066400000000000000000000006411377556325500227750ustar00rootroot00000000000000Overlapping rule analysis ------------------------- The overlapping rule analysis checks whether an individual operation is defined by overlapping left-hand sides. For instance, the operation not True = False not False = True is not overlapping, whereas coin = 0 coin = 1 is overlapping. Note that f = coin is not overlapping, although it calls an operation defined by overlapping rules. curry-tools-v3.3.0/cpm/vendor/cass/docs/PatComplete.md000066400000000000000000000015151377556325500227250ustar00rootroot00000000000000Pattern completeness analysis ----------------------------- This analysis analyzes an operation for a pattern-complete definition. An operation is pattern complete if each pattern match is defined for all constructors. For instance, the operation not True = False not False = True is pattern complete, whereas the operation head (x:_) = x is incomplete. If an operation is defined by overlapping rules, it is complete if there is one alternative with complete pattern matching. For instance, the operation por True x = True por x True = True por False False = False is not complete, since it corresponds to the following definition: por x y = por1 x y ? por2 x y por1 True _ = True por1 False False = True por2 _ True = True Hence, each alternative is incomplete. curry-tools-v3.3.0/cpm/vendor/cass/docs/Productive.md000066400000000000000000000013001377556325500226240ustar00rootroot00000000000000Productivity analysis --------------------- This analysis computes some information about the termination or productivity of an operation. An operation is considered as being productive if it cannot perform an infinite number of steps without producing outermost constructors. This analysis assigns to an operation an abstract value indicating whether the function is terminating, looping, or productive. In the latter case, the abstract value contains the top-level calls, i.e., operations that are called at the top-level without an outermost constructor. For instance, consider the operations loop = id loop ones = 1 : ones `loop` is classified as looping whereas `ones` is productive. curry-tools-v3.3.0/cpm/vendor/cass/docs/README.txt000066400000000000000000000004111377556325500216560ustar00rootroot00000000000000This directory contains some documention for the Curry Analysis Server System: manual.tex: A short description to be included in the main manual of the Curry system. .md: The documentation of the analysis registered with name in markdown syntax. curry-tools-v3.3.0/cpm/vendor/cass/docs/RequiredValue.md000066400000000000000000000022351377556325500232650ustar00rootroot00000000000000Required value analysis ----------------------- This analysis checks for each operation in a Curry program whether the arguments must have a particular shape in order to compute some value. For instance, the negation operation `not` defined by not True = False not False = True requires the argument value `False` in order to compute the result `True` and it requires the argument `True` to compute the result `False`. This property is expressed by the following abstract type: not : (True -> False) | (False -> True) Hence, each abstract type is a constructor which represents all expressions rooted by this constructor. Moreover, the abstract type `cons` denotes any constructor-rooted expression and the abstract type `any` denotes any expression. The abstract type `_|_` denotes an impossible required type, i.e., an argument which is required but for which no applicable value exists. For instance, the operation f x = solve (x && not x) has the required value typing f: (_|_ -> {True}) A detailed description of this analysis and its application can be found in the [LOPSTR'15 paper](http://www.informatik.uni-kiel.de/~mh/papers/LOPSTR15.html). curry-tools-v3.3.0/cpm/vendor/cass/docs/RequiredValues.md000066400000000000000000000021571377556325500234530ustar00rootroot00000000000000Required values analysis ------------------------ This analysis checks for each operation in a Curry program whether the arguments must have a particular shape in order to compute some value. For instance, the negation operation `not` defined by not True = False not False = True requires the argument value `False` in order to compute the result `True` and it requires the argument `True` to compute the result `False`. This property is expressed by the following abstract type: not : ({True} -> {False}) | ({False} -> {True}) Hence, each abstract type is a set of constructors which represents all expressions rooted by one of the constructors in this set. Moreover, the abstract type `any` denotes any expression. The empty list denotes an impossible required type, i.e., an argument which is required but for which no applicable value exists. For instance, the operation f x = solve (x && not x) has the required value typing f: ({} -> True) A detailed description of this analysis and its application can be found in the [LOPSTR'15 paper](http://www.informatik.uni-kiel.de/~mh/papers/LOPSTR15.html). curry-tools-v3.3.0/cpm/vendor/cass/docs/Residuation.md000066400000000000000000000024001377556325500227700ustar00rootroot00000000000000Residuation analysis -------------------- This analysis checks whether a function does not residuate and yields, if it successfully evaluates to some value, a ground value provided that the function is called with some ground values as arguments. To bemore precise, the analysis associates to each function one of the following results: * `NoResiduateIf xs` (does not residuate if arguments `xs` are ground): If the operation is called where the arguments in the index list `xs` are ground values (where arguments are numbered from 1), then the evaluation does not residuate and yields a ground value. For instance, the operation const :: a -> b -> a const x _ = x has the residuation behavior `NoResiduateIf [1]`, and the list concatenation `++` has the residuation behavior `NoResiduateIf [1,2]`. * `MayResiduate` (possible residuation or non-ground result): The operation might residuate or yields a non-ground value, independent of the arguments. For instance, this is the case for the operations f x = x + ensureNotFree unknown g x = (x,y) where y free * `NoResInfo` (unknown residuation behavior): The residuation behavior of this function cannot be determined. This might occur when complex recursive `let`s are involved. curry-tools-v3.3.0/cpm/vendor/cass/docs/RightLinear.md000066400000000000000000000006521377556325500227210ustar00rootroot00000000000000Right-linearity analysis ------------------------ This analysis checks whether an operation is right-linear, i.e., whether its evaluation does not duplicate any argument. Hence, this analysis returns `right-linear` for a given operation if it is defined by right-linear rules (i.e., rules that does not contain multiple occurrences of argument variables in its right-hand sides) and depends only on right-linear operations. curry-tools-v3.3.0/cpm/vendor/cass/docs/RootCyclic.md000066400000000000000000000005441377556325500225630ustar00rootroot00000000000000Root cyclic analysis -------------------- This analysis assigns `True` to an operation `f` if its evaluation might result in an expression rooted by `f`. Hence, this analysis is useful to detect simple loops. f x = g x g x = h x h x = id (f x) id x = x Then `f`, `g`, and `h` are root-cyclic whereas `id` is not root-cyclic. curry-tools-v3.3.0/cpm/vendor/cass/docs/RootReplaced.md000066400000000000000000000007241377556325500230740ustar00rootroot00000000000000Root replacement analysis ------------------------- This analysis returns for each function `f` all functions into which `f` can be replaced at the root. For instance, if there are the definitions: f x = g x g x = h x h x = k x : [] k x = x then the root replacements of `f` are `[g,h]` and the root replacements of `g` are `[h]`. This analysis could be useful to detect simple loops, e.g., if a function is in its own root replacement. curry-tools-v3.3.0/cpm/vendor/cass/docs/SensibleType.md000066400000000000000000000024101377556325500231110ustar00rootroot00000000000000Sensible types analysis ----------------------- The `SensibleType` analysis is a type analysis which checks whether a type is sensible, i.e., whether there exists at least one value of this type. This analysis associates to each type constructor the following information: * sensible, i.e., there is exists some value of this type * parametric sensible, i.e., it is parametric type which is sensible if all type arguments are instantiated with sensible types * not sensible, i.e., there may be no values of this type For instance, the list type constructor "[]" is sensible and the pair type constructor "(,)" is parametric sensible. For further examples, consider the following type declarations: type Pair = (Int,Int) data RTree a = RTree a [RTree a] data ITree a = ITree a (ITree a) type IntRTree = RTree Int type IntITree = ITree Int type ITreeRTree = RTree (ITree Int) Then this analysis computes the following information: Pair : sensible RTree : parametric sensible ITree : not sensible IntRTree : sensible IntITree : not sensible ITreeRTree : not sensible Note that function types are classified as not sensible since it is not known whether some operation of this type exists. curry-tools-v3.3.0/cpm/vendor/cass/docs/SiblingCons.md000066400000000000000000000005211377556325500227160ustar00rootroot00000000000000Sibling constructor analysis ---------------------------- This analysis associates to each data constructor the list of sibling constructors, i.e., the qualified name and arity of all constructors of the same type without this data constructor. For instance, the sibling constructors of `Prelude.True` are `[(("Prelude","False"),0)]`. curry-tools-v3.3.0/cpm/vendor/cass/docs/SolComplete.md000066400000000000000000000007141377556325500227360ustar00rootroot00000000000000Solution completeness analysis ------------------------------ This analysis assigns to a function a flag which is `True` if this function is operationally complete, i.e., does not call (explicitly or implicitly) a rigid function. For instance, the operation not True = False not False = True is `solution complete`, whereas the prelude operation `putChar` is not solution complete but may suspend if it is called with a free variable as argument. curry-tools-v3.3.0/cpm/vendor/cass/docs/Terminating.md000066400000000000000000000015661377556325500227770ustar00rootroot00000000000000Termination analysis -------------------- This analysis assigns `True` to an operation `f` if all its evaluations on ground argument terms are finite. The current method used in this analysis is quite simple. It checks whether the arguments in all recursive calls of an operation are smaller than the arguments passed to the operation. Indirect calls are not considered. Therefore, the operation length [] = 0 length (x:xs) = 1 + length xs is classified as terminating, whereas the semantically equivalent operation length [] = 0 length (x:xs) = incLength xs incLength xs = 1 + length xs is classified as possibly non-terminating. Operations containing free variables in their definitions are also classified as possibly non-terminating since a free variable might reduce to arbitrarily large constructor terms (in case of recursive data types). curry-tools-v3.3.0/cpm/vendor/cass/docs/Total.md000066400000000000000000000005201377556325500215660ustar00rootroot00000000000000Totally definedness analysis ---------------------------- This analysis assigns to each operation a flag which is `True` if this operation is completely defined on its input types, i.e., reducible for all ground data terms. Thus, an operation is totally defined if it is pattern complete and depends only on totally defined functions. curry-tools-v3.3.0/cpm/vendor/cass/docs/TypesInValues.md000066400000000000000000000016531377556325500232660ustar00rootroot00000000000000Analyzing types occurring in values ----------------------------------- The `TypesInValues` analysis is a type analysis which assigns to each data type defined in a program the list of data types (type constructors) which might occur in value arguments of this type. For instance, no type constructors are associated to `Bool` since Boolean values have no arguments. The type constructor `[]` is associated to the `[]` since a list occurs in the second argument of a non-empty list. Thus, this analysis can be used to check for recursive types: if a type constructor is associated to itself, the type is recursive, i.e., can have values of arbitrary size. For instance, consider the following type declarations: data List a = Empty | Cons a (List a) data Tree a = Leaf | Node (List (Tree a)) Then this analysis computes the following information: List : List Tree : List, Tree Hence, both types are recursive. curry-tools-v3.3.0/cpm/vendor/cass/docs/UnsafeModule.md000066400000000000000000000007501377556325500230770ustar00rootroot00000000000000Analyzing module for importing `Unsafe` module ---------------------------------------------- The `UnsafeModule` analysis returns information whether a module is unsafe, i.e., it imports directly or indirectly the module `Unsafe`. Such modules might hide dangerous operations in purely functional operations. The result of this analysis is the list of the names of all modules which directly imports the module `Unsafe`. Thus, a module is safe if the analysis result is the empty list. curry-tools-v3.3.0/cpm/vendor/cass/docs/main.tex000066400000000000000000000036101377556325500216320ustar00rootroot00000000000000\documentclass[11pt,fleqn]{article} \usepackage[T1]{fontenc} \usepackage{latexsym} \usepackage{url} \usepackage{xspace} \usepackage{graphicx} \setlength{\textwidth}{16.5cm} \setlength{\textheight}{23cm} \renewcommand{\baselinestretch}{1.1} \setlength{\topmargin}{-1cm} \setlength{\oddsidemargin}{0cm} \setlength{\evensidemargin}{0cm} \setlength{\marginparwidth}{0.0cm} \setlength{\marginparsep}{0.0cm} \newlength{\figurewidth} \setlength{\figurewidth}{\textwidth} \addtolength{\figurewidth}{-0.4cm} % font for program texts \renewcommand{\tt}{\usefont{OT1}{cmtt}{m}{n}\selectfont} \newcommand{\codefont}{\small\tt} \usepackage{listings} \lstset{aboveskip=1.5ex, belowskip=1.5ex, showstringspaces=false, % no special string space mathescape=true, flexiblecolumns=false, xleftmargin=2ex, basewidth=0.52em, basicstyle=\small\ttfamily} \lstset{literate={->}{{$\rightarrow{}\!\!\!$}}3 } \lstnewenvironment{curry}{}{} \lstnewenvironment{currynomath}{\lstset{mathescape=false}}{} % Curry w/o math \newcommand{\listline}{\vrule width0pt depth1.75ex} % program text in normal text \newcommand{\code}[1]{\mbox{\codefont #1}} % program text in normal text with apostrophs \newcommand{\ccode}[1]{``\code{#1}''} \newcommand{\pindex}[1]{\index{#1@{\tt #1}}} % program elements in index \newcommand{\CYS}{Curry\xspace} % name of the Curry system described here \newcommand{\cyshome}{\mbox{\textit{curryhome}}\xspace} % symbolic installation directory \begin{document} \sloppy \input{manual.tex} % Bibliography \begin{thebibliography}{10} \bibitem{HanusSkrlac14} M.~Hanus and F.~Skrlac. \newblock A modular and generic analysis server system for functional logic programs. \newblock In {\em Proc. of the ACM SIGPLAN 2014 Workshop on Partial Evaluation and Program Manipulation (PEPM'14)}, pages 181--188. ACM Press, 2014. \end{thebibliography} \end{document} curry-tools-v3.3.0/cpm/vendor/cass/docs/manual.tex000066400000000000000000000362431377556325500221730ustar00rootroot00000000000000\section{CASS: A Generic Curry Analysis Server System} \label{sec-cass} CASS\index{CASS}\index{analyzing programs}\index{program!analysis} (Curry Analysis Server System) is a tool for the analysis of Curry programs. CASS is generic so that various kinds of analyses (e.g., groundness, non-determinism, demanded arguments) can be easily integrated into CASS. In order to analyze larger applications consisting of dozens or hundreds of modules, CASS supports a modular and incremental analysis of programs. Moreover, it can be used by different programming tools, like documentation generators, analysis environments, program optimizers, as well as Eclipse-based development environments. For this purpose, CASS can also be invoked as a server system to get a language-independent access to its functionality. CASS is completely implemented Curry as a master/worker architecture to exploit parallel or distributed execution environments. The general design and architecture of CASS is described in \cite{HanusSkrlac14}. In the following, CASS is presented from a perspective of a programmer who is interested to analyze Curry programs. \subsection{Installation} The current implementation of CASS is a package managed by the Curry Package Manager CPM. Thus, to install the newest version of CASS, use the following commands: % \begin{curry} > cypm update > cypm install cass \end{curry} % This downloads the newest package, compiles it, and places the executable \code{cass} into the directory \code{\$HOME/.cpm/bin}. Hence it is recommended to add this directory to your path in order to execute CASS as described below. \subsection{Using CASS to Analyze Programs} CASS is intended to analyze various operational properties of Curry programs. Currently, it contains more than a dozen program analyses for various properties. Since most of these analyses are based on abstract interpretations, they usually approximate program properties. To see the list of all available analyses, use the help option of CASS: \begin{curry} > cass -h Usage: $\ldots$ $\vdots$ Registered analyses names: $\ldots$ Demand : Demanded arguments Deterministic : Deterministic operations $\vdots$ \end{curry} More information about the meaning of the various analyses can be obtained by adding the short name of the analysis: \begin{curry} > cass -h Deterministic $\ldots$ \end{curry} For instance, consider the following Curry module \code{Rev.curry}: \begin{curry} append :: [a] -> [a] -> [a] append [] ys = ys append (x:xs) ys = x : append xs ys rev :: [a] -> [a] rev [] = [] rev (x:xs) = append (rev xs) [x] main :: Int -> Int -> [Int] main x y = rev [x .. y] \end{curry} % CASS supports three different usage modes to analyze this program. \subsubsection{Batch Mode} In the batch mode, CASS is started as a separate application via the shell command \code{cass}, where the analysis name and the name of the module to be analyzed must be provided:\footnote{More output is generated when the parameter \code{debugLevel} is changed in the configuration file \code{.curryanalysisrc} which is installed in the user's home directory when CASS is started for the first time.} \begin{curry} > cass Demand Rev append : demanded arguments: 1 main : demanded arguments: 1,2 rev : demanded arguments: 1 \end{curry} The \code{Demand} analysis shows the list of argument positions (e.g., 1 for the first argument) which are demanded in order to reduce an application of the operation to some constructor-rooted value. Here we can see that both arguments of \code{main} are demanded whereas only the first argument of \code{append} is demanded. This information could be used in a Curry compiler to produce more efficient target code. The batch mode is useful to test a new analysis and get the information in human-readable form so that one can experiment with different abstractions or analysis methods. \subsubsection{API Mode} The API mode is intended to use analysis information in some application implemented in Curry. Since CASS is implemented in Curry, one can import the modules of the CASS implementation and use the CASS interface operations to start an analysis and use the computed results. For instance, CASS provides an operation (defined in the module \code{AnalysisServer}) \begin{curry} analyzeGeneric :: Analysis a -> String -> IO (Either (ProgInfo a) String) \end{curry} to apply an analysis (first argument) to some module (whose name is given in the second argument). The result is either the analysis information computed for this module or an error message in case of some execution error. The modules of the CASS implementation are stored in the directory \code{\cyshome/currytools/CASS} and the modules implementing the various program analyses are stored in \code{\cyshome/currytools/analysis}. Hence, one should add these directories to the Curry load path when using CASS in API mode. The CASS module \code{GenericProgInfo} contains operations to access the analysis information computed by CASS. For instance, the operation \begin{curry} lookupProgInfo:: QName -> ProgInfo a -> Maybe a \end{curry} returns the information about a given qualified name in the analysis information, if it exists. As a simple example, consider the demand analysis which is implemented in the module \code{Demandedness} by the following operation: \begin{curry} demandAnalysis :: Analysis DemandedArgs \end{curry} \code{DemendedArgs} is just a type synonym for \code{[Int]}. We can use this analysis in the following simple program: \begin{currynomath} import AnalysisServer (analyzeGeneric) import GenericProgInfo (lookupProgInfo) import Demandedness (demandAnalysis) demandedArgumentsOf :: String -> String -> IO [Int] demandedArgumentsOf modname fname = do deminfo <- analyzeGeneric demandAnalysis modname >>= return . either id error return $ maybe [] id (lookupProgInfo (modname,fname) deminfo) \end{currynomath} %$ Of course, in a realistic program, the program analysis is performed only once and the computed information \code{deminfo} is passed around to access it several times. Nevertheless, we can use this simple program to compute the demanded arguments of \code{Rev.main}: \begin{curry} $\ldots$> demandedArgumentsOf "Rev" "main" [1,2] \end{curry} \subsubsection{Server Mode} The server mode of CASS can be used in an application implemented in some language that does not have a direct interface to Curry. In this case, one can connect to CASS via some socket using a simple communication protocol that is specified in the file \code{\cyshome/currytools/CASS/Protocol.txt} and sketched below. To start CASS in the server mode, one has to execute the command \begin{curry} > cass --server [ -p ] \end{curry} where an optional port number for the communication can be provided. Otherwise, a free port number is chosen and shown. In the server mode, CASS understands the following commands: \begin{curry} GetAnalysis SetCurryPath ::... AnalyzeModule AnalyzeInterface AnalyzeFunction AnalyzeDataConstructor AnalyzeTypeConstructor StopServer \end{curry} The output type can be \code{Text}, \code{CurryTerm}, or \code{XML}. The answer to each request can have two formats: \begin{curry} error \end{curry} if an execution error occured, or \begin{curry} ok \end{curry} where \code{} is the number of lines of the result text. For instance, the answer to the command \code{GetAnalysis} is a list of all available analyses. The list has the form \begin{curry} \end{curry} For instance, a communication could be: \begin{curry} > GetAnalysis < ok 5 < Deterministic CurryTerm < Deterministic Text < Deterministic XML < HigherOrder CurryTerm < DependsOn CurryTerm \end{curry} The command \code{SetCurryPath} instructs CASS to use the given directories to search for modules to be analyzed. This is necessary since the CASS server might be started in a different location than its client. Complete modules are analyzed by \code{AnalyzeModule}, whereas \code{AnalyzeInterface} returns only the analysis information of exported entities. Furthermore, the analysis results of individual functions, data or type constructors are returned with the remaining analysis commands. Finally, \code{StopServer} terminates the CASS server. For instance, if we start CASS by \begin{curry} > cass --server -p 12345 \end{curry} we can communicate with CASS as follows (user inputs are prefixed by \ccode{>}); \begin{curry} > telnet localhost 12345 Connected to localhost. > GetAnalysis ok 57 Overlapping XML Overlapping CurryTerm Overlapping Text Deterministic XML ... > AnalyzeModule Demand Text Rev ok 3 append : demanded arguments: 1 main : demanded arguments: 1,2 rev : demanded arguments: 1 > AnalyzeModule Demand CurryTerm Rev ok 1 [(("Rev","append"),"demanded arguments: 1"),(("Rev","main"),"demanded arguments: 1,2"),(("Rev","rev"),"demanded arguments: 1")] > AnalyzeModule Demand XML Rev ok 19 Rev append demanded arguments: 1 Rev main demanded arguments: 1,2 Rev rev demanded arguments: 1 > StopServer ok 0 Connection closed by foreign host. \end{curry} \subsection{Implementing Program Analyses} Each program analysis accessible by CASS must be registered in the CASS module \code{Registry}. The registered analysis must contain an operation of type \begin{curry} Analysis a \end{curry} where \code{a} denotes the type of analysis results. For instance, the \code{Overlapping} analysis is implemented as a function \begin{curry} overlapAnalysis :: Analysis Bool \end{curry} where the Boolean analysis result indicates whether a Curry operation is defined by overlapping rules. In order to add a new analysis to CASS, one has to implement a corresponding analysis operation, registering it in the module \code{Registry} (in the constant \code{registeredAnalysis}) and compile the modified CASS implementation. An analysis is implemented as a mapping from Curry programs represented in FlatCurry into the analysis result. Hence, to implement the \code{Overlapping} analysis, we define the following operation on function declarations in FlatCurry format: \begin{curry} import FlatCurry.Types $\ldots$ isOverlappingFunction :: FuncDecl -> Bool isOverlappingFunction (Func _ _ _ _ (Rule _ e)) = orInExpr e isOverlappingFunction (Func f _ _ _ (External _)) = f==("Prelude","?") -- Check an expression for occurrences of Or: orInExpr :: Expr -> Bool orInExpr (Var _) = False orInExpr (Lit _) = False orInExpr (Comb _ f es) = f==(pre "?") || any orInExpr es orInExpr (Free _ e) = orInExpr e orInExpr (Let bs e) = any orInExpr (map snd bs) || orInExpr e orInExpr (Or _ _) = True orInExpr (Case _ e bs) = orInExpr e || any orInBranch bs where orInBranch (Branch _ be) = orInExpr be orInExpr (Typed e _) = orInExpr e \end{curry} % In order to enable the inclusion of different analyses in CASS, CASS offers several constructor operations for the abstract type \ccode{Analysis a} (defined in the CASS module \code{Analysis}). Each analysis has a name provided as a first argument to these constructors. The name is used to store the analysis information persistently and to pass specific analysis tasks to analysis workers. For instance, a simple function analysis which depends only on a given function definition can be defined by the analysis constructor \begin{curry} simpleFuncAnalysis :: String -> (FuncDecl -> a) -> Analysis a \end{curry} The arguments are the analysis name and the actual analysis function. Hence, the ``overlapping rules'' analysis can be specified as \begin{curry} import Analysis $\ldots$ overlapAnalysis :: Analysis Bool overlapAnalysis = simpleFuncAnalysis "Overlapping" isOverlappingFunction \end{curry} Another analysis constructor supports the definition of a function analysis with dependencies (which is implemented via a fixpoint computation): \begin{curry} dependencyFuncAnalysis :: String -> a -> (FuncDecl -> [(QName,a)] -> a) -> Analysis a \end{curry} Here, the second argument specifies the start value of the fixpoint analysis, i.e., the bottom element of the abstract domain. For instance, a determinism analysis could be based on an abstract domain described by the data type \begin{curry} data Deterministic = NDet | Det \end{curry} Here, \code{Det} is interpreted as ``the operation always evaluates in a deterministic manner on ground constructor terms.'' However, \code{NDet} is interpreted as ``the operation \emph{might} evaluate in different ways for given ground constructor terms.'' The apparent imprecision is due to the approximation of the analysis. For instance, if the function \code{f} is defined by overlapping rules and the function \code{g} \emph{might} call \code{f}, then \code{g} is judged as non-deterministic (since it is generally undecidable whether \code{f} is actually called by \code{g} in some run of the program). The determinism analysis requires to examine the current function as well as all directly or indirectly called functions for overlapping rules. Due to recursive function definitions, this analysis cannot be done in one shot---it requires a fixpoint computation. CASS provides such fixpoint computations and requires only the implementation of an operation of type \begin{curry} FuncDecl -> [(QName,a)] -> a \end{curry} where \ccode{a} denotes the type of abstract values. The second argument of type \code{[(QName,a)]} represents the currently known analysis values for the functions \emph{directly} used in this function declaration. In our example, the determinism analysis can be implemented by the following operation: \begin{curry} detFunc :: FuncDecl -> [(QName,Deterministic)] -> Deterministic detFunc (Func f _ _ _ (Rule _ e)) calledFuncs = if orInExpr e || freeVarInExpr e || any (==NDet) (map snd calledFuncs) then NDet else Det \end{curry} Thus, it computes the abstract value \code{NDet} if the function itself is defined by overlapping rules or contains free variables that might cause non-deterministic guessing (we omit the definition of \code{freeVarInExpr} since it is quite similar to \code{orInExpr}), or if it depends on some non-deterministic function. The complete determinism analysis can be specified as \begin{curry} detAnalysis :: Analysis Deterministic detAnalysis = dependencyFuncAnalysis "Deterministic" Det detFunc \end{curry} This definition is sufficient to execute the analysis with CASS since the analysis system takes care of computing fixpoints, calling the analysis functions with appropriate values, analyzing imported modules, etc. Nevertheless, the analysis must be defined so that the fixpoint computation always terminates. This can be achieved by using an abstract domain with finitely many values and ensuring that the analysis function is monotone w.r.t.\ some ordering on the values. curry-tools-v3.3.0/cpm/vendor/cass/examples/000077500000000000000000000000001377556325500210525ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/cass/examples/NonDetTest.curry000066400000000000000000000010661377556325500241720ustar00rootroot00000000000000-- Tests for the non-determinism dependency analysis `NonDetDeps`. -- -- Runt test with: -- > cass NonDetDeps NonDetTest.curry last xs | _ ++ [x] == xs = x where x free lastfp (_ ++ [x]) = x printLast = do print $ last [1..7] print $ lastfp [1..42] coin = 0 ? 1 lastCoin = id (last [coin]) --> last, coin f x = x ? lastCoin g x = f x -- For this operation, the NonDetDeps analysis reports that the -- non-determinism depends on `f`. -- However, the analysis NonDetAllDeps reports also the dependency -- on the non-deterministic operations coin, last,... curry-tools-v3.3.0/cpm/vendor/cass/examples/ResiduationStats.curry000066400000000000000000000037311377556325500254510ustar00rootroot00000000000000--- Analyzing the residuation behavior of a module and returns --- some statistical information. import Data.List ( intercalate, partition ) import FlatCurry.Types ( QName ) import CASS.Server ( analyzeGeneric ) import Analysis.ProgInfo ( progInfo2Lists ) import Analysis.Residuation -- ( demandAnalysis ) residuationInfoOf :: String -> IO ([(QName,ResiduationInfo)],[(QName,ResiduationInfo)]) residuationInfoOf modname = do analyzeGeneric residuationAnalysis modname >>= return . either progInfo2Lists error countResOps :: String -> IO [String] countResOps mname = do putStrLn $ "Analyzing module " ++ mname ++ "..." (pubres,privres) <- residuationInfoOf mname let (resops,nonresops) = partition (\(_,i) -> i==MayResiduate || i==NoResInfo) (pubres ++ privres) return [mname, show (length resops), show (length nonresops)] printCountResOps :: [String] -> IO () printCountResOps mname = do stats <- mapIO countResOps mname putStrLn $ "Module | Residuating | Non-residuating" mapIO_ (\row -> putStrLn (intercalate "|" row)) stats main :: IO () main = printCountResOps baseModules baseModules :: [String] baseModules = ["Prelude","List","Char"] allBaseModules :: [String] allBaseModules = ["AllSolutions" ,"AnsiCodes" ,"Char" ,"Combinatorial" ,"CPNS" ,"Debug" ,"Dequeue" ,"Directory" ,"Distribution" ,"Either" ,"ErrorState" ,"FileGoodies" ,"FilePath" ,"Findall" ,"FiniteMap" ,"Float" ,"Format" ,"Function" ,"FunctionInversion" ,"GetOpt" ,"Global" ,"Integer" ,"IO" ,"IOExts" ,"List" ,"Maybe" ,"NamedSocket" ,"Nat" ,"Prelude" ,"Profile" ,"PropertyFile" ,"Random" ,"Read" ,"ReadNumeric" ,"ReadShowTerm" ,"RedBlackTree" ,"SearchTree" ,"SearchTreeGenerators" ,"SearchTreeTraversal" ,"SetFunctions" ,"SetRBT" ,"ShowS" ,"Socket" ,"Sort" ,"State" ,"System" ,"TableRBT" ,"Time" ,"Traversal" ,"Unsafe" ,"ValueSequence" ] curry-tools-v3.3.0/cpm/vendor/cass/examples/Rev.curry000066400000000000000000000003171377556325500226750ustar00rootroot00000000000000append :: [a] -> [a] -> [a] append [] ys = ys append (x:xs) ys = x : append xs ys rev :: [a] -> [a] rev [] = [] rev (x:xs) = append (rev xs) [x] main :: Int -> Int -> [Int] main x y = rev [x .. y] curry-tools-v3.3.0/cpm/vendor/cass/examples/RootReplacedTest.curry000066400000000000000000000005151377556325500253640ustar00rootroot00000000000000-- Tests for the RootReplaced analysis -- -- Runt test with: -- > cass RootReplaced RootReplacedTest.curry loop = loop --> root replacements: [loop] --> indicates infinite loop f x = g x --> root replacements: [g,h] g x = h x --> root replacements: [h] h x = k x : [] --> root replacements: [] k x = x --> root replacements: [] curry-tools-v3.3.0/cpm/vendor/cass/examples/UsingCASS.curry000066400000000000000000000010611377556325500236750ustar00rootroot00000000000000--- A simple program to show the usage of the API mode of CASS --- to access the demanded values of the operation Rev.rev: import CASS.Server ( analyzeGeneric ) import Analysis.ProgInfo ( lookupProgInfo ) import Analysis.Demandedness ( demandAnalysis ) demandedArgumentsOf :: String -> String -> IO [Int] demandedArgumentsOf modname fname = do deminfo <- analyzeGeneric demandAnalysis modname >>= return . either id error return $ maybe [] id (lookupProgInfo (modname,fname) deminfo) main :: IO [Int] main = demandedArgumentsOf "Rev" "rev" curry-tools-v3.3.0/cpm/vendor/cass/package.json000066400000000000000000000027141377556325500215260ustar00rootroot00000000000000{ "name": "cass", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "CASS: the Curry Analysis Server System", "category": [ "Analysis" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "cass-analysis" : ">= 3.0.0, < 4.0.0", "containers" : ">= 3.0.0, < 4.0.0", "currypath" : ">= 3.0.0, < 4.0.0", "directory" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0", "flatcurry" : ">= 3.0.0, < 4.0.0", "global" : ">= 3.0.0, < 4.0.0", "io-extra" : ">= 3.0.0, < 4.0.0", "process" : ">= 3.0.0, < 4.0.0", "propertyfile" : ">= 3.0.0, < 4.0.0", "read-legacy" : ">= 3.0.0, < 4.0.0", "redblacktree" : ">= 3.0.0, < 4.0.0", "scc" : ">= 3.0.0, < 4.0.0", "socket" : ">= 3.0.0, < 4.0.0", "xml" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "configModule": "CASS.PackageConfig", "executable": { "name": "cass", "main": "CASS.Main" }, "documentation": { "src-dir": "docs", "main": "main.tex" }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/cass.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/cass/src/000077500000000000000000000000001377556325500200235ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/000077500000000000000000000000001377556325500205545ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/Configuration.curry000066400000000000000000000222451377556325500244560ustar00rootroot00000000000000-------------------------------------------------------------------------- --- This module supports the configuration of the analysis system --- and provides access to some values in Config file. --- --- It also provides an operation to get the port number of --- the analysis server (which is implicitly started if necessary). --- --- @author Michael Hanus --- @version December 2020 -------------------------------------------------------------------------- module CASS.Configuration ( systemBanner, baseDir, docDir, executableName , getServerAddress, updateRCFile, updateCurrentProperty , getFPMethod, getWithPrelude , storeServerPortNumber, removeServerPortNumber, getServerPortNumber , getDefaultPath, waitTime, numberOfWorkers ) where import Curry.Compiler.Distribution ( curryCompiler ) import Data.List ( sort ) import Numeric ( readInt ) import System.Environment ( getEnv ) import System.FilePath ( FilePath, (), (<.>) ) import System.Process import System.Directory import Global import ReadShowTerm import Analysis.Logging ( debugMessage, setDebugLevel ) import CASS.PackageConfig ( packagePath, packageExecutable, packageVersion ) import Data.PropertyFile ( readPropertyFile, updatePropertyFile ) systemBanner :: String systemBanner = let bannerText = "CASS: Curry Analysis Server System (Version " ++ packageVersion ++ " of 27/12/2020 for " ++ curryCompiler ++ ")" bannerLine = take (length bannerText) (repeat '=') in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine --- The base directory of the analysis tool containing all programs --- and documentations. --- It is used to copy the configuration file, to the find executables --- of the server and the workers, and to find the documentation --- of the various analyses. baseDir :: String baseDir = packagePath --- The directory containing the documentations of the various analyses. docDir :: String docDir = baseDir "docs" --- The name of the main executable. Used to start workers in `CASS.Server`. executableName :: String executableName = packageExecutable --- The address of the server when it is connected from the worker clients. getServerAddress :: IO String getServerAddress = return "127.0.0.1" -- run only on local machine -------------------------------------------------------------------------- -- Name of user property file: propertyFileName :: IO String propertyFileName = getHomeDirectory >>= return . ( ".curryanalysisrc") defaultPropertyFileName :: String defaultPropertyFileName = baseDir "curryanalysisrc" --- Install user property file if it does not exist. installPropertyFile :: IO () installPropertyFile = do fname <- propertyFileName pfexists <- doesFileExist fname if pfexists then return () else do copyFile defaultPropertyFileName fname putStrLn ("New analysis configuration file '"++fname++"' installed.") --- Reads the rc file (and try to install a user copy of it if it does not --- exist) and compares the definitions with the default property file --- of the CASS distribution. If the set of variables is different, --- update the rc file of the user with the distribution --- but keep the user's definitions. updateRCFile :: IO () updateRCFile = do hashomedir <- getHomeDirectory >>= doesDirectoryExist if not hashomedir then readPropertiesAndStoreLocally >> return () else do installPropertyFile userprops <- readPropertiesAndStoreLocally distprops <- readPropertyFile defaultPropertyFileName if (rcKeys userprops == rcKeys distprops) then return () else do rcName <- propertyFileName putStrLn $ "Updating \"" ++ rcName ++ "\"..." renameFile rcName $ rcName <.> "bak" copyFile defaultPropertyFileName rcName mapM_ (\ (n, v) -> maybe (return ()) (\uv -> if uv==v then return () else updatePropertyFile rcName n uv) (lookup n userprops)) distprops rcKeys :: [(String, String)] -> [String] rcKeys = sort . map fst --- Reads the user property file or, if it does not exist, --- the default property file of CASS, --- and store the properties in a global variable for next access. readPropertiesAndStoreLocally :: IO [(String,String)] readPropertiesAndStoreLocally = do userpfn <- propertyFileName hasuserpfn <- doesFileExist userpfn props <- readPropertyFile (if hasuserpfn then userpfn else defaultPropertyFileName) writeGlobal currProps (Just props) updateDebugLevel props return props --- Reads the user property file (which must be installed!) --- and store the properties in a global variable for next access. getProperties :: IO [(String,String)] getProperties = readGlobal currProps >>= maybe readPropertiesAndStoreLocally return --- Updates the debug level from the current properties. updateDebugLevel :: [(String,String)] -> IO () updateDebugLevel properties = do let number = lookup "debugLevel" properties case number of Just value -> do case readInt value of [(dl,_)] -> setDebugLevel dl _ -> return () Nothing -> return () --- Global variable to store the current properties. currProps :: Global (Maybe [(String,String)]) currProps = global Nothing Temporary -- Updates a current property. updateCurrentProperty :: String -> String -> IO () updateCurrentProperty pn pv = do currprops <- getProperties let newprops = replaceKeyValue pn pv currprops writeGlobal currProps (Just newprops) updateDebugLevel newprops replaceKeyValue :: Eq a => a -> b -> [(a,b)] -> [(a,b)] replaceKeyValue k v [] = [(k,v)] replaceKeyValue k v ((k1,v1):kvs) = if k==k1 then (k,v):kvs else (k1,v1) : replaceKeyValue k v kvs -------------------------------------------------------------------------- --- Gets the name of file containing the current server port and pid --- ($HOME has to be set) getServerPortFileName :: IO String getServerPortFileName = do homeDir <- getHomeDirectory return $ homeDir++"/.curryanalysis.port" --- Stores the current server port number together with the pid of --- the server process. storeServerPortNumber :: Int -> IO () storeServerPortNumber portnum = do mypid <- getPID serverPortFileName <- getServerPortFileName writeQTermFile serverPortFileName (portnum,mypid) --- Removes the currently stored server port number. removeServerPortNumber :: IO () removeServerPortNumber = getServerPortFileName >>= removeFile readServerPortPid :: IO (Int,Int) readServerPortPid = getServerPortFileName >>= readQTermFile --- Reads the current server port number. If the server is not running, --- it is also started. getServerPortNumber :: IO Int getServerPortNumber = do serverPortFileName <- getServerPortFileName exfile <- doesFileExist serverPortFileName if exfile then do (portnum,pid) <- readServerPortPid flag <- system ("ps -p "++show pid++" > /dev/null") if flag==0 then return portnum else do removeFile serverPortFileName getServerPortNumber else do debugMessage 2 "Starting analysis server..." tcmd <- getTerminalCommand let serverCmd = baseDir++"/cass" if all isSpace tcmd then system ("\""++serverCmd++"\" > /dev/null 2>&1 &") else system (tcmd++" \""++baseDir++"/cass\" &") sleep 1 waitForServerPort serverPortFileName where waitForServerPort serverPortFileName = do exfile <- doesFileExist serverPortFileName if exfile then readServerPortPid >>= return . fst else do debugMessage 2 "Waiting for server start..." sleep 1 waitForServerPort serverPortFileName -------------------------------------------------------------------------- -- Get terminalCommand from Config file getTerminalCommand :: IO String getTerminalCommand = do properties <- getProperties let tcmd = lookup "terminalCommand" properties return (maybe "" id tcmd) -- Get the fixpoint computation method from Config file getFPMethod :: IO String getFPMethod = getProperties >>= return . maybe "simple" id . lookup "fixpoint" -- Get the option to analyze also the prelude from Config file getWithPrelude :: IO String getWithPrelude = getProperties >>= return . maybe "yes" id . lookup "prelude" -- timeout for network message passing: -1 is wait time infinity waitTime :: Int waitTime = -1 -- Default number of workers (if the number is not found in the -- configuration file). defaultWorkers :: Int defaultWorkers=0 --- Gets the default load path from the property file (added at the end --- of CURRYPATH). getDefaultPath :: IO String getDefaultPath = do currypath <- getEnv "CURRYPATH" properties <- getProperties let proppath = lookup "path" properties return $ case proppath of Just value -> if all isSpace value then currypath else if null currypath then value else currypath++':':value Nothing -> currypath -- number of worker threads running at the same time numberOfWorkers :: IO Int numberOfWorkers = do properties <- getProperties let number = lookup "numberOfWorkers" properties case number of Just value -> do case readInt value of [(int,_)] -> return int _ -> return defaultWorkers Nothing -> return defaultWorkers curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/Dependencies.curry000066400000000000000000000216011377556325500242300ustar00rootroot00000000000000----------------------------------------------------------------------- --- Operations to handle dependencies of analysis files. --- --- @author Heiko Hoffmann, Michael Hanus --- @version January 2017 ----------------------------------------------------------------------- module CASS.Dependencies(getModulesToAnalyze,reduceDependencies) where import FlatCurry.Types import FlatCurry.Goodies (progImports) import ReadShowTerm (readQTerm) import System.Directory (doesFileExist,getModificationTime) import Data.Maybe (fromMaybe) import Data.List (delete) import Data.Time(ClockTime) import Analysis.Logging ( debugMessage ) import Analysis.Types import Analysis.ProgInfo import Analysis.Files import CASS.Configuration ( getWithPrelude ) ----------------------------------------------------------------------- --- Compute the modules and their imports which must be analyzed --- w.r.t. a given analysis and main module. --- If the first argument is true, then the analysis is enforced --- (even if analysis information exists). getModulesToAnalyze :: Bool -> Analysis a -> String -> IO [(String,[String])] getModulesToAnalyze enforce analysis moduleName = if isSimpleAnalysis analysis then do ananewer <- isAnalysisFileNewer ananame moduleName return (if ananewer && not enforce then [] else [(moduleName,[])]) else do valid <- isAnalysisValid ananame moduleName if valid && not enforce then do debugMessage 3 ("Analysis file for '"++moduleName++"' up-to-date") return [] else do moduleList <- getDependencyList [moduleName] [] debugMessage 3 ("Complete module list: "++ show moduleList) let impmods = map fst moduleList storeImportModuleList moduleName impmods sourceTimeList <- mapM getSourceFileTime impmods fcyTimeList <- mapM getFlatCurryFileTime impmods anaTimeList <- mapM (getAnaFileTime ananame) impmods let (modulesToDo,modulesUpToDate) = findModulesToAnalyze moduleList anaTimeList sourceTimeList fcyTimeList ([],[]) --debugMessage 3 ("Modules up-to-date: "++ show modulesUpToDate) withprelude <- getWithPrelude let modulesToAnalyze = if enforce then moduleList else if withprelude=="no" then let reduced = reduceDependencies modulesToDo (modulesUpToDate ++ ["Prelude"]) in case reduced of (("Prelude",_):remaining) -> remaining _ -> reduced else reduceDependencies modulesToDo modulesUpToDate debugMessage 3 ("Modules to analyze: " ++ show modulesToAnalyze) return modulesToAnalyze where ananame = analysisName analysis -- Checks whether the analysis file is up-to-date. -- Returns True if the analysis file is newer than the source file -- and the FlatCurry file (if is exists). isAnalysisFileNewer :: String -> String -> IO Bool isAnalysisFileNewer ananame modname = do atime <- getAnaFileTime ananame modname stime <- getSourceFileTime modname ftime <- getFlatCurryFileTime modname return (isAnalysisFileTimeNewer (snd atime) (Just (snd stime)) (snd ftime)) -- Is the analysis file time up-to-date w.r.t. the file times of -- the source file and the FlatCurry file? -- Returns True if the analysis file is newer than the source file -- and the FlatCurry file (if is exists). isAnalysisFileTimeNewer :: Maybe ClockTime -> Maybe ClockTime -> Maybe ClockTime -> Bool isAnalysisFileTimeNewer anatime srctime fcytime = anatime >= srctime && anatime >= fcytime -- Read current import dependencies and checks whether the current analysis -- file is valid, i.e., it is newer than the source and FlatCurry files -- of all (directly and indirectly) imported modules. isAnalysisValid :: String -> String -> IO Bool isAnalysisValid ananame modname = getImportModuleListFile modname >>= maybe (return False) (\importListFile -> do itime <- getModificationTime importListFile stime <- getSourceFileTime modname >>= return . snd if itime>=stime then do implist <- readFile importListFile >>= return . readQTerm sourceTimeList <- mapM getSourceFileTime implist fcyTimeList <- mapM getFlatCurryFileTime implist anaTimeList <- mapM (getAnaFileTime ananame) implist return (all (\ (x,y,z) -> isAnalysisFileTimeNewer x y z) (zip3 (map snd anaTimeList) (map (Just . snd) sourceTimeList) (map snd fcyTimeList))) else return False) --- Gets the list of all modules required by the first module. --- The result is sorted according to their dependencies --- (Prelude first, main module last) getDependencyList :: [String] -> [(String,[String])] -> IO [(String,[String])] getDependencyList [] moddeps = return moddeps getDependencyList (mname:mods) moddeps = maybe (do --debugMessage 3 ("Getting imports of "++ mname) --debugMessage 3 ("Still to do: "++ show mods) imports <- getImports mname getDependencyList (addNewMods mods imports) ((mname,imports):moddeps)) (\ (newmoddeps,imps) -> getDependencyList (addNewMods mods imps) newmoddeps) (lookupAndReorder mname [] moddeps) -- add new modules if they are not already there: addNewMods :: [String] -> [String] -> [String] addNewMods oldmods newmods = oldmods ++ filter (`notElem` oldmods) newmods lookupAndReorder :: String -> [(String, [String])] -> [(String, [String])] -> Maybe ([(String, [String])], [String]) lookupAndReorder _ _ [] = Nothing lookupAndReorder mname list1 ((amod,amodimports):rest) | mname==amod = Just ((amod,amodimports):reverse list1++rest, amodimports) | otherwise = lookupAndReorder mname ((amod,amodimports):list1) rest -- get timestamp of analysis file getAnaFileTime :: String -> String -> IO (String,Maybe ClockTime) getAnaFileTime anaName moduleName = do fileName <- getAnalysisPublicFile moduleName anaName fileExists <- doesFileExist fileName if fileExists then do time <- getModificationTime fileName return (moduleName,Just time) else return (moduleName,Nothing) -- check if analysis result of a module can be loaded or needs to be -- newly analyzed findModulesToAnalyze :: [(String,[String])] -> [(String,Maybe ClockTime)] -> [(String,ClockTime)] -> [(String,Maybe ClockTime)] -> ([(String,[String])],[String]) -> ([(String,[String])],[String]) findModulesToAnalyze [] _ _ _ (modulesToDo,modulesUpToDate) = (reverse modulesToDo, modulesUpToDate) findModulesToAnalyze (m@(mod,imports):ms) anaTimeList sourceTimeList fcyTimeList (modulesToDo,modulesUpToDate) = case (lookup mod anaTimeList) of Just Nothing -> findModulesToAnalyze ms anaTimeList sourceTimeList fcyTimeList ((m:modulesToDo),modulesUpToDate) Just (Just time) -> if checkTime mod time imports anaTimeList sourceTimeList fcyTimeList modulesToDo then findModulesToAnalyze ms anaTimeList sourceTimeList fcyTimeList (modulesToDo,(mod:modulesUpToDate)) else findModulesToAnalyze ms anaTimeList sourceTimeList fcyTimeList ((m:modulesToDo),modulesUpToDate) Nothing -> error "Internal error in AnalysisDependencies.findModulesToAnalyz" -- function to check if result file is up-to-date -- compares timestamp of analysis result file with module source/FlatCurry file -- and with timpestamp of result files of all imported modules checkTime :: String -> ClockTime -> [String] -> [(String,Maybe ClockTime)] -> [(String,ClockTime)] -> [(String,Maybe ClockTime)] -> [(String,[String])] -> Bool checkTime mod time1 [] _ sourceTimeList fcyTimeList _ = isAnalysisFileTimeNewer (Just time1) (lookup mod sourceTimeList) (fromMaybe Nothing (lookup mod fcyTimeList)) checkTime mod time1 (impt:impts) anaTimeList sourceTimeList fcyTimeList resultList = (lookup impt resultList) == Nothing && (Just time1) >= (fromMaybe Nothing (lookup impt anaTimeList)) && checkTime mod time1 impts anaTimeList sourceTimeList fcyTimeList resultList ----------------------------------------------------------------------- -- Remove the module analysis dependencies (first argument) w.r.t. -- a list of modules that are already analyzed (second argument). reduceDependencies :: [(String,[String])] -> [String] -> [(String,[String])] reduceDependencies modulesToDo [] = modulesToDo reduceDependencies modulesToDo (mod:mods) = let modulesToDo2 = map (\ (m,list) -> (m,(delete mod list))) modulesToDo in reduceDependencies modulesToDo2 mods curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/Doc.curry000066400000000000000000000021251377556325500223470ustar00rootroot00000000000000-------------------------------------------------------------------------- --- This module contains operations to deal with the documentation --- of analyses registered in CASS. --- --- @author Michael Hanus --- @version July 2016 -------------------------------------------------------------------------- module CASS.Doc(getAnalysisDoc) where import System.Directory (doesFileExist) import System.FilePath ((), (<.>)) import CASS.Configuration (docDir) -------------------------------------------------------------------------- --- Gets the documentation of an analysis with a registered name. --- Returns `Nothing` if no documentation exist. --- The documentation of an analysis with name AN is usually stored --- in the file `/docs/AN.md`. getAnalysisDoc :: String -> IO (Maybe String) getAnalysisDoc aname = do let docfilename = docDir aname <.> "md" docfileexists <- doesFileExist docfilename if docfileexists then readFile docfilename >>= return . Just else return Nothing -------------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/FlatCurryDependency.curry000066400000000000000000000054431377556325500255620ustar00rootroot00000000000000----------------------------------------------------------------------------- --- A few base functions for analysing type dependencies in FlatCurry programs. --- --- @author Heiko Hoffmann, Michael Hanus --- @version Junes 2017 ----------------------------------------------------------------------------- module CASS.FlatCurryDependency(dependsDirectlyOnTypes,callsDirectly) where import FlatCurry.Types import Data.List ( nub ) import Prelude hiding (empty) import Data.Set.RBTree ( SetRBT, empty, insert, toList, union) --- Return the type constructors occurring in a type declaration. dependsDirectlyOnTypes :: TypeDecl -> [QName] dependsDirectlyOnTypes (Type _ _ _ consDeclList) = nub (concatMap (\ (Cons _ _ _ typeExprs) -> concatMap tconsOf typeExprs) consDeclList) dependsDirectlyOnTypes (TypeSyn _ _ _ typeExpr) = nub (tconsOf typeExpr) dependsDirectlyOnTypes (TypeNew _ _ _ (NewCons _ _ typeExpr)) = nub (tconsOf typeExpr) tconsOf :: TypeExpr -> [QName] tconsOf (TVar _) = [] tconsOf (FuncType a b) = tconsOf a ++ tconsOf b tconsOf (TCons qName texps) = qName : concatMap tconsOf texps tconsOf (ForallType _ te) = tconsOf te ----------------------------------------------------------------------------- -- list of direct dependencies for a function callsDirectly :: FuncDecl -> [QName] callsDirectly fun = toList (snd (directlyDependent fun)) -- set of direct dependencies for a function directlyDependent :: FuncDecl -> (QName,SetRBT QName) directlyDependent (Func f _ _ _ (Rule _ e)) = (f,funcSetOfExpr e) directlyDependent (Func f _ _ _ (External _)) = (f,emptySet) -- Gets the set of all functions (including partially applied functions) -- called in an expression: funcSetOfExpr :: Expr -> SetRBT QName funcSetOfExpr (Var _) = emptySet funcSetOfExpr (Lit _) = emptySet funcSetOfExpr (Comb ct f es) = if isConstructorComb ct then unionMap funcSetOfExpr es else insert f (unionMap funcSetOfExpr es) funcSetOfExpr (Free _ e) = funcSetOfExpr e funcSetOfExpr (Let bs e) = union (unionMap (funcSetOfExpr . snd) bs) (funcSetOfExpr e) funcSetOfExpr (Or e1 e2) = union (funcSetOfExpr e1) (funcSetOfExpr e2) funcSetOfExpr (Case _ e bs) = union (funcSetOfExpr e) (unionMap funcSetOfBranch bs) where funcSetOfBranch (Branch _ be) = funcSetOfExpr be funcSetOfExpr (Typed e _) = funcSetOfExpr e isConstructorComb :: CombType -> Bool isConstructorComb ct = case ct of ConsCall -> True ConsPartCall _ -> True _ -> False unionMap :: (a -> SetRBT QName) -> [a] -> SetRBT QName unionMap f = foldr union emptySet . map f emptySet :: SetRBT QName emptySet = empty leqQName leqQName :: QName -> QName -> Bool leqQName (m1,n1) (m2,n2) = m1++('.':n1) <= m2++('.':n2) curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/Main.curry000066400000000000000000000173721377556325500225400ustar00rootroot00000000000000-------------------------------------------------------------------------- --- This is the main module to start the executable of the analysis system. --- --- @author Michael Hanus --- @version December 2018 -------------------------------------------------------------------------- module CASS.Main ( main ) where import Data.Char ( toLower ) import Data.List ( isPrefixOf, sort ) import Control.Monad ( when, unless ) import System.FilePath ( (), (<.>) ) import System.Process ( exitWith ) import System.Environment ( getArgs ) import System.Console.GetOpt import Numeric ( readNat ) import ReadShowTerm ( readQTerm ) import Analysis.Files ( deleteAllAnalysisFiles ) import Analysis.Logging ( debugMessage ) import CASS.Doc ( getAnalysisDoc ) import CASS.Server import CASS.Configuration import CASS.Registry import CASS.Worker ( startWorker ) import System.CurryPath ( stripCurrySuffix ) --- Main function to start the analysis system. --- With option -s or --server, the server is started on a socket. --- Otherwise, it is started in batch mode to analyze a single module. main :: IO () main = do argv <- getArgs let (funopts, args, opterrors) = getOpt Permute options argv let opts = foldl (flip id) defaultOptions funopts unless (null opterrors) (putStr (unlines opterrors) >> putStr usageText >> exitWith 1) initializeAnalysisSystem when (optHelp opts) (printHelp args >> exitWith 1) when (optDelete opts) (deleteFiles args) when ((optServer opts && not (null args)) || (not (optServer opts) && length args /= 2)) (error "Illegal arguments (try `-h' for help)" >> exitWith 1) when (optWorker opts && length args /= 2) (error "Illegal arguments (try `-h' for help)" >> exitWith 1) mapM_ (\ (k,v) -> updateCurrentProperty k v) (optProp opts) let verb = optVerb opts when (verb >= 0) (updateCurrentProperty "debugLevel" (show verb)) debugMessage 1 systemBanner if optServer opts then mainServer (let p = optPort opts in if p == 0 then Nothing else Just p) else if optWorker opts then startWorker (head args) (readQTerm (args!!1)) else do let [ananame,mname] = args fullananame <- checkAnalysisName ananame putStrLn $ "Computing results for analysis `" ++ fullananame ++ "'" analyzeModuleAsText fullananame (stripCurrySuffix mname) (optAll opts) (optReAna opts) >>= putStrLn where deleteFiles args = case args of [aname] -> do fullaname <- checkAnalysisName aname putStrLn $ "Deleting files for analysis `" ++ fullaname ++ "'" deleteAllAnalysisFiles fullaname exitWith 0 [] -> error "Missing analysis name!" _ -> error "Too many arguments (only analysis name should be given)!" -- Checks whether a given analysis name is a unique abbreviation -- of a registered analysis name and return the registered name. -- Otherwise, raise an error. checkAnalysisName :: String -> IO String checkAnalysisName aname = case matchedNames of [] -> error $ "Unknown analysis name `"++ aname ++ "' " ++ tryCmt [raname] -> return raname (_:_:_) -> error $ "Analysis name `"++ aname ++ "' not unique " ++ tryCmt ++ ":\nPossible names are: " ++ unwords matchedNames where matchedNames = filter (isPrefixOf (map toLower aname) . map toLower) registeredAnalysisNames tryCmt = "(try `-h' for help)" -------------------------------------------------------------------------- -- Representation of command line options. data Options = Options { optHelp :: Bool -- print help? , optVerb :: Int -- verbosity level , optServer :: Bool -- start CASS in server mode? , optWorker :: Bool -- start CASS in worker mode? , optPort :: Int -- port number (if used in server mode) , optAll :: Bool -- show analysis results for all operations? , optReAna :: Bool -- force re-analysis? , optDelete :: Bool -- delete analysis files? , optProp :: [(String,String)] -- property (of ~/.curryanalsisrc) to be set } -- Default command line options. defaultOptions :: Options defaultOptions = Options { optHelp = False , optVerb = -1 , optServer = False , optWorker = False , optPort = 0 , optAll = False , optReAna = False , optDelete = False , optProp = [] } -- Definition of actual command line options. options :: [OptDescr (Options -> Options)] options = [ Option "h?" ["help"] (NoArg (\opts -> opts { optHelp = True })) "print help and exit" , Option "q" ["quiet"] (NoArg (\opts -> opts { optVerb = 0 })) "run quietly (no output)" , Option "v" ["verbosity"] (ReqArg (safeReadNat checkVerb) "") "verbosity/debug level:\n0: quiet (same as `-q')\n1: show worker activity, e.g., timings\n2: show server communication\n3: ...and show read/store information\n4: ...show also stored/computed analysis data\n(default: see debugLevel in ~/.curryanalysisrc)" , Option "a" ["all"] (NoArg (\opts -> opts { optAll = True })) "show-analysis results for all operations\n(i.e., also for non-exported operations)" , Option "r" ["reanalyze"] (NoArg (\opts -> opts { optReAna = True })) "force re-analysis \n(i.e., ignore old analysis information)" , Option "d" ["delete"] (NoArg (\opts -> opts { optDelete = True })) "delete existing analysis results" , Option "s" ["server"] (NoArg (\opts -> opts { optServer = True })) "start analysis system in server mode" , Option "w" ["worker"] (NoArg (\opts -> opts { optWorker = True })) "start analysis system in worker mode" , Option "p" ["port"] (ReqArg (safeReadNat (\n opts -> opts { optPort = n })) "") "port number for communication\n(only for server mode;\n if omitted, a free port number is selected)" , Option "D" [] (ReqArg checkSetProperty "name=v") "set property (of ~/.curryanalysisrc)\n`name' as `v'" ] where safeReadNat opttrans s opts = case readNat s of [(n,"")] -> opttrans n opts _ -> error "Illegal number argument (try `-h' for help)" checkVerb n opts = if n>=0 && n<5 then opts { optVerb = n } else error "Illegal verbosity level (try `-h' for help)" checkSetProperty s opts = let (key,eqvalue) = break (=='=') s in if null eqvalue then error "Illegal property setting (try `-h' for help)" else opts { optProp = optProp opts ++ [(key,tail eqvalue)] } -------------------------------------------------------------------------- -- Printing help: printHelp :: [String] -> IO () printHelp args = if null args then putStrLn $ systemBanner ++ "\n" ++ usageText else do aname <- checkAnalysisName (head args) getAnalysisDoc aname >>= maybe (putStrLn $ "Sorry, no documentation for analysis `" ++ aname ++ "'") putStrLn -- Help text usageText :: String usageText = usageInfo ("Usage: curry analyze \n" ++ " or: curry analyze [-s|--server]\n" ++ " or: curry analyze [-w|--worker] \n") options ++ unlines ("" : "Registered analyses names:" : "(use option `-h ' for more documentation)" : "" : map showAnaInfo (sort registeredAnalysisInfos)) where maxName = foldr1 max (map (length . fst) registeredAnalysisInfos) + 1 showAnaInfo (n,t) = n ++ take (maxName - length n) (repeat ' ') ++ ": " ++ t -------------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/PackageConfig.curry000066400000000000000000000006751377556325500243330ustar00rootroot00000000000000module CASS.PackageConfig where import Curry.Compiler.Distribution ( installDir ) import System.FilePath ( () ) --- Package version as a string. packageVersion :: String packageVersion = "3.0.0" --- Package location. packagePath :: String packagePath = installDir "currytools" "cpm" "vendor" "cass" --- Location of the executable installed by this package. packageExecutable :: String packageExecutable = "" curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/Registry.curry000066400000000000000000000276111377556325500234610ustar00rootroot00000000000000-------------------------------------------------------------------- --- This module collects all analyses in the analysis system. --- --- Each analysis available in the analysis system must be --- registered in the top part of this module. --- --- @author Heiko Hoffmann, Michael Hanus --- @version September 2018 -------------------------------------------------------------------- module CASS.Registry ( functionAnalysisInfos, registeredAnalysisNames, registeredAnalysisInfos , lookupRegAnaWorker, runAnalysisWithWorkers, analyzeMain ) where import FlatCurry.Types import FlatCurry.Goodies(progImports) import System.IO import System.IOExts import Control.Monad import XML import Analysis.Logging (debugMessage) import Analysis.Files (getImports, loadCompleteAnalysis) import Analysis.ProgInfo import Analysis.Types import CASS.Configuration(numberOfWorkers) import CASS.Dependencies(getModulesToAnalyze) import CASS.ServerFunctions(masterLoop) import CASS.WorkerFunctions(analysisClient) -------------------------------------------------------------------- -- Configurable part of this module. -------------------------------------------------------------------- import Analysis.Demandedness import Analysis.Deterministic import Analysis.Groundness import Analysis.HigherOrder import Analysis.Indeterministic import Analysis.RequiredValue import qualified Analysis.RequiredValues as RVS import Analysis.RightLinearity import Analysis.Residuation import Analysis.RootReplaced import Analysis.SensibleTypes import Analysis.SolutionCompleteness import Analysis.Termination import Analysis.TotallyDefined import Analysis.TypeUsage import Analysis.UnsafeModule -------------------------------------------------------------------- --- Each analysis used in our tool must be registered in this list --- together with an operation to show the analysis result as a string. registeredAnalysis :: [RegisteredAnalysis] registeredAnalysis = [cassAnalysis "Functionally defined" functionalAnalysis showFunctional ,cassAnalysis "Overlapping rules" overlapAnalysis showOverlap ,cassAnalysis "Deterministic operations" nondetAnalysis showDet ,cassAnalysis "Depends on non-deterministic operations" nondetDepAnalysis showNonDetDeps ,cassAnalysis "Depends on all non-deterministic operations" nondetDepAllAnalysis showNonDetDeps ,cassAnalysis "Right-linear operations" rlinAnalysis showRightLinear ,cassAnalysis "Solution completeness" solcompAnalysis showSolComplete ,cassAnalysis "Pattern completeness" patCompAnalysis showComplete ,cassAnalysis "Totally defined operations" totalAnalysis showTotally ,cassAnalysis "Indeterministic operations" indetAnalysis showIndet ,cassAnalysis "Demanded arguments" demandAnalysis showDemand ,cassAnalysis "Groundness" groundAnalysis showGround ,cassAnalysis "Non-determinism effects" ndEffectAnalysis showNDEffect ,cassAnalysis "Higher-order datatypes" hiOrdType showOrder ,cassAnalysis "Higher-order constructors" hiOrdCons showOrder ,cassAnalysis "Higher-order functions" hiOrdFunc showOrder ,cassAnalysis "Productive operations" productivityAnalysis showProductivity ,cassAnalysis "Sensible types" sensibleType showSensible ,cassAnalysis "Sibling constructors" siblingCons showSibling ,cassAnalysis "Required value" reqValueAnalysis showAFType ,cassAnalysis "Required value sets" RVS.reqValueAnalysis RVS.showAFType ,cassAnalysis "Residuating operations" residuationAnalysis showResInfo ,cassAnalysis "Root cyclic replacements" rootCyclicAnalysis showRootCyclic ,cassAnalysis "Root replacements" rootReplAnalysis showRootRepl ,cassAnalysis "Terminating operations" terminationAnalysis showTermination ,cassAnalysis "Types in values" typesInValuesAnalysis showTypeNames ,cassAnalysis "Unsafe module" unsafeModuleAnalysis showUnsafe ] -------------------------------------------------------------------- -- Static part of this module follows below -------------------------------------------------------------------- --- This auxiliary operation creates a new program analysis to be used --- by the server/client analysis tool from a given analysis and --- analysis show function. The first argument is a short title for the --- analysis. cassAnalysis :: (Read a, Show a, Eq a) => String -> Analysis a -> (AOutFormat -> a -> String) -> RegisteredAnalysis cassAnalysis title analysis showres = RegAna (analysisName analysis) (isFunctionAnalysis analysis) title (analyzeAsString analysis showres) (analysisClient analysis) --- The type of all registered analysis. --- The components are as follows: --- * the name of the analysis --- * is this a function analysis? --- * a long meaningful title of the analysis --- * the operation used by the server to distribute analysis work --- to the clients --- * the worker operation to analyze a list of modules data RegisteredAnalysis = RegAna String Bool String (String -> Bool -> [Handle] -> Maybe AOutFormat -> IO (Either (ProgInfo String) String)) ([String] -> IO ()) regAnaName :: RegisteredAnalysis -> String regAnaName (RegAna n _ _ _ _) = n regAnaInfo :: RegisteredAnalysis -> (String,String) regAnaInfo (RegAna n _ t _ _) = (n,t) regAnaFunc :: RegisteredAnalysis -> Bool regAnaFunc (RegAna _ fa _ _ _) = fa regAnaServer :: RegisteredAnalysis -> (String -> Bool -> [Handle] -> Maybe AOutFormat -> IO (Either (ProgInfo String) String)) regAnaServer (RegAna _ _ _ a _) = a regAnaWorker :: RegisteredAnalysis -> ([String] -> IO ()) regAnaWorker (RegAna _ _ _ _ a) = a --- Names of all registered analyses. registeredAnalysisNames :: [String] registeredAnalysisNames = map regAnaName registeredAnalysis --- Names and titles of all registered analyses. registeredAnalysisInfos :: [(String,String)] registeredAnalysisInfos = map regAnaInfo registeredAnalysis --- Names and titles of all registered function analyses. functionAnalysisInfos :: [(String,String)] functionAnalysisInfos = map regAnaInfo (filter regAnaFunc registeredAnalysis) lookupRegAna :: String -> [RegisteredAnalysis] -> Maybe RegisteredAnalysis lookupRegAna _ [] = Nothing lookupRegAna aname (ra@(RegAna raname _ _ _ _) : ras) = if aname==raname then Just ra else lookupRegAna aname ras -- Look up a registered analysis server with a given analysis name. lookupRegAnaServer :: String -> (String -> Bool -> [Handle] -> Maybe AOutFormat -> IO (Either (ProgInfo String) String)) lookupRegAnaServer aname = maybe (\_ _ _ _ -> return (Right ("unknown analysis: "++aname))) regAnaServer (lookupRegAna aname registeredAnalysis) -- Look up a registered analysis worker with a given analysis name. lookupRegAnaWorker :: String -> ([String] -> IO ()) lookupRegAnaWorker aname = maybe (const (return ())) regAnaWorker (lookupRegAna aname registeredAnalysis) -------------------------------------------------------------------- -- Run an analysis with a given name on a given module with a list -- of workers identified by their handles and return the analysis results. runAnalysisWithWorkers :: String -> AOutFormat -> Bool -> [Handle] -> String -> IO (Either (ProgInfo String) String) runAnalysisWithWorkers ananame aoutformat enforce handles moduleName = (lookupRegAnaServer ananame) moduleName enforce handles (Just aoutformat) -- Run an analysis with a given name on a given module with a list -- of workers identified by their handles but do not load analysis results. runAnalysisWithWorkersNoLoad :: String -> [Handle] -> String -> IO () runAnalysisWithWorkersNoLoad ananame handles moduleName = () <$ (lookupRegAnaServer ananame) moduleName False handles Nothing --- Generic operation to analyze a module. --- The parameters are the analysis, the show operation for analysis results, --- the name of the main module to be analyzed, --- a flag indicating whether the (re-)analysis should be enforced, --- the handles for the workers, --- and a flag indicating whether the analysis results should be loaded --- and returned (if the flag is false, the result contains the empty --- program information). --- An error occurred during the analysis is returned as `(Right ...)`. analyzeAsString :: (Read a, Show a) => Analysis a -> (AOutFormat->a->String) -> String -> Bool -> [Handle] -> Maybe AOutFormat -> IO (Either (ProgInfo String) String) analyzeAsString analysis showres modname enforce handles mbaoutformat = do analyzeMain analysis modname handles enforce (mbaoutformat /= Nothing) >>= return . either (Left . mapProgInfo (showres aoutformat)) Right where aoutformat = maybe AText id mbaoutformat --- Generic operation to analyze a module. --- The parameters are the analysis, the name of the main module --- to be analyzed, the handles for the workers, --- a flag indicating whether the (re-)analysis should be enforced, --- and a flag indicating whether the analysis results should be loaded --- and returned (if the flag is false, the result contains the empty --- program information). --- An error occurred during the analysis is returned as `(Right ...)`. analyzeMain :: (Read a, Show a) => Analysis a -> String -> [Handle] -> Bool -> Bool -> IO (Either (ProgInfo a) String) analyzeMain analysis modname handles enforce load = do let ananame = analysisName analysis debugMessage 2 ("Start analysis: "++modname++"/"++ananame) modulesToDo <- getModulesToAnalyze enforce analysis modname let numModules = length modulesToDo workresult <- if numModules==0 then return Nothing else do when (numModules>1) $ debugMessage 1 ("Number of modules to be analyzed: " ++ show numModules) prepareCombinedAnalysis analysis modname (map fst modulesToDo) handles numworkers <- numberOfWorkers if numworkers>0 then do debugMessage 2 "Starting master loop" masterLoop handles [] ananame modname modulesToDo [] else analyzeLocally ananame (map fst modulesToDo) result <- maybe (if load then do debugMessage 3 ("Reading analysis of: "++modname) loadCompleteAnalysis ananame modname >>= return . Left else return (Left emptyProgInfo)) (return . Right) workresult debugMessage 4 ("Result: " ++ either showProgInfo id result) return result -- Analyze a module and all its imports locally without worker processes. analyzeLocally :: String -> [String] -> IO (Maybe String) analyzeLocally ananame modules = do debugMessage 3 ("Local analysis of: "++ananame++"/"++show modules) (lookupRegAnaWorker ananame) modules -- run client return Nothing -- Perform the first analysis part of a combined analysis -- so that their results are available for the main analysis. prepareCombinedAnalysis:: Analysis a -> String -> [String] -> [Handle] -> IO () prepareCombinedAnalysis analysis moduleName depmods handles = if isCombinedAnalysis analysis then if isSimpleAnalysis analysis then do -- the directly imported interface information might be required... importedModules <- getImports moduleName mapM_ (\basename -> mapM_ (runAnalysisWithWorkersNoLoad basename handles) (importedModules++[moduleName])) baseAnaNames else -- for a dependency analysis, the information of all implicitly -- imported modules might be required: mapM_ (\baseaname -> mapM_ (runAnalysisWithWorkersNoLoad baseaname handles) depmods) baseAnaNames else return () where baseAnaNames = baseAnalysisNames analysis -------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/Server.curry000066400000000000000000000334401377556325500231140ustar00rootroot00000000000000-------------------------------------------------------------------------- --- This is the main module of the analysis server. --- It provides operations to initialize the server system, --- start the server on a socket, or use the analysis server --- by other Curry applications. --- --- @author Heiko Hoffmann, Michael Hanus --- @version December 2020 -------------------------------------------------------------------------- module CASS.Server (mainServer, initializeAnalysisSystem, analyzeModuleAsText , analyzeModuleForBrowser, analyzeFunctionForBrowser , analyzeGeneric, analyzePublic, analyzeInterface ) where import Numeric ( readNat ) import ReadShowTerm ( readQTerm, showQTerm ) import Data.Char ( isSpace ) import Control.Monad ( unless ) import System.CurryPath ( runModuleAction ) import System.Directory import System.FilePath import System.IO import System.Process ( system, sleep ) import System.Environment import Analysis.Logging ( debugMessage ) import Analysis.ProgInfo import Analysis.Types ( Analysis, AOutFormat(..) ) import FlatCurry.Types ( QName ) import Network.Socket ( Socket(..), listenOn, listenOnFresh , close, waitForSocketAccept ) import CASS.Configuration import CASS.Registry import CASS.ServerFormats import CASS.ServerFunctions(WorkerMessage(..)) -- Messages to communicate with the analysis server from external programs. data AnalysisServerMessage = GetAnalysis | AnalyzeModule String String String Bool | AnalyzeEntity String String String String | StopServer | SetCurryPath String | ParseError --- Initializations to be done when the system is started. initializeAnalysisSystem :: IO () initializeAnalysisSystem = updateRCFile --- Start the analysis server on a socket. mainServer :: Maybe Int -> IO () mainServer mbport = do putStrLn "Start Server" (port1,socket1) <- maybe listenOnFresh (\p -> listenOn p >>= \s -> return (p,s)) mbport putStrLn ("Server Port: "++show port1) storeServerPortNumber port1 getDefaultPath >>= setEnv "CURRYPATH" numworkers <- numberOfWorkers if numworkers>0 then do serveraddress <- getServerAddress (workerport,workersocket) <- listenOnFresh debugMessage 2 ("SERVER: port to workers: "++show workerport) handles <- startWorkers numworkers workersocket serveraddress workerport [] serverLoop socket1 handles close workersocket else serverLoop socket1 [] --- Run the analysis system and show the analysis results in standard textual --- representation. --- If the third argument is true, all operations are shown, --- otherwise only the interface operations. --- The fourth argument is a flag indicating whether the --- (re-)analysis should be enforced. --- Note that, before its first use, the analysis system must be initialized --- by 'initializeAnalysisSystem'. analyzeModuleAsText :: String -> String -> Bool -> Bool -> IO String analyzeModuleAsText ananame mname optall enforce = analyzeProgram ananame enforce AText mname >>= return . formatResult mname "Text" Nothing (not optall) --- Run the analysis system to show the analysis results in the BrowserGUI. --- Note that, before its first use, the analysis system must be initialized --- by 'initializeAnalysisSystem'. analyzeModuleForBrowser :: String -> String -> AOutFormat -> IO [(QName,String)] analyzeModuleForBrowser ananame mname aoutformat = analyzeProgram ananame False aoutformat mname >>= return . either pinfo2list (const []) where pinfo2list pinfo = let (pubinfo,privinfo) = progInfo2Lists pinfo in pubinfo++privinfo --- Run the analysis system to show the analysis result of a single function --- in the BrowserGUI. --- Note that before its first use, the analysis system must be initialized --- by 'initializeAnalysisSystem'. analyzeFunctionForBrowser :: String -> QName -> AOutFormat -> IO String analyzeFunctionForBrowser ananame qn@(mname,_) aoutformat = do analyzeProgram ananame False aoutformat mname >>= return . either (maybe "" id . lookupProgInfo qn) (const "") --- Analyze a given program (i.e., a module possibly prefixed with a --- directory name) for a given analysis result format. --- The third argument is a flag indicating whether the --- (re-)analysis should be enforced. --- Note that before its first use, the analysis system must be initialized --- by 'initializeAnalysisSystem'. analyzeProgram :: String -> Bool -> AOutFormat -> String -> IO (Either (ProgInfo String) String) analyzeProgram ananame enforce aoutformat progname = runModuleAction (analyzeModule ananame enforce aoutformat) progname --- Analyze a complete module for a given analysis result format. --- The second argument is a flag indicating whether the --- (re-)analysis should be enforced. --- Note that before its first use, the analysis system must be initialized --- by 'initializeAnalysisSystem'. analyzeModule :: String -> Bool -> AOutFormat -> String -> IO (Either (ProgInfo String) String) analyzeModule ananame enforce aoutformat modname = do getDefaultPath >>= setEnv "CURRYPATH" numworkers <- numberOfWorkers if numworkers>0 then do serveraddress <- getServerAddress (port,socket) <- listenOnFresh handles <- startWorkers numworkers socket serveraddress port [] result <- runAnalysisWithWorkers ananame aoutformat enforce handles modname stopWorkers handles close socket return result else runAnalysisWithWorkers ananame aoutformat enforce [] modname --- Start the analysis system with a particular analysis. --- The analysis must be a registered one if workers are used. --- If it is a combined analysis, the base analysis must be also --- a registered one. --- Returns either the analysis information or an error message. analyzeGeneric :: (Read a, Show a) => Analysis a -> String -> IO (Either (ProgInfo a) String) analyzeGeneric analysis moduleName = do initializeAnalysisSystem let (mdir,mname) = splitFileName moduleName getDefaultPath >>= setEnv "CURRYPATH" curdir <- getCurrentDirectory unless (mdir==".") $ setCurrentDirectory mdir numworkers <- numberOfWorkers aresult <- if numworkers>0 then do serveraddress <- getServerAddress (port,socket) <- listenOnFresh handles <- startWorkers numworkers socket serveraddress port [] result <- analyzeMain analysis mname handles False True stopWorkers handles close socket return result else analyzeMain analysis mname [] False True setCurrentDirectory curdir return aresult --- Start the analysis system with a given analysis to compute properties --- of a module interface. --- The analysis must be a registered one if workers are used. --- If it is a combined analysis, the base analysis must be also --- a registered one. --- Returns either the analysis information or an error message. analyzePublic :: (Read a, Show a) => Analysis a -> String -> IO (Either (ProgInfo a) String) analyzePublic analysis moduleName = analyzeGeneric analysis moduleName >>= return . either (Left . publicProgInfo) Right --- Start the analysis system with a given analysis to compute properties --- of a module interface. --- The analysis must be a registered one if workers are used. --- If it is a combined analysis, the base analysis must be also --- a registered one. analyzeInterface :: (Read a, Show a) => Analysis a -> String -> IO (Either [(QName,a)] String) analyzeInterface analysis moduleName = analyzeGeneric analysis moduleName >>= return . either (Left . publicListFromProgInfo) Right -------------------------------------------------------------------------- -- start a number of workers at server start startWorkers:: Int -> Socket -> String -> Int -> [Handle] -> IO [Handle] startWorkers number workersocket serveraddress workerport handles = do if number>0 then do debugMessage 4 ("Number:"++(show number)) let command = unwords [ executableName, " --worker " , serveraddress, show workerport, "&" ] debugMessage 4 ("system command: "++command) system command debugMessage 4 ("Wait for socket accept for client "++show number) connection <- waitForSocketAccept workersocket waitTime debugMessage 4 ("Socket accept for client "++show number) case connection of Just (_,handle) -> do startWorkers (number-1) workersocket serveraddress workerport (handle:handles) Nothing -> do putStrLn ("startWorkers: connection error worker "++(show number)) startWorkers (number-1) workersocket serveraddress workerport handles else return handles -- stop all workers at server stop stopWorkers :: [Handle] -> IO () stopWorkers [] = return () stopWorkers (handle:whandles) = do hPutStrLn handle (showQTerm StopWorker) hClose handle stopWorkers whandles -------------------------------------------------------------------------- -- server loop to answer analysis requests over network serverLoop :: Socket -> [Handle] -> IO () serverLoop socket1 whandles = do --debugMessage 3 "SERVER: serverLoop" connection <- waitForSocketAccept socket1 waitTime case connection of Just (_,handle) -> serverLoopOnHandle socket1 whandles handle Nothing -> do putStrLn "serverLoop: connection error: time out in waitForSocketAccept" sleep 1 serverLoop socket1 whandles --- Reads a line from an input handle and returns it. hGetLineUntilEOF :: Handle -> IO String hGetLineUntilEOF h = do eof <- hIsEOF h if eof then return "" else do c <- hGetChar h if c=='\n' then return "" else do cs <- hGetLineUntilEOF h return (c:cs) serverLoopOnHandle :: Socket -> [Handle] -> Handle -> IO () serverLoopOnHandle socket1 whandles handle = do eof <- hIsEOF handle if eof then do hClose handle debugMessage 2 "SERVER connection: eof" serverLoop socket1 whandles else do string <- hGetLineUntilEOF handle debugMessage 2 ("SERVER got message: "++string) let force = False case parseServerMessage string of ParseError -> do sendServerError handle ("Illegal message received: "++string) serverLoopOnHandle socket1 whandles handle GetAnalysis -> do sendServerResult handle showAnalysisNamesAndFormats serverLoopOnHandle socket1 whandles handle AnalyzeModule ananame outForm modname public -> catch (runAnalysisWithWorkers ananame AText force whandles modname >>= return . formatResult modname outForm Nothing public >>= sendResult) sendAnalysisError AnalyzeEntity ananame outForm modname functionName -> catch (runAnalysisWithWorkers ananame AText force whandles modname >>= return . formatResult modname outForm (Just functionName) False >>= sendResult) sendAnalysisError SetCurryPath path -> do setEnv "CURRYPATH" path changeWorkerPath path whandles sendServerResult handle "" serverLoopOnHandle socket1 whandles handle StopServer -> do stopWorkers whandles sendServerResult handle "" hClose handle close socket1 putStrLn "Stop Server" removeServerPortNumber where sendResult resultstring = do debugMessage 4 ("formatted result:\n"++resultstring) sendServerResult handle resultstring serverLoopOnHandle socket1 whandles handle sendAnalysisError err = do sendServerError handle ("ERROR in analysis server: "++ show err) serverLoopOnHandle socket1 whandles handle -- Send a server result in the format "ok \n" where -- is the number of lines of the . sendServerResult :: Handle -> String -> IO () sendServerResult handle resultstring = do let resultlines = lines resultstring hPutStrLn handle ("ok " ++ show (length resultlines)) hPutStr handle (unlines resultlines) hFlush handle -- Send a server error in the format "error \n". sendServerError :: Handle -> String -> IO () sendServerError handle errstring = do debugMessage 1 errstring hPutStrLn handle ("error "++errstring) hFlush handle -- Inform the worker threads about a given changed library search path changeWorkerPath :: String -> [Handle] -> IO () changeWorkerPath _ [] = return () changeWorkerPath path (handle:whandles) = do hPutStrLn handle (showQTerm (ChangePath path)) changeWorkerPath path whandles -- parse incoming message for type of request parseServerMessage :: String -> AnalysisServerMessage parseServerMessage message = case words message of [] -> ParseError w:ws -> case w of "GetAnalysis" -> GetAnalysis "AnalyzeModule" -> case ws of s1:s2:s3:[] -> checkFormat s2 $ AnalyzeModule s1 s2 s3 False _ -> ParseError "AnalyzeInterface" -> case ws of s1:s2:s3:[] -> checkFormat s2 $ AnalyzeModule s1 s2 s3 True _ -> ParseError "AnalyzeFunction" -> case ws of s1:s2:s3:s4:[] -> checkFormat s2 $ AnalyzeEntity s1 s2 s3 s4 _ -> ParseError "AnalyzeTypeConstructor" -> case ws of s1:s2:s3:s4:[] -> checkFormat s2 $ AnalyzeEntity s1 s2 s3 s4 _ -> ParseError "AnalyzeDataConstructor" -> case ws of s1:s2:s3:s4:[] -> checkFormat s2 $ AnalyzeEntity s1 s2 s3 s4 _ -> ParseError "SetCurryPath" -> case ws of s:[] -> SetCurryPath s _ -> ParseError "StopServer" -> StopServer _ -> ParseError where checkFormat fmt msg = if fmt `elem` serverFormats then msg else ParseError --- Show all analysis names and formats. showAnalysisNamesAndFormats :: String showAnalysisNamesAndFormats = unlines (concatMap (\an -> map ((an++" ")++) serverFormats) registeredAnalysisNames) curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/ServerFormats.curry000066400000000000000000000053341377556325500244510ustar00rootroot00000000000000-------------------------------------------------------------------- --- This module defines the various output formats offered by the --- anlysis server. --- --- @author Heiko Hoffmann, Michael Hanus --- @version January 2017 -------------------------------------------------------------------- module CASS.ServerFormats(serverFormats,formatResult) where import Analysis.ProgInfo import FlatCurry.Types ( QName, showQNameInModule ) import Data.List ( sortBy ) import XML -------------------------------------------------------------------- --- The supported formats of the analysis server: serverFormats :: [String] serverFormats = ["XML","CurryTerm","Text"] --- Format an analysis result in different formats. --- The arguments are the module name, the output format (see 'serverFormats'), --- `(Just n)` if not the complete module but the result for entity `n` --- should only be shown, and a flag which is true if only the interface --- information should be shown. formatResult :: String -> String -> Maybe String -> Bool -> (Either (ProgInfo String) String) -> String formatResult _ outForm _ _ (Right err) = let errMsg = "ERROR in analysis: " ++ err in if outForm == "XML" then showXmlDoc (xml "error" [xtxt errMsg]) else errMsg -- Format a single program entity result: formatResult moduleName outForm (Just name) _ (Left pinfo) = let lookupResult = lookupProgInfo (moduleName,name) pinfo in case lookupResult of Nothing -> ("ERROR "++name++" not found in "++moduleName) Just value -> case outForm of "CurryTerm" -> value "Text" -> value "XML" -> showXmlDoc (xml "result" [xtxt value]) _ -> error "Internal error ServerFormats.formatResult" -- Format a complete module: formatResult moduleName outForm Nothing public (Left pinfo) = case outForm of "CurryTerm" -> show entities "Text" -> formatAsText moduleName entities "XML" -> let (pubxml,privxml) = progInfo2XML pinfo in showXmlDoc (xml "results" (pubxml ++ if public then [] else privxml)) _ -> error "Internal error ServerFormats.formatResult" where entities = let (pubents,privents) = progInfo2Lists pinfo in if public then pubents else sortBy (\ (qf1,_) (qf2,_) -> qf1<=qf2) (pubents++privents) -- Format a list of analysis results as a string (lines of analysis results). formatAsText :: String -> [(QName,String)] -> String formatAsText moduleName = unlines . map (\ (qf,r) -> showQNameInModule moduleName qf ++ " : " ++ r) -------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/ServerFunctions.curry000066400000000000000000000121071377556325500250020ustar00rootroot00000000000000------------------------------------------------------------------------ --- Implementation of the analysis computations on the server side --- --- @author Heiko Hoffmann, Michael Hanus --- @version December 2018 ------------------------------------------------------------------------ -- analysis computations on the server side module CASS.ServerFunctions where import System.IO ( Handle(..), hClose, hFlush, hGetLine, hPutStrLn , hWaitForInput, hWaitForInputs ) import System.Process ( system, sleep ) import System.Directory ( doesFileExist, getModificationTime ) import Data.Maybe ( fromMaybe ) import Data.List ( delete ) import Data.Time ( ClockTime ) import XML ( showXmlDoc, xml ) import ReadShowTerm ( readQTerm, showQTerm ) import FlatCurry.Types ( QName ) import FlatCurry.Goodies ( progImports ) import Analysis.Logging ( debugMessage ) import Analysis.Types import Analysis.ProgInfo import CASS.Dependencies import CASS.Configuration ( waitTime ) data WorkerMessage = Task String String | ChangePath String | StopWorker -- Master loop for communication with workers -- Argument 1: handles for workers that are currently free -- Argument 2: handles for workers that are currently busy -- Argument 3: the analysis name -- Argument 4: the name of the main module -- Argument 5: the modules to be analyzed (with their dependencies) -- Argument 6: names of modules that are ready be to analyzed (since their -- imports are already analyzed) -- Result: Nothing (in case of successful work) or (Just ) masterLoop :: [Handle] -> [Handle] -> String -> String -> [(String,[String])] -> [String] -> IO (Maybe String) masterLoop _ [] _ _ [] [] = do debugMessage 2 "Master loop: terminated" return Nothing masterLoop _ (b:busyWorker) ananame mainModule [] [] = do debugMessage 2 "Master loop: waiting for worker result" inputHandle <- hWaitForInputs (b:busyWorker) waitTime if inputHandle/=0 then return (Just "No input from any worker received") else do let handle = b input <- hGetLine handle debugMessage 2 ("Master loop: got message: "++input) let Task ananame2 moduleName2 = readQTerm input if ananame==ananame2 && moduleName2==mainModule then return Nothing else return (Just "Received analysis does not match requested analysis") masterLoop idleWorker busyWorker ananame mainModule modulesToDo@(_:_) [] = do debugMessage 3 ("Master loop: modules to do: "++(showQTerm modulesToDo)) let modulesToDo2 = filter ((not . null) . snd) modulesToDo waitList = map fst (filter (null . snd) modulesToDo) if null waitList then do debugMessage 2 "Master loop: waiting for workers to finish" inputHandle <- hWaitForInputs busyWorker waitTime if inputHandle<0 then return (Just "No input from any worker received") else do let handle = busyWorker !! inputHandle input <- hGetLine handle debugMessage 2 ("Master loop: got message: "++input) let Task ananame2 moduleName2 = readQTerm input if ananame==ananame2 then do let modulesToDo3 = reduceDependencies modulesToDo2 [moduleName2] busyWorker2= deleteIndex inputHandle busyWorker masterLoop (handle:idleWorker) busyWorker2 ananame mainModule modulesToDo3 waitList else return (Just "Received analysis does not match requested analysis type") else masterLoop idleWorker busyWorker ananame mainModule modulesToDo2 waitList masterLoop (handle:idleWorker) busyWorker ananame mainModule modulesToDo (modName:waitList) = do debugMessage 2 "Master loop: worker available, send task to a worker..." let newTask = showQTerm (Task ananame modName) hPutStrLn handle newTask hFlush handle debugMessage 2 ("Master loop: send message: "++newTask) masterLoop idleWorker (handle:busyWorker) ananame mainModule modulesToDo waitList masterLoop [] busyWorker ananame mainModule modulesToDo waits@(modName:waitList) = do debugMessage 2 $ "Waiting for worker to analyze modules: "++show waits inputHandle <- hWaitForInputs busyWorker waitTime if inputHandle<0 then return (Just "No input from any worker received") else do let handle = busyWorker !! inputHandle input <- hGetLine handle debugMessage 2 ("Master loop: got message: "++input) let Task _ finishedmodule = readQTerm input newTask = showQTerm (Task ananame modName) hPutStrLn handle newTask hFlush handle debugMessage 2 ("Master loop: send message: "++newTask) let modulesToDo2 = reduceDependencies modulesToDo [finishedmodule] masterLoop [] busyWorker ananame mainModule modulesToDo2 waitList deleteIndex :: Int -> [a] -> [a] deleteIndex _ [] = [] deleteIndex n (x:xs) | n==0 = xs | otherwise = x : deleteIndex (n-1) xs ----------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/Worker.curry000066400000000000000000000040751377556325500231210ustar00rootroot00000000000000------------------------------------------------------------------------ --- Implementation of a worker client to analyze a module --- --- @author Heiko Hoffmann, Michael Hanus --- @version December 2018 ------------------------------------------------------------------------ module CASS.Worker(main, startWorker) where import System.IO ( Handle, hClose, hFlush, hWaitForInput , hPutStrLn, hGetLine ) import System.Environment ( getArgs, setEnv ) import ReadShowTerm ( readQTerm ) import Analysis.Logging ( debugMessage ) import Network.Socket ( connectToSocket ) import CASS.Configuration ( waitTime, getDefaultPath ) import CASS.Registry ( lookupRegAnaWorker ) import CASS.ServerFunctions ( WorkerMessage(..) ) main :: IO () main = do args <- getArgs if length args /= 2 then error "Analysis worker program started with illegal arguments" else startWorker (head args) (readQTerm (args!!1)) startWorker :: String -> Int -> IO () startWorker host port = do debugMessage 2 ("start analysis worker on port " ++ show port) getDefaultPath >>= setEnv "CURRYPATH" handle <- connectToSocket host port worker handle -- communication loop worker :: Handle -> IO () worker handle = do gotInput <- hWaitForInput handle waitTime if gotInput then do input <- hGetLine handle debugMessage 3 ("input: "++input) case readQTerm input of Task ananame moduleName -> do debugMessage 1 ("Start task: "++ananame++" for "++moduleName) -- Run the analysis worker for the given analysis and module: (lookupRegAnaWorker ananame) [moduleName] debugMessage 1 ("Finished task: "++ananame++" for "++moduleName) debugMessage 3 ("Output: "++input) hPutStrLn handle input hFlush handle worker handle ChangePath path -> do setEnv "CURRYPATH" path worker handle StopWorker -> do debugMessage 2 "Stop worker" hClose handle return () else return () curry-tools-v3.3.0/cpm/vendor/cass/src/CASS/WorkerFunctions.curry000066400000000000000000000436641377556325500250210ustar00rootroot00000000000000-------------------------------------------------------------------------- --- Operations to implement the client workers. --- In particular, it contains some simple fixpoint computations. --- --- @author Heiko Hoffmann, Michael Hanus --- @version November 2020 -------------------------------------------------------------------------- module CASS.WorkerFunctions where import Prelude import Data.List ( partition ) import Data.Maybe ( fromJust ) import System.CPUTime ( getCPUTime ) import System.IOExts import Analysis.Files import Analysis.Logging ( debugMessage, debugString ) import Analysis.Types ( Analysis(..), isSimpleAnalysis, isCombinedAnalysis , analysisName, startValue) import Analysis.ProgInfo ( ProgInfo, combineProgInfo, emptyProgInfo , publicProgInfo, lookupProgInfo, lists2ProgInfo , equalProgInfo, publicListFromProgInfo, showProgInfo ) import Data.Map as Map import FlatCurry.Types import FlatCurry.Files import FlatCurry.Goodies import Data.SCC ( scc ) import Data.Set.RBTree as Set ( SetRBT, member, empty, insert, null ) import CASS.Configuration import CASS.FlatCurryDependency ( callsDirectly, dependsDirectlyOnTypes ) ----------------------------------------------------------------------- -- Datatype to store already read ProgInfos for modules. type ProgInfoStore a = [(String,ProgInfo a)] newProgInfoStoreRef :: IO (IORef (ProgInfoStore _)) newProgInfoStoreRef = newIORef [] ----------------------------------------------------------------------- --- Analyze a list of modules (in the given order) with a given analysis. --- The analysis results are stored in the corresponding analysis result files. analysisClient :: (Eq a, Show a, Read a) => Analysis a -> [String] -> IO () analysisClient analysis modnames = do store <- newIORef [] fpmethod <- getFPMethod mapM_ (analysisClientWithStore store analysis fpmethod) modnames analysisClientWithStore :: (Eq a, Show a, Read a) => IORef (ProgInfoStore a) -> Analysis a -> String -> String -> IO () analysisClientWithStore store analysis fpmethod moduleName = do prog <- readNewestFlatCurry moduleName withprelude <- getWithPrelude let progimports = progImports prog importList = if withprelude=="no" then filter (/="Prelude") progimports else progimports ananame = analysisName analysis importInfos <- if isSimpleAnalysis analysis then return emptyProgInfo else getInterfaceInfosWS store (analysisName analysis) importList debugString 1 $ "Analysis time for " ++ ananame ++ "/" ++ moduleName ++ ": " starttime <- getCPUTime startvals <- getStartValues analysis prog result <- if isCombinedAnalysis analysis then execCombinedAnalysis analysis prog importInfos startvals moduleName fpmethod else runAnalysis analysis prog importInfos startvals fpmethod storeAnalysisResult ananame moduleName result stoptime <- getCPUTime debugMessage 1 $ show (stoptime-starttime) ++ " msecs" loadinfos <- readIORef store writeIORef store ((moduleName,publicProgInfo result):loadinfos) -- Loads analysis results for a list of modules where already read results -- are stored in an IORef. getInterfaceInfosWS :: Read a => IORef (ProgInfoStore a) -> String -> [String] -> IO (ProgInfo a) getInterfaceInfosWS _ _ [] = return emptyProgInfo getInterfaceInfosWS store anaName (mod:mods) = do loadinfos <- readIORef store modInfo <- maybe (loadAndStoreAnalysis loadinfos) return (Prelude.lookup mod loadinfos) modsInfo <- getInterfaceInfosWS store anaName mods return (combineProgInfo modInfo modsInfo) where loadAndStoreAnalysis loadinfos = do info <- loadPublicAnalysis anaName mod writeIORef store ((mod,info):loadinfos) return info ----------------------------------------------------------------------- --- Compute the start (bottom) values for a dependency analysis. getStartValues :: Analysis a -> Prog -> IO [(QName,a)] getStartValues analysis prog = if isSimpleAnalysis analysis then return [] else do let startvals = case analysis of DependencyFuncAnalysis _ _ _ -> map (\func->(funcName func,startValue analysis)) (progFuncs prog) CombinedDependencyFuncAnalysis _ _ _ _ _ -> map (\func->(funcName func,startValue analysis)) (progFuncs prog) DependencyTypeAnalysis _ _ _ -> map (\typeDecl->(typeName typeDecl,startValue analysis)) (progTypes prog) CombinedDependencyTypeAnalysis _ _ _ _ _ -> map (\typeDecl->(typeName typeDecl,startValue analysis)) (progTypes prog) _ -> error "Internal error in WorkerFunctions.getStartValues" return startvals --- Compute a ProgInfo from a given list of infos for each function name w.r.t. --- a given program. funcInfos2ProgInfo :: Prog -> [(QName,a)] -> ProgInfo a funcInfos2ProgInfo prog infos = lists2ProgInfo $ map2 (\fdecl -> let fname = funcName fdecl in (fname, fromJust (Prelude.lookup fname infos))) (partition isVisibleFunc (progFuncs prog)) --- Compute a ProgInfo from a given list of infos for each type name w.r.t. --- a given program. typeInfos2ProgInfo :: Prog -> [(QName,a)] -> ProgInfo a typeInfos2ProgInfo prog infos = lists2ProgInfo $ map2 (\tdecl -> let tname = typeName tdecl in (tname, fromJust (Prelude.lookup tname infos))) (partition isVisibleType (progTypes prog)) map2 :: (a -> b) -> ([a], [a]) -> ([b], [b]) map2 f (xs,ys) = (map f xs, map f ys) --- Update a given value list (second argument) w.r.t. new values given --- in the first argument list. updateList :: Eq a => [(a,b)] -> [(a,b)] -> [(a,b)] updateList [] oldList = oldList updateList ((key,newValue):newList) oldList = updateList newList (updateValue (key,newValue) oldList) updateValue :: Eq a => (a,b) -> [(a,b)] -> [(a,b)] updateValue _ [] = [] updateValue (key1,newValue) ((key2,value2):list) = if key1==key2 then (key1,newValue):list else (key2,value2):(updateValue (key1,newValue) list) ----------------------------------------------------------------------- execCombinedAnalysis :: Eq a => Analysis a -> Prog -> ProgInfo a -> [(QName,a)] -> String -> String -> IO (ProgInfo a) execCombinedAnalysis analysis prog importInfos startvals moduleName fpmethod = case analysis of CombinedSimpleFuncAnalysis _ ananame _ runWithBaseAna -> do anaFunc <- runWithBaseAna moduleName runAnalysis (SimpleFuncAnalysis ananame anaFunc) prog importInfos startvals fpmethod CombinedSimpleTypeAnalysis _ ananame _ runWithBaseAna -> do anaFunc <- runWithBaseAna moduleName runAnalysis (SimpleTypeAnalysis ananame anaFunc) prog importInfos startvals fpmethod CombinedDependencyFuncAnalysis _ ananame _ startval runWithBaseAna -> do anaFunc <- runWithBaseAna moduleName runAnalysis (DependencyFuncAnalysis ananame startval anaFunc) prog importInfos startvals fpmethod CombinedDependencyTypeAnalysis _ ananame _ startval runWithBaseAna -> do anaFunc <- runWithBaseAna moduleName runAnalysis (DependencyTypeAnalysis ananame startval anaFunc) prog importInfos startvals fpmethod _ -> error "Internal error in WorkerFunctions.execCombinedAnalysis" ----------------------------------------------------------------------- --- Run an analysis but load default values (e.g., for external operations) --- before and do not analyse the operations or types for these defaults. runAnalysis :: Eq a => Analysis a -> Prog -> ProgInfo a -> [(QName,a)] -> String -> IO (ProgInfo a) runAnalysis analysis prog importInfos startvals fpmethod = do deflts <- loadDefaultAnalysisValues (analysisName analysis) (progName prog) let defaultFuncs = updProgFuncs (filter (\fd -> funcName fd `elem` map fst deflts)) prog definedFuncs = updProgFuncs (filter (\fd -> funcName fd `notElem` map fst deflts)) prog defaultTypes = updProgTypes (filter (\fd -> typeName fd `elem` map fst deflts)) prog definedTypes = updProgTypes (filter (\fd -> typeName fd `notElem` map fst deflts)) prog let (progWithoutDefaults,defaultproginfo) = case analysis of SimpleFuncAnalysis _ _ -> (definedFuncs, funcInfos2ProgInfo defaultFuncs deflts) SimpleTypeAnalysis _ _ -> (definedTypes, typeInfos2ProgInfo defaultTypes deflts) SimpleConstructorAnalysis _ _ -> -- there are no external constructors if Prelude.null deflts then (prog,emptyProgInfo) else error "SimpleConstructorAnalysis with default values!" DependencyFuncAnalysis _ _ _ -> (definedFuncs, funcInfos2ProgInfo defaultFuncs deflts) DependencyTypeAnalysis _ _ _ -> (definedTypes, typeInfos2ProgInfo defaultTypes deflts) SimpleModuleAnalysis _ _ -> if Prelude.null deflts then (definedFuncs, emptyProgInfo) else error defaultNotEmptyError DependencyModuleAnalysis _ _ -> if Prelude.null deflts then (definedFuncs, emptyProgInfo) else error defaultNotEmptyError _ -> error "Internal error in WorkerFunctions.runAnalysis" let result = executeAnalysis analysis progWithoutDefaults (combineProgInfo importInfos defaultproginfo) startvals fpmethod return $ combineProgInfo defaultproginfo result where defaultNotEmptyError = "Default analysis information for analysis '" ++ analysisName analysis ++ "' and module '" ++ progName prog ++ "' not empty!" --- Executes an anlysis on a given program w.r.t. an imported ProgInfo --- and some start values (for dependency analysis). --- The fixpoint iteration method to be applied is passed as the last argument. executeAnalysis :: Eq a => Analysis a -> Prog -> ProgInfo a -> [(QName,a)] -> String -> ProgInfo a -- The results of a module analysis for module `m` are encoded as -- a `ProgInfo` with a single entry for the qualified name `m.m`. executeAnalysis (SimpleModuleAnalysis _ anaFunc) prog _ _ _ = let pname = progName prog in lists2ProgInfo ([((pname,pname), anaFunc prog)], []) executeAnalysis (DependencyModuleAnalysis _ anaFunc) prog impproginfos _ _ = let pname = progName prog importinfos = map (\ (qn,a) -> (fst qn,a)) (publicListFromProgInfo impproginfos) in lists2ProgInfo ([((pname,pname), anaFunc prog importinfos)], []) executeAnalysis (SimpleFuncAnalysis _ anaFunc) prog _ _ _ = (lists2ProgInfo . map2 (\func -> (funcName func, anaFunc func)) . partition isVisibleFunc . progFuncs) prog executeAnalysis (SimpleTypeAnalysis _ anaFunc) prog _ _ _ = (lists2ProgInfo . map2 (\typ -> (typeName typ,anaFunc typ)) . partition isVisibleType . progTypes) prog executeAnalysis (SimpleConstructorAnalysis _ anaFunc) prog _ _ _ = (lists2ProgInfo . map2 (\ (cdecl,tdecl) -> (consName cdecl, anaFunc cdecl tdecl)) . partition isVisibleCons . concatMap (\t -> map (\c -> (c,t)) (consDeclsOfType t)) . progTypes) prog where isVisibleCons (consDecl,_) = consVisibility consDecl == Public executeAnalysis (DependencyFuncAnalysis _ _ anaFunc) prog importInfos startvals fpmethod = case fpmethod of "simple" -> let declsWithDeps = map2 addCalledFunctions (partition isVisibleFunc (progFuncs prog)) startinfo = funcInfos2ProgInfo prog startvals in simpleIteration anaFunc funcName declsWithDeps importInfos startinfo "wlist" -> let declsWithDeps = map addCalledFunctions (progFuncs prog) in funcInfos2ProgInfo prog $ toList $ wlIteration anaFunc funcName declsWithDeps [] (Set.empty (<)) importInfos (fromList startvals) "wlistscc" -> let declsWithDeps = map addCalledFunctions (progFuncs prog) -- compute strongly connected components w.r.t. func dependencies: sccDecls = scc ((:[]) . funcName . fst) snd declsWithDeps in funcInfos2ProgInfo prog $ toList $ foldr (\scc sccstartvals -> wlIteration anaFunc funcName scc [] (Set.empty (<)) importInfos sccstartvals) (fromList startvals) (reverse sccDecls) _ -> error unknownFixpointMessage executeAnalysis (DependencyTypeAnalysis _ _ anaType) prog importInfos startvals fpmethod = case fpmethod of "simple" -> let declsWithDeps = map2 addUsedTypes (partition isVisibleType (progTypes prog)) startinfo = typeInfos2ProgInfo prog startvals in simpleIteration anaType typeName declsWithDeps importInfos startinfo "wlist" -> let declsWithDeps = map addUsedTypes (progTypes prog) in typeInfos2ProgInfo prog $ toList $ wlIteration anaType typeName declsWithDeps [] (Set.empty (<)) importInfos (fromList startvals) "wlistscc" -> let declsWithDeps = map addUsedTypes (progTypes prog) -- compute strongly connected components w.r.t. type dependencies: sccDecls = scc ((:[]) . typeName . fst) snd declsWithDeps in typeInfos2ProgInfo prog $ toList $ foldr (\scc sccstartvals -> wlIteration anaType typeName scc [] (Set.empty (<)) importInfos sccstartvals) (fromList startvals) (reverse sccDecls) _ -> error unknownFixpointMessage -- These cases are handled elsewhere: executeAnalysis (CombinedSimpleFuncAnalysis _ _ _ _) _ _ _ _ = error "Internal error in WorkerFunctions.executeAnalysis" executeAnalysis (CombinedSimpleTypeAnalysis _ _ _ _) _ _ _ _ = error "Internal error in WorkerFunctions.executeAnalysis" executeAnalysis (CombinedDependencyFuncAnalysis _ _ _ _ _) _ _ _ _ = error "Internal error in WorkerFunctions.executeAnalysis" executeAnalysis (CombinedDependencyTypeAnalysis _ _ _ _ _) _ _ _ _ = error "Internal error in WorkerFunctions.executeAnalysis" unknownFixpointMessage :: String unknownFixpointMessage = "Unknown value for 'fixpoint' in configuration file!" --- Add the directly called functions to each function declaration. addCalledFunctions :: FuncDecl -> (FuncDecl,[QName]) addCalledFunctions func = (func, callsDirectly func) --- Add the directly used type constructors to each type declaration. addUsedTypes :: TypeDecl -> (TypeDecl,[QName]) addUsedTypes tdecl = (tdecl, dependsDirectlyOnTypes tdecl) --- Gets all constructors of datatype declaration. consDeclsOfType :: TypeDecl -> [ConsDecl] consDeclsOfType (Type _ _ _ consDecls) = consDecls consDeclsOfType (TypeSyn _ _ _ _) = [] consDeclsOfType (TypeNew _ _ _ (NewCons qn vis te)) = [Cons qn 1 vis [te]] ----------------------------------------------------------------------- --- Fixpoint iteration to compute analysis information. The arguments are: --- * analysis operation --- * operation to get name of a declaration --- * list of public and private declarations together with their direct deps --- * ProgInfo for imported entities --- * current ProgInfo --- Result: fixpoint ProgInfo simpleIteration :: Eq a => (t -> [(QName,a)] -> a) -> (t -> QName) -> ([(t,[QName])],[(t,[QName])]) -> ProgInfo a -> ProgInfo a -> ProgInfo a simpleIteration analysis nameOf declsWithDeps importInfos currvals = let completeProgInfo = combineProgInfo currvals importInfos newvals = map2 (\ (decl,calls) -> (nameOf decl, analysis decl (map (\qn -> (qn,fromJust -- information must known! (lookupProgInfo qn completeProgInfo))) calls))) declsWithDeps newproginfo = lists2ProgInfo newvals in if equalProgInfo currvals newproginfo then currvals else simpleIteration analysis nameOf declsWithDeps importInfos newproginfo wlIteration :: (Eq a, Eq b) => (a -> [(QName,b)] -> b) -> (a -> QName) -> [(a,[QName])] -> [(a,[QName])] -> SetRBT QName -> ProgInfo b -> Map QName b -> Map QName b --wlIteration analysis nameOf declsToDo declsDone changedEntities -- importInfos currvals wlIteration analysis nameOf [] alldecls changedEntities importInfos currvals = if Set.null changedEntities then currvals -- no todos, no changed values, so we are done: else -- all declarations processed, compute todos for next round: let (declsToDo,declsDone) = partition (\ (_,calls) -> any (`Set.member` changedEntities) calls) alldecls in wlIteration analysis nameOf declsToDo declsDone (Set.empty (<)) importInfos currvals -- process a single declaration: wlIteration analysis nameOf (decldeps@(decl,calls):decls) declsDone changedEntities importInfos currvals = let decname = nameOf decl lookupVal qn = maybe (fromJust (Map.lookup qn currvals)) id (lookupProgInfo qn importInfos) oldval = lookupVal decname newval = analysis decl (map (\qn -> (qn, lookupVal qn)) calls) in if oldval==newval then wlIteration analysis nameOf decls (decldeps:declsDone) changedEntities importInfos currvals else wlIteration analysis nameOf decls (decldeps:declsDone) (Set.insert decname changedEntities) importInfos (Map.adjust (const newval) decname currvals) --------------------------------------------------------------------- -- Auxiliaries isVisibleFunc :: FuncDecl -> Bool isVisibleFunc funcDecl = funcVisibility funcDecl == Public isVisibleType :: TypeDecl -> Bool isVisibleType typeDecl = typeVisibility typeDecl == Public --------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cdbi/000077500000000000000000000000001377556325500172045ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/cdbi/LICENSE000066400000000000000000000027351377556325500202200ustar00rootroot00000000000000Copyright (c) 2017, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/cdbi/README.md000066400000000000000000000014271377556325500204670ustar00rootroot00000000000000cdbi: Type-safe database programming ==================================== This package contains libraries to support type-safe database programming. [This paper](http://dx.doi.org/10.4204/EPTCS.234.8) contains a description of the basic ideas behind these libraries. Since the current implementation is based on the [SQLite](https://www.sqlite.org/) database system, it must be installed together with the command line interface `sqlite3`. This can be done in a Ubuntu distribution by sudo apt-get install sqlite3 Usually, it is not necessary to use these libraries directly. Instead, one can use the Curry preprocessor to formulate type-safe SQL queries which are translated into calls to these libraries. -------------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cdbi/package.json000066400000000000000000000023141377556325500214720ustar00rootroot00000000000000{ "name": "cdbi", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Libraries for type-safe database programming", "category": [ "Database" ], "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "csv" : ">= 3.0.0, < 4.0.0", "directory" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0", "global" : ">= 3.0.0, < 4.0.0", "io-extra" : ">= 3.0.0, < 4.0.0", "process" : ">= 3.0.0, < 4.0.0", "read-legacy": ">= 3.0.0, < 4.0.0", "time" : ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Database.ERD", "Database.CDBI.Connection", "Database.CDBI.Criteria", "Database.CDBI.Description", "Database.CDBI.ER", "Database.CDBI.QueryTypes" ], "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "license": "BSD-3-Clause", "licenseFile": "LICENSE", "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/cdbi.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/cdbi/src/000077500000000000000000000000001377556325500177735ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/cdbi/src/Database/000077500000000000000000000000001377556325500214775ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/cdbi/src/Database/CDBI/000077500000000000000000000000001377556325500222005ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/cdbi/src/Database/CDBI/Connection.curry000066400000000000000000000604731377556325500253770ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- This module defines basis data types and functions for accessing --- database systems using SQL. Currently, only SQLite3 is supported, --- but this is easy to extend. It also provides execution of SQL-Queries --- with types. Allowed datatypes for these queries are defined and --- the conversion to standard SQL-Queries is provided. --- --- @author Mike Tallarek, Michael Hanus --- ---------------------------------------------------------------------------- module Database.CDBI.Connection ( -- Basis types and operations SQLValue(..), SQLType(..), SQLResult, fromSQLResult, printSQLResults , DBAction, DBError (..), DBErrorKind (..), Connection (..) -- DBActions , runDBAction, runInTransaction, returnDB, failDB, (>+), (>+=) , executeRaw, execute, select , executeMultipleTimes, getColumnNames, valueToString -- Connections , connectSQLite, disconnect, writeConnection , begin, commit, rollback, setForeignKeyCheck , runWithDB ) where import Data.Time import Data.Char ( isDigit ) import Data.Function ( on ) import Data.List ( init, insertBy, intercalate, isInfixOf, isPrefixOf , nub, tails, (\\) ) import System.IO ( Handle, hPutStrLn, hGetLine, hFlush, hClose, stderr ) import System.Process ( system ) import Control.Monad ( when, unless ) import ReadShowTerm ( readQTerm, readsQTerm, showQTerm ) import Global ( Global, GlobalSpec(..), global , readGlobal, writeGlobal ) import System.IOExts ( connectToCommand ) import Text.CSV ( readCSV ) infixl 1 >+, >+= --- Global flag for database debug mode. --- If on, all communication with database is written to stderr. dbDebug :: Bool dbDebug = False --- If this flag is true, the SQL output will be requested in csv format --- (which can be parsed faster than the line mode output). dbWithCSVMode :: Bool dbWithCSVMode = True -- ----------------------------------------------------------------------------- -- Datatypes -- ----------------------------------------------------------------------------- --- The result of SQL-related actions. It is either a `DBError` or some value. type SQLResult a = Either DBError a --- Gets the value of an 'SQLResult'. If there is no result value --- but a database error, the error is raised. fromSQLResult :: SQLResult a -> a fromSQLResult (Left err) = error $ "Database connection error: " ++ show err fromSQLResult (Right val) = val --- Print an 'SQLResult' list, i.e., print either the 'DBError' --- or the list of result elements. printSQLResults :: Show a => SQLResult [a] -> IO () printSQLResults (Left err) = putStrLn $ show err printSQLResults (Right res) = mapM_ print res --- `DBError`s are composed of an `DBErrorKind` and a `String` --- describing the error more explicitly. data DBError = DBError DBErrorKind String deriving (Eq,Show) --- The different kinds of errors. data DBErrorKind = TableDoesNotExist | ParameterError | ConstraintViolation | SyntaxError | NoLineError | LockedDBError | UnknownError deriving (Eq,Show) --- Data type for SQL values, used during the communication with the database. data SQLValue = SQLString String | SQLInt Int | SQLFloat Float | SQLChar Char | SQLBool Bool | SQLDate ClockTime | SQLNull deriving Show --- Type identifiers for `SQLValue`s, necessary to determine the type --- of the value a column should be converted to. data SQLType = SQLTypeString | SQLTypeInt | SQLTypeFloat | SQLTypeChar | SQLTypeBool | SQLTypeDate -- ----------------------------------------------------------------------------- -- Database actions with types -- ----------------------------------------------------------------------------- --- A `DBAction` takes a connection and performs an IO action that --- returns a `SQLResult a` value. data DBAction a = DBAction (Connection -> IO (SQLResult a)) --- Runs a `DBAction` on a connection. runDBAction :: DBAction a -> Connection -> IO (SQLResult a) runDBAction (DBAction a) conn = a conn --- Run a `DBAction` as a transaction. --- In case of an error, it will rollback all changes, otherwise, the changes --- are committed. The transaction is also checked whether foreign key errors --- have been introduced so that a transaction which introduces --- foreign key errors will never be committed. --- @param act - The `DBAction` --- @param conn - The `Connection` to the database on which the transaction --- shall be executed. runInTransaction :: DBAction a -> DBAction a runInTransaction act = DBAction $ \conn -> do res <- flip runDBAction conn $ do begin kes1 <- getForeignKeyErrors r <- act kes2 <- getForeignKeyErrors return (kes2 \\ kes1, r) case res of Left err -> runDBAction rollback conn >> return (Left err) Right (newkes,ares) -> if null newkes then runDBAction commit conn >> return (Right ares) else runDBAction rollback conn >> return (Left (DBError ConstraintViolation (showFKErrors newkes))) where showFKErrors = intercalate "," . nub . concatMap (\row -> if length row < 3 then [] else [row!!0 ++ "/" ++ row!!2]) --- Connects two `DBAction`s. --- When executed this function will execute the first `DBAction` --- and then execute the second applied to the result of the first action. --- A database error will stop either action. --- @param x - The `DBAction` that will be executed first --- @param y - The `DBAction` hat will be executed afterwards --- @return A `DBAction` that wille execute both `DBAction`s. --- The result is the result of the second `DBAction`. (>+=) :: DBAction a -> (a -> DBAction b) -> DBAction b m >+= f = DBAction $ \conn -> do v1 <- runDBAction m conn case v1 of Right val -> runDBAction (f val) conn Left err -> return (Left err) --- Connects two `DBAction`s but ignore the result of the first. (>+) :: DBAction a -> DBAction b -> DBAction b (>+) x y = x >+= (\_ -> y) --- Returns an `SQLResult`. returnDB :: SQLResult a -> DBAction a returnDB r = DBAction $ \_ -> return r --- A failed `DBAction` with a specific error. failDB :: DBError -> DBAction a failDB err = returnDB (Left err) instance Functor DBAction where fmap f x = x >>= \a -> return (f a) instance Applicative DBAction where pure = return a1 <*> a2 = a1 >>= \x -> fmap x a2 --- The `Monad` instance of `DBAction`. instance Monad DBAction where a1 >>= a2 = a1 >+= a2 a1 >> a2 = a1 >+ a2 return x = returnDB (Right x) instance MonadFail DBAction where fail s = returnDB (Left (DBError UnknownError s)) ----------------------------------------------------------------------------- --- Execute a query where the result of the execution is returned. --- @param query - The SQL Query as a String, might have '?' as placeholder --- @param values - A list of SQLValues that replace the '?' placeholder --- @param types - A list of SQLTypes that describe the types of the --- result-tables (e.g. "select * from exampletable" and [SQLTypeInt, --- SQLTypeFloat, SQLTypeString] --- when the table exampletable has three columns of type Int, Float and --- String.) The order of the list has to be the same as the order of the --- columns in the table --- @param conn - A Connection to a database where the query will be executed --- @return A Result with a list of SQLValues which types correspond to --- the SQLType-List that was given as a parameter if the execution was --- successful, otherwise an Error select :: String -> [SQLValue] -> [SQLType] -> DBAction [[SQLValue]] select query values types = executeRaw query (map valueToString values) >+= \a -> returnDB (convertValues a types) --- execute a query without a result --- @param query - The SQL Query as a String, might have '?' as placeholder --- @param values - A list of SQLValues that replace the '?' placeholder --- @param conn - A Connection to a database where the query will be executed --- @return An empty if the execution was successful, otherwise an error execute :: String -> [SQLValue] -> DBAction () execute query values = executeRaw query (map valueToString values) >+ return () --- Executes a query multiple times with different SQLValues without a result --- @param query - The SQL Query as a String, might have '?' as placeholder --- @param values - A list of lists of SQLValues that replace the '?' --- placeholder (one list for every execution) --- @return A void result if every execution was successful, otherwise an --- Error (meaning at least one execution failed). As soon as one --- execution fails, the rest wont be executed. executeMultipleTimes :: String -> [[SQLValue]] -> DBAction () executeMultipleTimes query values = mapM_ (execute query) values -- ----------------------------------------------------------------------------- -- Database connections -- ----------------------------------------------------------------------------- --- Data type for database connections. --- Currently, only connections to a SQLite3 database are supported, --- but other types of connections could easily be added. --- The following functions might need to be re-implemented for other DBs: --- A function to connect to the database, disconnect, writeConnection --- readRawConnectionLine, parseLines, begin, commit, rollback, --- and getColumnNames data Connection = SQLiteConnection Handle --- Connect to a SQLite Database --- @param str - name of the database (e.g. "database.db") --- @return A connection to a SQLite Database connectSQLite :: String -> IO Connection connectSQLite db = do exsqlite3 <- system "which sqlite3 > /dev/null" when (exsqlite3>0) $ error "Database interface `sqlite3' not found. Please install package `sqlite3'!" h <- connectToCommand $ "sqlite3 " ++ db ++ " 2>&1" hPutAndFlush h $ ".mode " ++ if dbWithCSVMode then "csv" else "line" hPutAndFlush h $ ".log " ++ if dbWithCSVMode then "off" else "stdout" -- we increase the timeout to avoid 'OperationalError: database is locked' -- see https://stackoverflow.com/questions/3172929/operationalerror-database-is-locked/3172950 hPutAndFlush h $ ".timeout 10000" return $ SQLiteConnection h --- Disconnect from a database. disconnect :: Connection -> IO () disconnect (SQLiteConnection h) = hClose h hPutAndFlush :: Handle -> String -> IO () hPutAndFlush h s = do when dbDebug $ hPutStrLn stderr ("DB>>> " ++ s) >> hFlush stderr hPutStrLn h s >> hFlush h --- Write a `String` to a `Connection`. writeConnection :: String -> Connection -> IO () writeConnection str (SQLiteConnection h) = hPutAndFlush h str --- Read a line from a `Connection`. readRawConnectionLine :: Connection -> IO String readRawConnectionLine (SQLiteConnection h) = do inp <- hGetLine h >>= return . stripCR when dbDebug $ hPutStrLn stderr ("DB<<< " ++ inp) >> hFlush stderr return inp where -- Remove CR at end-of-line stripCR [] = [] stripCR [c] = if c == '\r' then [] else [c] stripCR (c:cs@(_:_)) = c : stripCR cs --- Begin a transaction. --- Inside a transaction, foreign key constraints are checked. begin :: DBAction () begin = DBAction $ \conn -> do writeConnection "begin;" conn writeConnection "PRAGMA foreign_keys=ON;" conn return (Right ()) --- Commit a transaction. commit :: DBAction () commit = DBAction $ \conn -> do writeConnection "commit;" conn return (Right ()) --- Rollback a transaction. rollback :: DBAction () rollback = DBAction $ \conn -> do writeConnection "rollback;" conn return (Right ()) --- Turn on/off checking of foreign key constraints (SQLite3). setForeignKeyCheck :: Bool -> DBAction () setForeignKeyCheck flag = DBAction $ \conn -> do writeConnection ("PRAGMA foreign_keys=" ++ showFlag ++ ";") conn return (Right ()) where showFlag = if flag then "ON" else "OFF" --- Executes an action dependent on a connection on a database --- by connecting to the datebase. The connection will be kept open --- and re-used for the next action to this database. --- @param str - name of the database (e.g. "database.db") --- @param action - an action parameterized over a database connection --- @return the result of the action runWithDB :: String -> DBAction a -> IO (SQLResult a) runWithDB dbname dbaction = ensureSQLiteConnection dbname >>= runDBAction dbaction --- Executes an action dependent on a connection on a database --- by connecting and disconnecting to the datebase. --- @param str - name of the database (e.g. "database.db") --- @param action - an action parameterized over a database connection --- @return the result of the action runWithDB' :: String -> (Connection -> IO a) -> IO a runWithDB' dbname dbaction = do conn <- connectSQLite dbname result <- dbaction conn disconnect conn return result -- ----------------------------------------------------------------------------- -- Executing SQL statements -- ----------------------------------------------------------------------------- --- Executes an SQL statement. --- The statement may contain '?' placeholders and a list of parameters which --- should be inserted at the respective positions. --- The result is a list of list of strings where every single list --- represents a row of the result. executeRaw :: String -> [String] -> DBAction [[String]] executeRaw query para = case insertParams query para of Left err -> failDB err Right qu -> DBAction $ \conn -> do writeConnection qu conn parseLines conn --- Returns a list with the names of every column in a table --- The parameter is the name of the table. getColumnNames :: String -> DBAction [String] -- SQLite implementation getColumnNames table = DBAction $ \conn -> do writeConnection ("pragma table_info(" ++ table ++ ");") conn result <- parseLines conn case result of Left err -> return (Left err) Right xs -> return (Right (map retrieveColumnNames xs)) where retrieveColumnNames xs = case xs of (_:y:_) -> y _ -> error "Database.CDBI.Connection.getColumnNames: wrong arguments" --- Returns a list of unsatisfisfied foreign key constraints (SQLite). --- In a correct database state, the list should be empty. getForeignKeyErrors :: DBAction [[String]] -- SQLite implementation getForeignKeyErrors = DBAction $ \conn -> do writeConnection ("PRAGMA foreign_key_check;") conn parseLines conn --- Read every output line of a Connection and return a Result with a list --- of lists of strings where every list of strings represents a row. --- NULL-Values have to be empty Strings instead of "NULL", all other --- values should be represented exactly as they are saved in the database parseLines :: Connection -> IO (SQLResult [[String]]) --- SQLite implementation parseLines conn@(SQLiteConnection _) = do random <- getRandom case random of Left err -> return (Left err) Right val -> do writeConnection ("select '" ++ val ++ "';") conn parseSQLOutputUntil val conn --- `getRandom` requests a random number from a SQLite-database. getRandom :: IO (SQLResult String) getRandom = do conn <- ensureSQLiteConnection "" -- connectSQLite "" writeConnection "select hex(randomblob(8));" conn result <- readConnectionLine conn --disconnect conn return result --- Inserts parameters into a SQL query for placeholders denoted by (`?`). --- The parameters are inserted in the order in which they are supplied. --- Will throw error if the number of placeholders isn't equal to the length --- of the list insertParams :: String -> [String] -> SQLResult String insertParams qu xs = if (length xs == (countPlaceholder qu)) then Right (insertParams' qu xs) else Left (DBError ParameterError "Amount of placeholders not equal to length of placeholder-list") where insertParams' sql [] = sql insertParams' sql params@(p:ps) = case sql of "" -> "" ''':'?':''':cs -> p ++ insertParams' cs ps c:cs -> c : insertParams' cs params countPlaceholder qu2 = case qu2 of "" -> 0 ''':'?':''':cs -> 1 + (countPlaceholder cs) _:cs -> countPlaceholder cs --- Reads the current output of SQLite line by line until a specific stop --- string is found. This is necessary because it is otherwise not possible --- to determine the end of the output without blocking. (SQLite function) parseSQLOutputUntil :: String -> Connection -> IO (SQLResult [[String]]) parseSQLOutputUntil = if dbWithCSVMode then parseCSVUntil else parseLinesUntil parseCSVUntil :: String -> Connection -> IO (SQLResult [[String]]) parseCSVUntil stop conn = do output <- readLinesUntil case output of Left err -> return $ Left err Right csvlines -> return $ Right (concatMap readCSV csvlines) where readLinesUntil = do line <- readConnectionLine conn case line of Left err -> return $ Left err Right s -> if s == stop then return $ Right [] else do rest <- readLinesUntil case rest of Left err -> return $ Left err Right ls -> return $ Right (s:ls) parseLinesUntil :: String -> Connection -> IO (SQLResult [[String]]) parseLinesUntil stop conn@(SQLiteConnection _) = next where next = do value <- readConnectionLine conn case value of Left (DBError NoLineError "") -> do rest <- next case rest of Left err -> return $ Left err Right xs -> return $ Right ([]:xs) Left err -> readRawConnectionLine conn >> return (Left err) Right val | val == "index" -> next | val == stop -> return (Right [[]]) | otherwise -> do rest <- next case rest of Left err -> return $ Left err Right ([]:xs) -> return $ Right ([val]:xs) Right ((x:ys):xs) -> return $ Right ((val:(x:ys)):xs) Right [] -> error "Database.CDBI.Connection.parseLinesUntil: wrong arguments" --- Read a line from a SQLite Connection and check if it represents a value readConnectionLine :: Connection -> IO (SQLResult String) readConnectionLine conn = check <$> readRawConnectionLine conn where --- Ensure that a line read from a database connection represents a value. check :: String -> SQLResult String check s = if dbWithCSVMode then checkCSV s else checkLine s checkCSV s | "Error" `isPrefixOf` s = Left (DBError (getErrorKindSQLite s) s) | otherwise = Right s checkLine s | null s = Left (DBError NoLineError "") | "Error" `isPrefixOf` s = Left (DBError (getErrorKindSQLite s) s) | '=' `elem` s = Right (getValue s) | "automatic index on" `isInfixOf` s = Right "index" | otherwise = Left (DBError (getErrorKindSQLite s) s) --- Get the value from a line with a '=' getValue :: String -> String --getValue (_ ++ "= " ++ b) = b --getValue (_ ++ "=") = "" -- alternative implementation to avoid non-deterministic functional patterns: getValue s = if "case" `isInfixOf` s then getCaseValue s else let taileq = tail (snd (break (== '=') s)) in if null taileq then "" else let (' ':val) = taileq in val where getCaseValue str = getValue (readTilEnd str) readTilEnd rest = head (filter (\ls -> "end" `isPrefixOf` ls) (tails rest)) --- Identify the error kind. getErrorKindSQLite :: String -> DBErrorKind getErrorKindSQLite str | "UNIQUE constraint" `isInfixOf` str = ConstraintViolation | "FOREIGN KEY constraint" `isInfixOf` str = ConstraintViolation | "no such table" `isInfixOf` str = TableDoesNotExist | "syntax error" `isInfixOf` str = SyntaxError | "database is locked" `isInfixOf` str = LockedDBError | otherwise = UnknownError -- ----------------------------------------------------------------------------- -- Auxiliary Functions -- ----------------------------------------------------------------------------- -- Converts an SQLValue to its string representation. valueToString :: SQLValue -> String valueToString x = replaceEmptyString $ case x of SQLString a -> "'" ++ encodeStringToSQL a ++ "'" SQLChar a -> "'" ++ encodeStringToSQL [a] ++ "'" SQLNull -> "NULL" SQLDate a -> "'" ++ show (toUTCTime a) ++ "'" SQLInt a -> show a--"'" ++ show a ++ "'" SQLFloat a -> show a --"'" ++ show a ++ "'" SQLBool a -> "'" ++ show a ++ "'" -- Replaces an empty String with "NU'LL" replaceEmptyString :: String -> String replaceEmptyString str = case str of "''" -> "NULL" st -> st -- Converts String representations of SQLValues to their SQLValues -- Every list of strings in the first parameter represents a data-type -- of multiple values -- The list of SQLTypes tells the function what kind of SQLValues should be parsed convertValues :: [[String]] -> [SQLType] -> SQLResult [[SQLValue]] convertValues [] _ = Right [] -- this rule should not be used convertValues (s:str) types = if length s == length types then Right (map (\x -> map convertValue (zip x types)) (s:str)) else if null s then Right [] else Left (DBError ParameterError "Number of returned parameters and types not equal") convertValue :: (String,SQLType) -> SQLValue convertValue (s, SQLTypeString) = if null s then SQLNull else SQLString (decodeStringFromSQL s) convertValue (s, SQLTypeInt) = case reads s of [(a,"")] -> SQLInt a _ -> SQLNull convertValue (s, SQLTypeFloat) = if isFloat s then case readsQTerm s of [] -> SQLNull ((a,_):_) -> SQLFloat a else SQLNull convertValue (s, SQLTypeBool) = case readsQTerm s of [(True,[])] -> SQLBool True [(False,[])] -> SQLBool False _ -> SQLNull convertValue (s, SQLTypeDate) = case readsQTerm s of [(CalendarTime a b c d e f g, [])] -> SQLDate (toClockTime (CalendarTime a b c d e f g)) _ -> SQLNull convertValue ("", SQLTypeChar) = SQLNull convertValue (s:_, SQLTypeChar) = SQLChar s -- Encodes a Curry string into an SQL string which allows an appropriate -- parsing of SQL output values. This is done by: -- 1. Transform the string by applying Curry's `show` operation and removing -- the enclosing apostrophs (i.e., encode all special chars). -- 2. Replacing all apostrophes in the resulting string with double apostrophes -- (this is necessary to transfer the encoded string correctly to SQLite) encodeStringToSQL :: String -> String encodeStringToSQL s = doubleQuote (init (tail (showQTerm s))) where doubleQuote "" = "" doubleQuote (c:cs) | c == ''' = "''" ++ doubleQuote cs | otherwise = c : doubleQuote cs -- Decodes SQL string back into a Curry string into an SQL string. decodeStringFromSQL :: String -> String decodeStringFromSQL s = readQTerm ('"' : s ++ ['"']) -- Does a string represent a Float? isFloat :: String -> Bool isFloat [a] = isDigit a isFloat (a:b:_) = (isDigit a) || (isDigit b && a == '-') isFloat [] = False ----------------------------------------------------------------------------- -- A global value that keeps all open database handles. openDBConnections :: Global [(String,Connection)] openDBConnections = global [] Temporary -- Connect to SQLite database. Either create a new connection -- (and keep it) or re-use a previous connection. ensureSQLiteConnection :: String -> IO Connection ensureSQLiteConnection db = do dbConnections <- readGlobal openDBConnections maybe (addNewConnection dbConnections) return (lookup db dbConnections) where addNewConnection dbConnections = do dbcon <- connectSQLite db writeGlobal openDBConnections $ -- sort against deadlock insertBy ((<=) `on` fst) (db,dbcon) dbConnections return dbcon -- Performs an action on all open database connections. withAllDBConnections :: (Connection -> IO _) -> IO () withAllDBConnections f = readGlobal openDBConnections >>= mapM_ (f . snd) --- Closes all database connections. Should be called when no more --- database access will be necessary. closeDBConnections :: IO () closeDBConnections = do withAllDBConnections disconnect writeGlobal openDBConnections [] ----------------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cdbi/src/Database/CDBI/Criteria.curry000066400000000000000000000416151377556325500250370ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- This module provides datatypes, constructor functions and translation --- functions to specify SQL criteria including options --- (group-by, having, order-by) --- --- @author Mike Tallarek, Julia Krone --- ---------------------------------------------------------------------------- {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module Database.CDBI.Criteria ( Criteria(..), Constraint(..), ColVal(..), GroupBy, Option, Value(..), CValue, CColumn, Condition(..), Specifier(..), emptyCriteria, int, float, char, string, bool, date, col, idVal, colNum, colVal, colValAlt, isNull, isNotNull, equal, (.=.), notEqual, (./=.), greaterThan, (.>.), lessThan, (.<.), greaterThanEqual, (.<=.), lessThanEqual, (.>=.), like, (.~.), between, isIn, (.<->.), toCValue, toCColumn, ascOrder, descOrder, groupBy, having, groupByCol, trCriteria, trConstraint, trCondition, trValue, trColumn,trSpecifier, trOption, sumIntCol, sumFloatCol, countCol, avgIntCol, avgFloatCol, minCol, maxCol, condition, noHave) where import Data.List (intercalate) import Data.Time (ClockTime) import Database.CDBI.Connection (SQLValue (..), SQLType(..), valueToString) import Database.CDBI.Description (Column (..), Table) -- ----------------------------------------------------------------------------- -- Datatypes for constructing SQL criteria -- ----------------------------------------------------------------------------- --- Criterias for queries that can have a constraint and a group-by clause data Criteria = Criteria Constraint (Maybe GroupBy) --- specifier for queries data Specifier = Distinct | All --- datatype to represent order-by statement data Option = AscOrder CValue | DescOrder CValue --- datatype to represent group-by statement data GroupBy = GroupBy CValue GroupByTail --- subtype for additional columns or having-Clause in group-by statement data GroupByTail = Having Condition | GBT CValue GroupByTail | NoHave --- datatype for conditions inside a having-clause data Condition = Con Constraint | Fun String Specifier Constraint | HAnd [Condition] | HOr [Condition] | Neg Condition --- A datatype to compare values. --- Can be either a SQLValue or a Column with an additional --- Integer (rename-number). The Integer is for dealing with renamed --- tables in queries (i.e. Students as 1Students). If the Integer n is 0 --- the column will be named as usual ("Table"."Column"), otherwise it will --- be named "nTable"."Column" in the query This is for being able to do --- complex "where exists" constraints data Value a = Val SQLValue | Col (Column a) Int --- A datatype thats a combination between a Column and a Value --- (Needed for update queries) data ColVal = ColVal CColumn CValue --- Type for columns used inside a constraint. type CColumn = Column () --- Type for values used inside a constraint. type CValue = Value () --- Constraints for queries --- Every constructor with at least one value has a function as a constructor --- and only that function will be exported to assure type-safety --- Most of these are just like the Sql-where-commands Exists needs the --- table-name, an integer and maybe a constraint --- (where exists (select * from table where constraint)) --- The integer n will rename the table if it has a different value than 0 --- (where exists (select * from table as ntable where...)) data Constraint = IsNull CValue | IsNotNull CValue | BinaryRel RelOp CValue CValue | Between CValue CValue CValue | IsIn CValue [CValue] | Not Constraint | And [Constraint] | Or [Constraint] | Exists Table Int Constraint | None data RelOp = Eq | Neq | Lt | Lte | Gt | Gte | Like -- ----------------------------------------------------------------------------- -- Constructor functions -- ----------------------------------------------------------------------------- --- An empty criteria emptyCriteria :: Criteria emptyCriteria = Criteria None Nothing --- Constructor for a Value Val of type Int --- @param i - The value int :: Int -> Value Int int = Val . SQLInt --- Constructor for a Value Val of type Float --- @param i - The value float :: Float -> Value Float float = Val . SQLFloat --- Constructor for a Value Val of type Char --- @param i - The value char :: Char -> Value Char char = Val . SQLChar --- Constructor for a Value Val of type String --- @param i - The value string :: String -> Value String string = Val . SQLString --- Constructor for a Value Val of type Bool --- @param i - The value bool :: Bool -> Value Bool bool = Val . SQLBool --- Constructor for a Value Val of type ClockTime --- @param i - The value date :: ClockTime -> Value ClockTime date = Val . SQLDate --- Constructor for Values of ID-types --- Should just be used internally! idVal :: Int -> Value _ idVal i = Val (SQLInt i) val :: SQLValue -> Value _ val v = (Val v) --- Constructor for a Value Col without a rename-number --- @param c - The column col :: Column a -> Value a col c = Col c 0 --- Constructor for a Value Col with a rename-number --- @param c - The column --- @param n - The rename-number colNum :: Column a -> Int -> Value a colNum c n = Col c n --- A constructor for ColVal needed for typesafety --- @param c - The Column --- @param v - The Value colVal :: Column a -> Value a -> ColVal colVal c v = ColVal (toCColumn c) (toCValue v) --- Alternative ColVal constructor without typesafety --- @param table - The Tablename of the column --- @param cl - The column name --- @param s - The SQLValue colValAlt :: String -> String -> SQLValue -> ColVal colValAlt table cl s = ColVal (toCColumn (Column ("\"" ++ cl ++ "\"") ("\"" ++ table ++ "\".\"" ++ "\"" ++ cl ++ "\""))) (Val s) --- IsNull construnctor --- @param v1 - First Value isNull :: Value a -> Constraint isNull v1 = IsNull (toCValue v1) --- IsNotNull construnctor --- @param v1 - First Value isNotNull :: Value a -> Constraint isNotNull v1 = IsNotNull (toCValue v1) --- Equal construnctor --- @param v1 - First Value --- @param v2 - Second Value equal :: Value a -> Value a -> Constraint equal v1 v2 = BinaryRel Eq (toCValue v1) (toCValue v2) --- Infix Equal (.=.) :: Value a -> Value a -> Constraint (.=.) = equal --- NotEqual construnctor --- @param v1 - First Value --- @param v2 - Second Value notEqual :: Value a -> Value a -> Constraint notEqual v1 v2 = BinaryRel Neq (toCValue v1) (toCValue v2) --- Infix NotEqual (./=.) :: Value a -> Value a -> Constraint (./=.) = notEqual --- GreatherThan construnctor --- @param v1 - First Value --- @param v2 - Second Value greaterThan :: Value a -> Value a -> Constraint greaterThan v1 v2 = BinaryRel Gt (toCValue v1) (toCValue v2) --- Infix GreaterThan (.>.) :: Value a -> Value a -> Constraint (.>.) = greaterThan --- LessThan construnctor --- @param v1 - First Value --- @param v2 - Second Value lessThan :: Value a -> Value a -> Constraint lessThan v1 v2 = BinaryRel Lt (toCValue v1) (toCValue v2) --- Infix LessThan (.<.) :: Value a -> Value a -> Constraint (.<.) = lessThan --- GreaterThanEqual construnctor --- @param v1 - First Value --- @param v2 - Second Value greaterThanEqual :: Value a -> Value a -> Constraint greaterThanEqual v1 v2 = BinaryRel Gte (toCValue v1) (toCValue v2) --- Infix GreaterThanEqual (.>=.) :: Value a -> Value a -> Constraint (.>=.) = greaterThanEqual --- LessThanEqual construnctor --- @param v1 - First Value --- @param v2 - Second Value lessThanEqual :: Value a -> Value a -> Constraint lessThanEqual v1 v2 = BinaryRel Lte (toCValue v1) (toCValue v2) --- Infix LessThanEqual (.<=.) :: Value a -> Value a -> Constraint (.<=.) = lessThanEqual --- Like construnctor --- @param v1 - First Value --- @param v2 - Second Value like :: Value a -> Value a -> Constraint like v1 v2 = BinaryRel Like (toCValue v1) (toCValue v2) --- Infix Like (.~.) :: Value a -> Value a -> Constraint (.~.) = like --- Between construnctor --- @param v1 - First Value --- @param v2 - Second Value --- @param v3 - Third Value between :: Value a -> Value a -> Value a -> Constraint between v1 v2 v3 = Between (toCValue v1) (toCValue v2) (toCValue v3) --- IsIn construnctor --- @param v1 - First Value --- @param xs - List of Values isIn :: Value a -> [Value a] -> Constraint isIn v1 xs = IsIn (toCValue v1) (map toCValue xs) --- Infix IsIn (.<->.) :: Value a -> [Value a] -> Constraint (.<->.) = isIn --- Constructor for the option: Ascending Order by Column --- @param c - The Column that should be ordered by ascOrder :: Value a -> Option ascOrder v = AscOrder (toCValue v) --- Constructor for the option: Descending Order by Column --- @param c - The Column that should be ordered by descOrder :: Value a -> Option descOrder v = DescOrder (toCValue v) ---Constructor for group-by-clause ---@param c - The Column that should be grouped by ---@param gbTail - GroupByTail, i.e. more columns or a having-clause groupBy :: Value a -> GroupByTail -> GroupBy groupBy c gbTail = GroupBy (toCValue c) gbTail --- Constructor to specifiy more than one column for group-by --- @param c - the additional column --- @param gbTail - subsequent part of group-by statement groupByCol :: Value a -> GroupByTail -> GroupByTail groupByCol c gbTail = GBT (toCValue c) gbTail ---Constructor for having condition ---@param con - The condition having :: Condition -> GroupByTail having con = Having con --- Constructor for empty having-Clause noHave :: GroupByTail noHave = NoHave ---Constructor for Condition with just a simple Constraint condition :: Constraint -> Condition condition con = Con con ---Constructor for aggregation function sum for columns of type Int --- having-clauses. ---@param spec - specifier Distinct or All ---@param c - Column that is to be summed up ---@param v - value the result is compared to (has to be of type Int) ---@param op - relating operator sumIntCol :: Specifier -> Value Int -> Value Int -> (Value () -> Value () -> Constraint) -> Condition sumIntCol spec c v op = (Fun "Sum " spec (op (toCValue c) (toCValue v))) --- Constructor for aggregation function sum for columns of type float --- in having-clauses. ---@param spec - specifier Distinct or All ---@param c - Column that is to be summed up ---@param v - value the result is compared to (has to be of type float) ---@param op - relating operator sumFloatCol :: Specifier -> Value Float -> Value Float -> (Value () -> Value () -> Constraint) -> Condition sumFloatCol spec c v op = (Fun "Sum " spec (op (toCValue c) (toCValue v))) --- Constructor for aggregation function avg for columns of type Int --- in having-clauses. ---@param spec - specifier Distinct or All ---@param c - Column that is to be averaged ---@param v - value the result is compared to (has to be of type float) ---@param op - relating operator avgIntCol :: Specifier -> Value Int -> Value Float -> (Value () -> Value () -> Constraint) -> Condition avgIntCol spec c v op = (Fun "Avg " spec (op (toCValue c) (toCValue v))) --- Constructor for aggregation function avg for columns of type float --- in having-clauses. ---@param spec - specifier Distinct or All ---@param c - Column that is to be avaraged ---@param v - value the result is compared to (has to be of type float) ---@param op - relating operator avgFloatCol :: Specifier -> Value Float -> Value Float -> (Value () -> Value () -> Constraint) -> Condition avgFloatCol spec c v op = (Fun "Avg " spec (op (toCValue c) (toCValue v))) ---Constructor for aggregation function count in having-clauses. ---@param spec - specifier Distinct or All ---@param c - Column which elements are to be counted ---@param v - value the result is compared to (has to be of type Int). ---@param op - relating operator countCol :: Specifier -> Value _ -> Value Int -> (Value () -> Value () -> Constraint) -> Condition countCol spec c v op = (Fun "Count " spec (op (toCValue c) (toCValue v))) --- Constructor for aggregation function min in having-clauses. --- @param spec - specifier Distinct or All ---@param c - column the minimal element has to be extracted from ---@param v - value to compare to the minimal value, same type as column ---@param op - operator minCol :: Specifier -> Value a -> Value a -> (Value () -> Value () -> Constraint) -> Condition minCol spec c v op = (Fun "Min " spec (op (toCValue c) (toCValue v))) --- Constructor for aggregation function max in having-clauses. --- @param spec - specifier Distinct or All ---@param c - column the maximal element has to be extracted from ---@param v - value to compare to the maximal value, same type as column ---@param op - operator maxCol :: Specifier -> Value a -> Value a -> (Value () -> Value () -> Constraint) -> Condition maxCol spec c v op = (Fun "Max " spec (op (toCValue c) (toCValue v))) --Convert to UnitType toCColumn :: Column a -> Column () toCColumn (Column s1 s2) = (Column s1 s2) toCValue :: Value a -> CValue toCValue (Col (Column s1 s2) n) = Col (Column s1 s2) n toCValue (Val v1) = Val v1 -- ----------------------------------------------------------------------------- -- Translation of a constraint into a SQL string. -- ----------------------------------------------------------------------------- -- Translate Criteria to a string in a sql-query trCriteria :: Criteria -> String trCriteria crit = case crit of (Criteria None group) -> trGroup group (Criteria c group) -> " where " ++ trConstraint c ++ " " ++ trGroup group -- Translate an Order-by to a string in a sql-query trOption :: [Option] -> String trOption [] = "" trOption (ls@((AscOrder _):_)) = " order by " ++ intercalate ", " (map trOption' ls) trOption (ls@((DescOrder _):_)) = " order by " ++ intercalate ", " (map trOption' ls) trOption' :: Option -> String trOption' (AscOrder v) = trValue v ++ " asc" trOption' (DescOrder v) = trValue v ++ " desc" -- translate a group-by to a string in a sql-query trGroup :: (Maybe GroupBy) -> String trGroup Nothing = "" trGroup (Just (GroupBy cs gbTail)) = " group by " ++ trValue cs ++ trTail gbTail trTail :: GroupByTail -> String trTail (GBT cs gbTail) = ", "++ trValue cs ++ trTail gbTail trTail NoHave = "" trTail (Having cond) = " Having " ++ trCondition cond trCondition :: Condition -> String trCondition (HAnd conds) = intercalate " and " (map trCondition conds) trCondition (HOr conds) = intercalate " or " (map trCondition conds) trCondition (Con cons) = trConstraint cons trCondition (Neg cond) = "(not "++ (trCondition cond)++")" trCondition (Fun fun spec cons) = "("++fun ++ "("++trSpecifier spec ++constr where ('(':'(':constr) = trConstraint cons -- Translate a Constraint to a string in a sql-query trConstraint :: Constraint -> String trConstraint (IsNull v) = paren $ (paren $ trValue v) ++ " is NULL" trConstraint (IsNotNull v) = paren $ (paren $ trValue v) ++ " is not NULL" trConstraint (BinaryRel rel v1 v2) = paren $ (paren $ trValue v1) ++ trRelOp rel ++ trValue v2 trConstraint (Between v1 v2 v3) = paren $ (paren $ trValue v1) ++ " between " ++ trValue v2 ++ " and " ++ trValue v3 trConstraint (IsIn v vs) = paren $ trValue v ++ " in " ++ paren (intercalate ", " $ map trValue vs) trConstraint (Not c) = paren $ "not " ++ trConstraint c trConstraint (And [] ) = "" trConstraint (And cs@(_:_)) = paren $ intercalate " and " (map trConstraint cs) trConstraint (Or [] ) = "" trConstraint (Or cs@(_:_)) = paren $ intercalate " or " (map trConstraint cs) trConstraint (Exists table n cs) = "(exists (select * from '" ++ table ++ "' " ++ (asTable table n) ++ " " ++ (trCriteria (Criteria cs Nothing)) ++ "))" trRelOp :: RelOp -> String trRelOp Eq = " == " trRelOp Neq = " <> " trRelOp Lt = " < " trRelOp Lte = " <= " trRelOp Gt = " > " trRelOp Gte = " >= " trRelOp Like = " like " -- Translate a Value to a String trValue :: Value a -> String trValue (Val v) = valueToString v trValue (Col (Column _ c) n) = trColumn c n -- Translate "Table.Column" to "nTable.Colum" where n is the Integer-Parameter trColumn :: String -> Int -> String trColumn ('"':table_column) n = if n==0 then '"' : table_column else '"' : show n ++ table_column {- trColumn ("\"" ++ table ++ "\"." ++ column) n = case n of 0 -> "\"" ++ table ++ "\"." ++ column m -> "\"" ++ (show m) ++ table ++ "\"." ++ column -} paren :: String -> String paren s = '(' : s ++ ")" -- Create the "as tablename" string asTable :: Table -> Int -> Table asTable table n = case n of 0 -> "" m -> " as '" ++ (show m) ++ table ++ "'" --Translate specifier trSpecifier :: Specifier -> String trSpecifier All = "" trSpecifier Distinct = "Distinct " curry-tools-v3.3.0/cpm/vendor/cdbi/src/Database/CDBI/Description.curry000066400000000000000000000231721377556325500255560ustar00rootroot00000000000000--- This module contains basic datatypes and operations to represent --- a relational data model in a type-safe manner. This representation is --- used by the library `Database.CDBI.ER` to provide type safety --- when working with relational databases. --- The tool `erd2cdbi` generates from an entity-relationship model --- a Curry program that represents all entities and relationships --- by the use of this module. --- --- @author Mike Tallarek, changes by Julia Krone --- ---------------------------------------------------------------------------- {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module Database.CDBI.Description where import Data.Time import Database.CDBI.Connection (SQLType, SQLValue(..)) -- ----------------------------------------------------------------------------- -- Datatypes for describing entities -- ----------------------------------------------------------------------------- --- The datatype EntityDescription is a description of a database entity --- type including the name, the types the entity consists of, a function --- transforming an instance of this entity to a list of SQLValues, a --- second function doing the same but converting the key value always to --- SQLNull to ensure that keys are auto incrementing and a --- function transforming a list of SQLValues to an instance of this entity data EntityDescription a = ED String [SQLType] (a -> [SQLValue]) (a -> [SQLValue]) --for insertion ([SQLValue] -> a) --- Entity-types can be combined (For Example Student and Lecture could be --- combined to Data StuLec = StuLec Student Lecture). If a description for --- this new type is written CDBI can look up that type in the database --- The description is a list of Tuples consisting of a String (The name of --- the entity type that will be combined), a "rename-number" n which will --- rename the table to "table as ntable" and a list of SQLTypes (The types --- that make up that entity type). Furthermore there has to be a function --- that transform a list of SQLValues into this combined type, and two --- functions that transform the combined type into a list of SQLValues, the --- first one for updates, the second one for insertion. --- The list of sqlvalues needs to match what is returned by the database. data CombinedDescription a = CD [(Table, Int, [SQLType])] ([SQLValue] -> a) (a -> [[SQLValue]]) (a -> [[SQLValue]]) -- for insertion --- A type representing tablenames type Table = String --- A datatype representing column names. --- The first string is the simple name of the column (for example the --- column Name of the row Student). The second string is the name of the --- column combined with the name of the row (for example Student.Name). --- These names should always be in quotes (for example "Student"."Name") --- so no errors emerge (the name "Group" for --- example would result in errors if not in quotes). --- Has a phantom-type for the value the column represents. data Column _ = Column String String --- Datatype representing columns for selection. --- This datatype has to be distinguished from type Column which is just for --- definition of conditions. --- The type definition consists of the complete name (including tablename), --- the SQLType of the column --- and two functions for the mapping from SQLValue into the resulttype and --- the other way around data ColumnDescription a = ColDesc String SQLType (a -> SQLValue) (SQLValue -> a) --- A constructor for CombinedDescription. --- @param ed1 - Description of the first Entity-Type that is to be combined --- @param rename1 - The "rename-number" for ed1. If it is zero ed1 will --- not be renamed in queries, otherwise is will be renamed as --- follows: "table as ntable" --- @param ed2 - Description of the second Entity-Type that is to be combined --- @param rename2 - Same as rename1 for ed2 --- @param f - A function that describes how the combined entity is built. --- Takes two entities that make up the combined entity as parameters --- and combines those into the combined entity. combineDescriptions :: EntityDescription a -> Int -> EntityDescription b -> Int -> (a -> b -> c) -> (c -> (a, b)) -> CombinedDescription c combineDescriptions ed1 rename1 ed2 rename2 f1 f2 = CD [(getTable ed1, rename1, getTypes ed1), (getTable ed2, rename2, getTypes ed2)] createFunction1 createFunction2 createFunction3 where createFunction1 xs = f1 ((getToEntity ed1) (take lengthEd1 xs)) ((getToEntity ed2) (drop lengthEd1 xs)) where lengthEd1 = length (getTypes ed1) createFunction2 combEnt = let (ent1, ent2) = f2 combEnt in ((getToValues ed1) ent1) : [(getToValues ed2) ent2] createFunction3 combEnt = let (ent1, ent2) = f2 combEnt in ((getToInsertValues ed1) ent1) : [(getToInsertValues ed2) ent2] --- Adds another ED to an already existing CD. --- @param ed1 - The ED to be added --- @param rename - The "rename-number" --- @param f1 - A function that describes how the combined entity is built. --- Takes the entity that should be added and the combined entity as parameter --- and combines those into a new version of the combined entity. --- @param cd - The already existing CD addDescription :: EntityDescription a -> Int -> (a -> b -> b) -> (b -> a) -> CombinedDescription b -> CombinedDescription b addDescription ed1 rename f1 f2 (CD xs f1' f2' f3') = CD ((getTable ed1, rename, getTypes ed1) : xs) createFunction1 createFunction2 createFunction3 where createFunction1 ys = f1 ((getToEntity ed1) (take lengthEd1 ys)) (f1' (drop lengthEd1 ys)) where lengthEd1 = length (getTypes ed1) createFunction2 combEnt = [(getToValues ed1) (f2 combEnt)] ++ (f2' combEnt) createFunction3 combEnt = [(getToInsertValues ed1) (f2 combEnt)] ++ (f3' combEnt) -- ----------------------------------------------------------------------------- -- Auxiliary Functions -- ----------------------------------------------------------------------------- getTable :: EntityDescription a -> String getTable (ED s _ _ _ _) = s getTypes :: EntityDescription a -> [SQLType] getTypes (ED _ t _ _ _) = t getToValues :: EntityDescription a -> (a -> [SQLValue]) getToValues (ED _ _ f _ _) = f getToInsertValues :: EntityDescription a -> (a -> [SQLValue]) getToInsertValues (ED _ _ _ f _) = f getToEntity :: EntityDescription a -> ([SQLValue] -> a) getToEntity (ED _ _ _ _ f) = f getColumnSimple :: Column a -> String getColumnSimple (Column s _ ) = s getColumnFull :: Column a -> String getColumnFull (Column _ s ) = s getColumnName :: ColumnDescription a -> String getColumnName (ColDesc s _ _ _) = s getColumnTableName :: ColumnDescription a -> String getColumnTableName (ColDesc s _ _ _) = s getColumnTyp :: ColumnDescription a -> SQLType getColumnTyp (ColDesc _ t _ _) = t getColumnValueBuilder :: ColumnDescription a -> (a -> SQLValue) getColumnValueBuilder (ColDesc _ _ f _) = f getColumnValueSelector :: ColumnDescription a -> (SQLValue -> a) getColumnValueSelector (ColDesc _ _ _ f) = f -- Conversion functions from Curry values to SQL values. toValueOrNull :: (a -> SQLValue) -> Maybe a -> SQLValue toValueOrNull _ Nothing = SQLNull toValueOrNull f (Just v) = f v sqlKeyOrNull :: (key -> Int) -> Maybe key -> SQLValue sqlKeyOrNull _ Nothing = SQLNull sqlKeyOrNull key2int (Just k) = SQLInt (key2int k) sqlIntOrNull :: (Maybe Int) -> SQLValue sqlIntOrNull Nothing = SQLNull sqlIntOrNull (Just a) = SQLInt a sqlFloatOrNull :: (Maybe Float) -> SQLValue sqlFloatOrNull Nothing = SQLNull sqlFloatOrNull (Just a) = SQLFloat a sqlCharOrNull :: (Maybe Char) -> SQLValue sqlCharOrNull Nothing = SQLNull sqlCharOrNull (Just a) = SQLChar a sqlStringOrNull :: (Maybe String) -> SQLValue sqlStringOrNull Nothing = SQLNull sqlStringOrNull (Just a) = SQLString a sqlString :: String -> SQLValue sqlString a = SQLString a sqlBoolOrNull :: (Maybe Bool) -> SQLValue sqlBoolOrNull Nothing = SQLNull sqlBoolOrNull (Just a) = SQLBool a sqlDateOrNull :: (Maybe ClockTime) -> SQLValue sqlDateOrNull Nothing = SQLNull sqlDateOrNull (Just a) = SQLDate a -- Conversion functions from SQL values to Curry values. keyOrNothing :: (Int -> key) -> SQLValue -> Maybe key keyOrNothing _ SQLNull = Nothing keyOrNothing keycon (SQLInt k) = Just (keycon k) intOrNothing :: SQLValue -> (Maybe Int) intOrNothing SQLNull = Nothing intOrNothing (SQLInt a) = Just a floatOrNothing :: SQLValue -> (Maybe Float) floatOrNothing SQLNull = Nothing floatOrNothing (SQLFloat a) = Just a charOrNothing :: SQLValue -> (Maybe Char) charOrNothing SQLNull = Nothing charOrNothing (SQLChar a) = Just a stringOrNothing :: SQLValue -> (Maybe String) stringOrNothing SQLNull = Nothing stringOrNothing (SQLString a) = Just a fromStringOrNull :: SQLValue -> String fromStringOrNull SQLNull = "" fromStringOrNull (SQLString a) = a boolOrNothing :: SQLValue -> (Maybe Bool) boolOrNothing SQLNull = Nothing boolOrNothing (SQLBool a) = Just a dateOrNothing :: SQLValue -> (Maybe ClockTime) dateOrNothing SQLNull = Nothing dateOrNothing (SQLDate a) = Just a curry-tools-v3.3.0/cpm/vendor/cdbi/src/Database/CDBI/ER.curry000066400000000000000000000743101377556325500236010ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- This is the main CDBI-module. It provides datatypes and functions to --- do Database-Queries working with Entities (ER-Model) --- --- @author Mike Tallarek, extensions by Julia Krone, Michael Hanus --- ---------------------------------------------------------------------------- {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module Database.CDBI.ER ( -- Database Functions insertEntry, insertEntries, insertEntryCombined, restoreEntries, getEntries, getEntriesCombined, updateEntries, deleteEntries, updateEntry, updateEntryCombined, getColumn, getColumnTuple, getColumnTriple, getColumnFourTuple, getColumnFiveTuple, getColumnSixTuple, getAllEntries, getCondEntries, getEntryWithKey, getEntriesWithColVal, insertNewEntry, deleteEntry, deleteEntryR, showDatabaseKey, readDatabaseKey, saveDBTerms, restoreDBTerms, runQueryOnDB, runTransactionOnDB, runJustTransactionOnDB, --CDBI.Connection DBAction, Connection, SQLResult, printSQLResults, runInTransaction, (>+), (>+=), begin, commit, rollback, connectSQLite, disconnect, setForeignKeyCheck, runWithDB, -- Datatypes EntityDescription, Value, ColumnDescription, Join, SetOp(..), Specifier(..), Table, SingleColumnSelect(..), TupleColumnSelect(..), TripleColumnSelect(..), FourColumnSelect(..), FiveColumnSelect(..), SixColumnSelect(..), TableClause(..), CombinedDescription, combineDescriptions, addDescription, innerJoin, crossJoin, caseThen, sum, avg, minV, maxV, none, count, singleCol, tupleCol, tripleCol, fourCol, fiveCol, sixCol, int, float, char, string, bool, date, col, colNum, colVal, -- CDBI.Criteria Criteria(..), emptyCriteria, Constraint(Exists, Or, And, Not, None), isNull, isNotNull, equal, (.=.), notEqual, (./=.), greaterThan, (.>.), lessThan, (.<.), greaterThanEqual, (.>=.), lessThanEqual, (.<=.), like, (.~.), between, isIn, (.<->.), Option, ascOrder, descOrder, groupBy, groupByCol, having, condition, noHave, Condition(..), sumIntCol, sumFloatCol, countCol, avgIntCol, avgFloatCol, minCol, maxCol, caseResultInt, caseResultFloat, caseResultString, caseResultChar, caseResultBool) where import Data.Char ( isDigit ) import Data.List ( intercalate, nub ) import Data.Time ( ClockTime ) import System.FilePath ( () ) import ReadShowTerm ( showQTerm, readQTermListFile, writeQTermListFile ) import Database.CDBI.Connection import Database.CDBI.Criteria import Database.CDBI.Description import Database.CDBI.QueryTypes -- ----------------------------------------------------------------------------- -- Database functions with Entities -- ----------------------------------------------------------------------------- --- Inserts an entry into the database. --- @param ed - The EntityDescription that describes the entity to be saved --- @param ent - The entry to be inserted --- @return a `DBAction` with a void result insertEntry :: EntityDescription a -> a -> DBAction () insertEntry ed ent = let query = "insert into '" ++ getTable ed ++ "' values("++ questionmarks ed ++");" in execute query ((getToInsertValues ed) ent) --- Inserts several entries into the database. --- @param ed - The EntityDescription that describes the entities to be saved --- @param xs - The list of entries to be inserted --- @return A Result without parameter if saving worked or an Error if there --- was a problem. If one saving operation reports an error, every following --- saving operation will be aborted but every saving operation up to that --- point will be executed. If these executed saving operations should also --- be discarded withTransaction or begin/commit/rollback should be used insertEntries :: EntityDescription a -> [a] -> DBAction () insertEntries ed xs = let query = ("insert into '" ++ getTable ed ++ "' values("++ questionmarks ed ++");") in executeMultipleTimes query (map (getToInsertValues ed) xs) --- Stores entries with their current keys in the database. --- It is an error if entries with the same key are already in the database. --- Thus, this operation is useful only to restore a database with saved data. --- @param en - The EntityDescription that describes the entities to be saved --- @param xs - The list of entries to stored --- @return A Result without parameter if saving worked or an Error if there --- was a problem. If one saving operation reports an error, every following --- saving operation will be aborted but every saving operation up to that --- point will be executed. If these executed saving operations should also --- be discarded withTransaction or begin/commit/rollback should be used restoreEntries :: EntityDescription a -> [a] -> DBAction () restoreEntries en xs = let query = ("insert into '" ++ (getTable en) ++ "' values("++ (questionmarks en) ++");") in executeMultipleTimes query (map (getToValues en) xs) --- Gets entries from the database. --- @param spec - Specifier All or Distinct --- @param en - The EntityDescription that describes the entity --- @param crit - Criteria for the query --- @param op - oreder-by clause --- @param limit - int value to limit number of entities returned --- @return a `DBAction` with a list of entries getEntries :: Specifier -> EntityDescription a -> Criteria -> [Option] -> Maybe Int -> DBAction [a] getEntries spec en crit op limit = do let query = "select " ++ trSpecifier spec ++"* from '" ++ getTable en ++ "' " ++ trCriteria crit ++ trOption op ++ trLimit limit ++";" vals <- select query [] (getTypes en) return $ map (getToEntity en) vals --- Gets a single Column from the database. --- @param setops - list of Setoperators to combine queries if more than one is --- given, can be empty otherwise --- @param sels - list of SingleColumnSelects to specify query, --- if there are more requests than can be combined with --- setoperators they will be ignored ---@param options - order-by-clause for whole query ---@param limit - value to reduce number of returned rows ---@return a `DBAction`t with a list of a-Values as parameter --- (where a is the type of the column) getColumn :: [SetOp] -> [SingleColumnSelect a] -> [Option] -> Maybe Int -> DBAction [a] getColumn _ [] _ _ = return [] getColumn setops (s:sels) options limit = do let query = ((foldl (\quest (so, sel) -> quest ++ trSetOp so ++ trSingleSelectQuery sel ) (trSingleSelectQuery s) (zip setops sels)) ++ trOption options ++ trLimit limit++" ;") vals <- select query [] (getSingleType s) return (map ((getSingleValFunc s) . head) vals) --- Gets two Columns from the database. --- @param setops - list of Setoperators to combine queries if more than one is --- given, can be empty otherwise --- @param sels - list of TupleColumnSelects to specify queries, if there --- are more requests than can be combined with setoperators --- they will be ignored ---@param options - order-by-clause for whole query ---@param limit - value to reduce number of returned rows ---@return a `DBAction`t with a list of a-Values as parameter --- (where a is the type of the column) getColumnTuple :: [SetOp] -> [TupleColumnSelect a b] -> [Option] -> Maybe Int -> DBAction [(a,b)] getColumnTuple _ [] _ _ = return [] getColumnTuple setops (s:sels) options limit = do let query = ((foldl (\quest (so, sel) -> quest ++ trSetOp so ++ trTupleSelectQuery sel ) (trTupleSelectQuery s) (zip setops sels)) ++ trOption options ++ trLimit limit++" ;") (fun1, fun2) = getTupleValFuncs s vals <- select query [] (getTupleTypes s) return (map (\ [val1, val2] -> ((fun1 val1),(fun2 val2))) vals) --- Gets three Columns from the database. --- @param setops - list of Setoperators to combine queries if more than one is --- given, can be empty otherwise --- @param sels - list of TripleColumnSelects to specify queries, if there --- are more requests than can be combined with setoperators --- they will be ignored ---@param options - order-by-clause for whole query ---@param limit - value to reduce number of returned rows ---@return a `DBAction`t with a list of a-Values as parameter --- (where a is the type of the column) getColumnTriple :: [SetOp] -> [TripleColumnSelect a b c] -> [Option] -> Maybe Int -> DBAction [(a,b,c)] getColumnTriple _ [] _ _ = return [] getColumnTriple setops (s:sels) options limit = do let query = ((foldl (\quest (so, sel) -> quest ++ trSetOp so ++ trTripleSelectQuery sel ) (trTripleSelectQuery s) (zip setops sels)) ++ trOption options ++ trLimit limit++" ;") (fun1, fun2, fun3) = getTripleValFuncs s vals <- select query [] (getTripleTypes s) return (map (\ [val1, val2, val3] -> (fun1 val1, fun2 val2, fun3 val3)) vals) --- Gets four Columns from the database. --- @param setops - list of Setoperators to combine queries if more than one is --- given, can be empty otherwise --- @param sels - list of FourColumnSelects to specify queries, if there --- are more requests than can be combined with setoperators --- they will be ignored ---@param options - order-by-clause for whole query ---@param limit - value to reduce number of returned rows ---@return a `DBAction`t with a list of a-Values as parameter --- (where a is the type of the column) getColumnFourTuple :: [SetOp] -> [FourColumnSelect a b c d] -> [Option] -> Maybe Int -> DBAction [(a,b,c,d)] getColumnFourTuple _ [] _ _ = return [] getColumnFourTuple setops (s:sels) options limit = do let query = ((foldl (\quest (so, sel) -> quest ++ trSetOp so ++ trFourTupleSelectQuery sel) (trFourTupleSelectQuery s) (zip setops sels)) ++ trOption options ++ trLimit limit++" ;") (fun1, fun2, fun3, fun4) = getFourTupleValFuncs s vals <- select query [] (getFourTupleTypes s) return $ map (\ [val1, val2, val3, val4] -> ((fun1 val1), (fun2 val2), (fun3 val3), (fun4 val4))) vals --- Gets five Columns from the database. --- @param setops - list of Setoperators to combine queries if more than one is --- given, can be empty otherwise --- @param sels - list of FiveColumnSelects to specify queries, if there --- are more requests than can be combined with setoperators --- they will be ignored ---@param options - order-by-clause for whole query ---@param limit - value to reduce number of returned rows ---@return a `DBAction` with a list of a-values --- (where a is the type of the column) getColumnFiveTuple :: [SetOp] -> [FiveColumnSelect a b c d e] -> [Option] -> Maybe Int -> DBAction [(a,b,c,d,e)] getColumnFiveTuple _ [] _ _ = return [] getColumnFiveTuple setops (s:sels) options limit = do let query = ((foldl (\quest (so, sel) -> quest ++ trSetOp so ++ trFiveTupleSelectQuery sel) (trFiveTupleSelectQuery s) (zip setops sels)) ++ trOption options ++ trLimit limit++" ;") (fun1, fun2, fun3, fun4, fun5) = getFiveTupleValFuncs s vals <- select query [] (getFiveTupleTypes s) return $ map (\ [val1, val2, val3, val4, val5] -> ((fun1 val1), (fun2 val2), (fun3 val3), (fun4 val4), (fun5 val5))) vals --- Gets six Columns from the database. --- @param setops - list of Setoperators to combine queries if more than one is --- given, can be empty otherwise --- @param sels - list of SixColumnSelects to specify queries, if there --- are more requests than can be combined with setoperators --- they will be ignored ---@param options - order-by-clause for whole query ---@param limit - value to reduce number of returned rows ---@return a `DBAction` with a list of a-values --- (where a is the type of the column) getColumnSixTuple :: [SetOp] -> [SixColumnSelect a b c d e f] -> [Option] -> Maybe Int -> DBAction [(a,b,c,d,e,f)] getColumnSixTuple _ [] _ _ = return [] getColumnSixTuple setops (s:sels) options limit = do let query = ((foldl (\quest (so, sel) -> quest ++ trSetOp so ++ trSixTupleSelectQuery sel) (trSixTupleSelectQuery s) (zip setops sels)) ++ trOption options ++ trLimit limit++" ;") (fun1, fun2, fun3, fun4, fun5, fun6) = getSixTupleValFuncs s vals <- select query [] (getSixTupleTypes s) return $ map (\ [val1, val2, val3, val4, val5, val6] -> ((fun1 val1), (fun2 val2), (fun3 val3), (fun4 val4), (fun5 val5), (fun6 val6))) vals --- Gets combined entries from the database. --- @param spec - Specifier Distinct or All --- @param cd - The CombinedDescription that describes the entity --- @param joins - joins to combine the entity, they will be applied --- in a left-associative manner --- @param crit - Criteria for the query --- @param op - order-by-clause --- @param limit - int value to determine number of values returned --- @return A `DBAction` with a list of entries getEntriesCombined :: Specifier -> CombinedDescription a -> [Join] -> Criteria -> [Option] -> Maybe Int -> DBAction [a] getEntriesCombined spec cd@(CD _ f _ _) joins crit op limit = do let query = "select "++ trSpecifier spec ++ "* from " ++ getJoinString cd joins ++ " " ++ trCriteria crit ++ trOption op ++ trLimit limit ++ ";" xs <- select query [] (getJoinTypes cd) return (map f xs) --- Inserts combined entries. --- @param cd - The CombinedDescription that describes the entity --- @param ent - The combined Entity to be inserted --- @return A Result without parameter if saving worked or an Error if there --- was a problem insertEntryCombined :: CombinedDescription a -> a -> DBAction () insertEntryCombined (CD desc _ _ f3) ent = mapM_ save (zip desc (f3 ent)) where save :: ((Table, Int, [SQLType]), [SQLValue]) -> DBAction () save ((table, _, types), vals) = let query = "insert into '" ++ table ++ "' values(" ++ questionmarksHelp (length types) ++");" in execute query vals --- Updates entries depending on wether they fulfill the criteria or not --- @param en - The EntityDescription descriping the Entities that are to be --- updated --- @param xs - A list of ColVal that descripe the columns that should be --- updated and which values are to be inserted into them --- @param const - A Constraint can be be given as input which describes --- which entities should be updated. Only entities fulfilling the constraint --- will be updated. Nothing updates every entry. --- @return A Result without parameter if everything went right, --- an Error if something went wrong updateEntries :: EntityDescription a -> [ColVal] -> Constraint -> DBAction () updateEntries en (ColVal cl val : ys) const = let query = "update '" ++ (getTable en) ++ "' set " ++ foldl (\a (ColVal c v) -> a ++ ", " ++ (getColumnSimple c) ++ " = " ++ (trValue v)) (getColumnSimple cl ++ " = " ++ trValue val) ys ++ " " ++ trCriteria (Criteria const Nothing) ++ ";" in execute query [] --- Updates an entry by ID. Works for Entities that have a primary key --- as first value. --- This operation updates the entry in the database with the ID --- of the entry that is given as parameter with the values of --- the entry given as parameter. --- @param ed - The EntityDescription describung the entity-type --- @param entry - The entry that will be updated --- @return A Result without parameter if everything went right, --- an Error if something went wrong updateEntry :: EntityDescription a -> a -> DBAction () updateEntry ed ent = do let table = getTable ed columns <- getColumnNames table let values = getToValues ed ent SQLInt key = head values keycol = head columns colvals = zipWith (colValAlt table) (tail columns) (tail values) column = Column ("\"" ++ keycol ++ "\"") ("\"" ++ table ++ "\".\"" ++ keycol ++ "\"") const = col column .=. int key updateEntries ed colvals const --- Same as updateEntry but for combined Data updateEntryCombined :: CombinedDescription a -> a -> DBAction () updateEntryCombined (CD desc _ f2 _) ent = mapM_ update (zip desc (f2 ent)) where update :: ((Table, Int, [SQLType]), [SQLValue]) -> DBAction () update ((table, _, _), values) = do let SQLInt key = (\(x:_) -> x) values const = col (Column "\"Key\"" ("\"" ++ table ++ "\".\"Key\"")) .=. int key columns <- getColumnNames table let ((col1,val1):colval) = zip columns values execute ("update '" ++ table ++ "' set " ++ (foldl (\a (c, v) -> a ++ ", " ++ c ++ " = " ++ (valueToString v)) (col1 ++ " = " ++ (valueToString val1)) colval) ++ " " ++ trCriteria (Criteria const Nothing) ++ ";") [] --- Deletes entries depending on wether they fulfill the criteria or not --- @param en - The EntityDescription descriping the Entities that are to --- be updated --- @param const - A Constraint can be be given as input which describes --- which entities should be deleted. Only entities fulfilling the constraint --- will be deleted. Nothing deletes every entry. --- @return A Result without parameter if everything went right, an --- Error if something went wrong deleteEntries :: EntityDescription a -> (Maybe Constraint) -> DBAction () deleteEntries en const = let query = "delete from '" ++ (getTable en) ++ "' " ++ (case const of Just c -> "where "++(trConstraint c) _ -> "") ++ ";" in execute query [] --- Drops a table from the database --- @param en - The EntitiyDescription that describes the entity of which the --- table should be dropped --- @param conn - A Connection to a database which will be used for this --- @return A Result without paramter if everything went right, an Error if --- something went wrong dropTable :: EntityDescription a -> DBAction () dropTable en = let query = "drop table '" ++ getTable en ++ "';" in execute query [] -- ----------------------------------------------------------------------------- -- Auxiliary Functions -- ----------------------------------------------------------------------------- -- Create a String consisting of '?' seperated by commas corresponding to the -- number of Types an Entity has questionmarks :: EntityDescription a -> String questionmarks en = questionmarksHelp (length (getTypes en)) questionmarksHelp :: Int -> String questionmarksHelp n = intercalate ", " (replicate n "'?'") -- Create the join String of a CombinedDescription getJoinString :: CombinedDescription a -> [Join] -> String getJoinString (CD nametype _ _ _) jns= getJoinString' nametype jns where getJoinString' ((n,r,_):xs) joins = "'" ++ (foldl (\a (table, ren, _ ,join) -> a ++ (trJoinPart1 join) ++" '" ++ table ++ "'" ++ (asTable table ren) ++ (trJoinPart2 join)) (n ++ "'" ++ (asTable n r)) (mapJns xs joins)) mapJns [] _ = [] mapJns ((tb, al, t):xs) (j:js) = ((tb, al , t, j): (mapJns xs js)) -- Get the types of a CombinedDescription getJoinTypes :: CombinedDescription a -> [SQLType] getJoinTypes (CD nametype _ _ _) = getJoinString' (unzip3 nametype) where getJoinString' ((_, _, t:types)) = foldl (\a b -> a ++ b) t types ----------------------------------------------------------------------------- --- Gets the key of the last inserted entity from the database. --- @param en - The EntityDescription that describes the entity --- @return A Result with a key or an Error if something went wrong. getLastInsertedKey :: EntityDescription a -> DBAction Int getLastInsertedKey en = do let query = "select distinct last_insert_rowid() from '" ++ getTable en ++ "';" r <- select query [] [SQLTypeInt] selectInt r where selectInt vals = case vals of [[key]] -> maybe (failDB unknownKeyError) return (Database.CDBI.Description.intOrNothing key) _ -> failDB unknownKeyError unknownKeyError = DBError UnknownError "Key of inserted entity not available" ----------------------------------------------------------------------------- -- Some auxiliary operations for translating ER models into Curry -- with the erd2curry tool. --- Gets all entries of an entity stored in the database. --- @param endescr - the EntityDescription describing the entities --- @return a DB result with the list of entries if everything went right, --- or an error if something went wrong getAllEntries :: EntityDescription a -> DBAction [a] getAllEntries endescr = getEntries All endescr (Criteria None Nothing) [] Nothing --- Gets all entries of an entity satisfying a given condition. --- @param endescr - the EntityDescription describing the entities --- @param cond - a predicate on entities --- @return a DB result with the list of entries if everything went right, --- or an error if something went wrong getCondEntries :: EntityDescription a -> (a -> Bool) -> DBAction [a] getCondEntries endescr encond = do vals <- getAllEntries endescr return (filter encond vals) --- Gets an entry of an entity with a given key. --- @param endescr - the EntityDescription describing the entities --- @param keycolumn - the column containing the primary key --- @param keyval - the id-to-value function for entities --- @param key - the key of the entity to be fetched --- @return a DB result with the entry if everything went right, --- or an error if something went wrong getEntryWithKey :: Show kid => EntityDescription a -> Column k -> (kid -> Value k) -> kid -> DBAction a getEntryWithKey endescr keycolumn keyval key = do vals <- getEntries All endescr (Criteria (equal (colNum keycolumn 0) (keyval key)) Nothing) [] Nothing if null vals then failDB keyNotFoundError else return (head vals) where keyNotFoundError = DBError UnknownError $ "'" ++ getTable endescr ++ "' entity with key '" ++ show key ++ "' not available" --- Get all entries of an entity where some column have a given value. --- @param endescr - the EntityDescription describing the entities --- @param valcolumn - the column containing the required value --- @param val - the value required for fetched entities --- @return a DB result with the entry if everything went right, --- or an error if something went wrong getEntriesWithColVal :: EntityDescription a -> Column k -> Value k -> DBAction [a] getEntriesWithColVal endescr valcolumn val = getEntries All endescr (Criteria (equal (colNum valcolumn 0) val) Nothing) [] Nothing --- Inserts a new entry of an entity and returns the new entry with the new key. --- @param endescr - the EntityDescription describing the inserted entities --- @param setkey - the operation to set the key of an entry --- @param keycons - the constructor for entity keys --- @param entity - the entity to be inserted --- @return a DB result without a value if everything went right, or an --- error if something went wrong insertNewEntry :: EntityDescription a -> (a -> k -> a) -> (Int -> k) -> a -> DBAction a insertNewEntry endescr setkey keycons entity = do insertEntry endescr entity key <- getLastInsertedKey endescr return $ setkey entity (keycons key) --- Deletes an existing entry from the database. --- @param endescr - the EntityDescription describing the entities to be deleted --- @param keycolumn - the column containing the primary key --- @param keyval - the mapping from entities to their primary keys as SQL vals --- @param entity - the entity to be deleted --- @return a DB result without a value if everything went right, or an --- error if something went wrong deleteEntry :: EntityDescription a -> Column k -> (a -> Value k) -> a -> DBAction () deleteEntry endescr keycolumn keyval entity = deleteEntries endescr (Just (equal (colNum keycolumn 0) (keyval entity))) --- Deletes an existing binary relation entry from the database. --- @param endescr - the EntityDescription describing the entities to be deleted --- @param keycol1 - the column containing the first key --- @param keyval1 - the value of the first key to be deleted --- @param keycol2 - the column containing the second key --- @param keyval2 - the value of the second key to be deleted --- @return a DB result without a value if everything went right, or an --- error if something went wrong deleteEntryR :: EntityDescription a -> Column k1 -> Value k1 -> Column k2 -> Value k2 -> DBAction () deleteEntryR endescr keycol1 keyval1 keycol2 keyval2 = deleteEntries endescr (Just (And [equal (colNum keycol1 0) keyval1, equal (colNum keycol2 0) keyval2])) --- Shows a database key for an entity name as a string. --- Useful if a textual representation of a database key is necessary, --- e.g., as URL parameters in web pages. This textual representation --- should not be used to store database keys in attributes! showDatabaseKey :: String -> (enkey -> Int) -> enkey -> String showDatabaseKey enname fromenkey enkey = enname ++ show (fromenkey enkey) --- Transforms a string into a key for an entity name. --- Nothing is returned if the string does not represent a reasonable key. readDatabaseKey :: String -> (Int -> enkey) -> String -> Maybe enkey readDatabaseKey enname toenkey s = let (ens,ks) = splitAt (length enname) s in if ens==enname && all isDigit ks then Just (toenkey (read ks)) else Nothing -- Saves all entries of an entity as terms in a file. --- @param endescr - the EntityDescription of the entities to be saved --- @param dbname - name of the database (e.g. "database.db") --- @param path - directory where term file is written saveDBTerms :: Show a => EntityDescription a -> String -> String -> IO () saveDBTerms endescr dbname path = do allentries <- runQueryOnDB dbname (getAllEntries endescr) let savefile = path getTable endescr ++ ".terms" if null path then putStrLn (unlines (map showQTerm allentries)) -- show only else do putStr $ "Saving into '" ++ savefile ++ "'..." writeQTermListFile savefile allentries putStrLn "done" --- Restores entries saved in a term file by deleting all existing entries --- and inserting the saved entries. --- @param endescr - the EntityDescription of the entities to be restored --- @param dbname - name of the database (e.g. "database.db") --- @param path - directory where term file was saved restoreDBTerms :: Read a => EntityDescription a -> String -> String -> IO () restoreDBTerms endescr dbname path = do let savefile = path getTable endescr ++ ".terms" putStr $ "Restoring from '" ++ savefile ++ "'..." entries <- readQTermListFile savefile runJustTransactionOnDB dbname $ do setForeignKeyCheck False deleteEntries endescr Nothing restoreEntries endescr entries putStrLn "done" --- Executes a DB action on a database and returns the result. --- An error is raised if the DB action produces an error. --- @param dbname - name of the database (e.g. "database.db") --- @param dbaction - a database action --- @return the result of the action runQueryOnDB :: String -> DBAction a -> IO a runQueryOnDB dbname dbaction = runWithDB dbname dbaction >>= return . fromSQLResult --- Executes a DB action as a transcation on a database and returns the result. --- If the DB action produces an error, the transaction is rolled back --- and the error is returned, otherwise the transaction is committed. --- @param str - name of the database (e.g. "database.db") --- @param dbaction - a database action --- @return the result of the action runTransactionOnDB :: String -> DBAction a -> IO (SQLResult a) runTransactionOnDB dbname dbaction = runWithDB dbname (runInTransaction dbaction) --- Executes a DB action as a transcation on a database and returns the result. --- An error is raised if the DB action produces an error so that the --- transaction is rolled back. --- @param str - name of the database (e.g. "database.db") --- @param dbaction - a database action --- @return the result of the action runJustTransactionOnDB :: String -> DBAction a -> IO a runJustTransactionOnDB dbname dbaction = runWithDB dbname (runInTransaction dbaction) >>= return . fromSQLResult ---------------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/cdbi/src/Database/CDBI/QueryTypes.curry000066400000000000000000000511771377556325500254330ustar00rootroot00000000000000--- -------------------------------------------------------------- --- This module contains datatype declarations, constructor functions --- selectors and translation functions for complex select queries --- in particular for those selecting (1 to 5) single columns. --- --- @author Julia Krone --- ---------------------------------------------------------------- {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module Database.CDBI.QueryTypes ( SetOp(..),Join(..),innerJoin, crossJoin, ColumnSingleCollection(..), ColumnTupleCollection, ColumnTripleCollection, ColumnFourTupleCollection, ColumnFiveTupleCollection, ColumnSixTupleCollection, sum, avg, count, minV, maxV, none, caseThen, singleCol, tupleCol, tripleCol, fourCol, fiveCol, sixCol, SingleColumnSelect(..), TupleColumnSelect(..), TripleColumnSelect(..), FourColumnSelect(..), FiveColumnSelect(..), SixColumnSelect(..), TableClause(..), getSingleType, getTupleTypes, getTripleTypes, getFourTupleTypes, getFiveTupleTypes, getSixTupleTypes, getSingleValFunc, getTupleValFuncs, getTripleValFuncs, getFourTupleValFuncs, getFiveTupleValFuncs, getSixTupleValFuncs, trLimit, trSpecifier, trSetOp, trSingleSelectQuery, asTable, trTupleSelectQuery, trJoinPart1, trJoinPart2, trTripleSelectQuery, trFourTupleSelectQuery, trFiveTupleSelectQuery, trSixTupleSelectQuery, caseResultInt, caseResultFloat, caseResultString, caseResultChar, caseResultBool) where import Data.List(intercalate) import Data.Time(ClockTime) import Database.CDBI.Connection import Database.CDBI.Criteria import Database.CDBI.Description ---datatype for set operations data SetOp = Union | Intersect | Except --- datatype for joins data Join = Cross | Inner Constraint --- Constructorfunction for an inner join ---@param constraint innerJoin :: Constraint -> Join innerJoin constraint = Inner constraint --- Constructorfunction for cross join crossJoin :: Join crossJoin = Cross --- data structure to represent a table-clause (tables and joins) --- in a way that at least one table has to be specified data TableClause = TC Table Int (Maybe (Join,TableClause)) -- Data type to specify the result type of case expressions and its conversion. type CaseVal a = (SQLType , (SQLValue -> a)) --- Datatype representing a single column in a select-clause. Can be just a --- column connected with an alias and an optional aggregation function(String) --- or a Case-when-then-statement data ColumnSingleCollection a = ResultColumnDescription (ColumnDescription a) Int String | Case Condition (CValue, CValue) (CaseVal a) --- Datatype to select two different columns which can be of different types --- and from different tables. type ColumnTupleCollection a b = (ColumnSingleCollection a, ColumnSingleCollection b) --- Datatype to select three different columns which can be of different types --- and from different tables. type ColumnTripleCollection a b c = (ColumnSingleCollection a, ColumnSingleCollection b, ColumnSingleCollection c) --- Datatype to select four different columns which can be of different types --- and from different tables. type ColumnFourTupleCollection a b c d = (ColumnSingleCollection a, ColumnSingleCollection b, ColumnSingleCollection c, ColumnSingleCollection d) --- Datatype to select five different columns which can be of different types --- and from different tables. type ColumnFiveTupleCollection a b c d e= (ColumnSingleCollection a, ColumnSingleCollection b, ColumnSingleCollection c, ColumnSingleCollection d, ColumnSingleCollection e) --- Datatype to select five different columns which can be of different types --- and from different tables. type ColumnSixTupleCollection a b c d e f = (ColumnSingleCollection a, ColumnSingleCollection b, ColumnSingleCollection c, ColumnSingleCollection d, ColumnSingleCollection e, ColumnSingleCollection f) -- Data type to represent an aggregation function in a select-clause. type Fun a = (String , ColumnDescription a) --- Constructor for aggregation function sum --- in select-clauses. --- A pseudo-ResultColumnDescription of type --- float is created for correct return type. sum :: Specifier -> ColumnDescription _ -> Fun Float sum spec (ColDesc name _ _ _) = ("Sum( "++ (trSpecifier spec) , (ColDesc name SQLTypeFloat (\f -> (SQLFloat f)) getFloatValue)) --- Constructor for aggregation function avg --- in select-clauses. --- A pseudo-ResultColumnDescription of type --- float is created for correct return type. avg :: Specifier -> ColumnDescription _ -> Fun Float avg spec (ColDesc name _ _ _) = ("Avg( "++ (trSpecifier spec), (ColDesc name SQLTypeFloat (\f -> (SQLFloat f)) getFloatValue)) --- Constructor for aggregation function count --- in select-clauses. --- A pseudo-ResultColumnDescription of type --- float is created for correct return type. count :: Specifier -> ColumnDescription _ -> Fun Int count spec (ColDesc name _ _ _) = ("Count( "++ (trSpecifier spec), (ColDesc name SQLTypeInt (\i -> (SQLInt i)) getIntValue)) --- Constructor for aggregation function min in select-clauses. minV :: ColumnDescription a -> Fun a minV cd = ("Min( ", cd) --- Constructor for aggregation function max in select-clauses. maxV :: ColumnDescription a -> Fun a maxV cd = ("Max( ", cd) --- Constructor function in case no aggregation function is specified. none :: ColumnDescription a -> Fun a none cd = ("(", cd) ---Constructor for CaseVal of type Int ---expecting result of type Int in case-expression caseResultInt :: CaseVal Int caseResultInt = (SQLTypeInt, getIntValue) ---Constructor for CaseVal of type Float ---expecting result of type Float in case-expression caseResultFloat :: CaseVal Float caseResultFloat = (SQLTypeFloat, getFloatValue) ---Constructor for CaseVal of type String ---expecting result of type String in case-expression caseResultString :: CaseVal String caseResultString = (SQLTypeString, getStringValue) ---Constructor for CaseVal of type Date ---expecting result of type Date in case-expression caseResultDate :: CaseVal ClockTime caseResultDate = (SQLTypeDate, getDateValue) ---Constructor for CaseVal of type Bool ---expecting result of type Bool in case-expression caseResultBool :: CaseVal Bool caseResultBool = (SQLTypeBool, getBoolValue) ---Constructor for CaseVal of type Char ---expecting result of type Char in case-expression caseResultChar :: CaseVal Char caseResultChar = (SQLTypeChar, getCharValue) --- Constructor function for representation of statement: --- CASE WHEN condition THEN val1 ELSE val2 END. --- It does only work for the same type in then and --- else branch. ---@param con - the condition ---@param val1 - value for then-branch ---@param val2 - value for else-branch ---@param cv - data providing SQLType and conversion function caseThen :: Condition -> Value a -> Value a -> (CaseVal a) -> ColumnSingleCollection a caseThen con val1 val2 cv = Case con ((toCValue val1), (toCValue val2)) cv --- Constructorfunction for ColumnSingleCollection. ---@param coldecs - ColumnDescription of column to select ---@param alias - alias of the table ---@param f - aggregation function (constructor) singleCol :: ColumnDescription a -> Int -> (ColumnDescription a -> Fun b) -> ColumnSingleCollection b singleCol colDesc alias f = ResultColumnDescription convColDesc alias fun where (fun, convColDesc) = f colDesc ---Constructor function for ColumnTupleCollection. ---@param col1 - first ColumnSingleCollection ---@param col2 - second ColumnSingleCollection tupleCol :: ColumnSingleCollection a -> ColumnSingleCollection b -> ColumnTupleCollection a b tupleCol col1 col2 = (col1,col2) ---Constructor function for ColumnTripleCollection. tripleCol :: ColumnSingleCollection a -> ColumnSingleCollection b -> ColumnSingleCollection c -> ColumnTripleCollection a b c tripleCol col1 col2 col3 = (col1, col2, col3) ---Constructor function for ColumnFourTupleCollection. fourCol :: ColumnSingleCollection a -> ColumnSingleCollection b -> ColumnSingleCollection c -> ColumnSingleCollection d -> ColumnFourTupleCollection a b c d fourCol col1 col2 col3 col4 = (col1, col2, col3, col4) ---Constructor function for ColumnFiveTupleCollection. fiveCol :: ColumnSingleCollection a -> ColumnSingleCollection b -> ColumnSingleCollection c -> ColumnSingleCollection d -> ColumnSingleCollection e -> ColumnFiveTupleCollection a b c d e fiveCol col1 col2 col3 col4 col5 = (col1, col2, col3, col4, col5) --- Constructor function for ColumnSixTupleCollection. sixCol :: ColumnSingleCollection a -> ColumnSingleCollection b -> ColumnSingleCollection c -> ColumnSingleCollection d -> ColumnSingleCollection e -> ColumnSingleCollection f -> ColumnSixTupleCollection a b c d e f sixCol col1 col2 col3 col4 col5 col6 = (col1, col2, col3, col4, col5, col6) --- Datatype to describe all parts of a select-query without Setoperators --- order-by and limit (selecthead) for a single column. data SingleColumnSelect a = SingleCS Specifier (ColumnSingleCollection a) TableClause Criteria --- Datatype to describe all parts of a select-query without Setoperators --- order-by and limit (selecthead) for two columns. data TupleColumnSelect a b = TupleCS Specifier (ColumnTupleCollection a b) TableClause Criteria --- Datatype to describe all parts of a select-query without Setoperators --- order-by and limit (selecthead) for three columns. data TripleColumnSelect a b c = TripleCS Specifier (ColumnTripleCollection a b c) TableClause Criteria --- Datatype to describe all parts of a select-query without Setoperators --- order-by and limit (selecthead) for four columns. data FourColumnSelect a b c d = FourCS Specifier (ColumnFourTupleCollection a b c d) TableClause Criteria --- Datatype to describe all parts of a select-query without Setoperators --- order-by and limit (selecthead) for five columns. data FiveColumnSelect a b c d e = FiveCS Specifier (ColumnFiveTupleCollection a b c d e) TableClause Criteria --- Datatype to describe all parts of a select-query without Setoperators --- order-by and limit (selecthead) for five columns. data SixColumnSelect a b c d e f = SixCS Specifier (ColumnSixTupleCollection a b c d e f) TableClause Criteria --selector of the SQLType encasulated in a ColumnSingleCollection getColumnType :: ColumnSingleCollection _ -> [SQLType] getColumnType col = case col of (ResultColumnDescription (ColDesc _ typ _ _) _ _) -> [typ] (Case _ (_ , _) (typ,_)) -> [typ] -- selector of the conversion function encapsulated in a -- ColumnSingleCollection getColumnValFunc :: ColumnSingleCollection a -> (SQLValue -> a) getColumnValFunc col = case col of (ResultColumnDescription (ColDesc _ _ _ f) _ _) -> f (Case _ (_, _) (_,f)) -> f --selector: returns the SQLType of the ColumnSingleCollection -- inside of SingleColumnSelect getSingleType :: SingleColumnSelect _ -> [SQLType] getSingleType (SingleCS _ col _ _) = getColumnType col --selector: returns the function to convert the SQLValue to the resulttype getSingleValFunc :: SingleColumnSelect a -> (SQLValue -> a) getSingleValFunc (SingleCS _ col _ _) = getColumnValFunc col --selector: returns the list of SQLTypes used -- inside the TupleColumnSelect getTupleTypes :: TupleColumnSelect _ _ -> [SQLType] getTupleTypes (TupleCS _ (col1,col2) _ _) = getColumnType col1 ++ getColumnType col2 --selector: returns the tuple of functions to convert the SQLValue --to the resulttype getTupleValFuncs :: TupleColumnSelect a b -> ((SQLValue -> a), (SQLValue -> b)) getTupleValFuncs (TupleCS _ (col1,col2) _ _) = (getColumnValFunc col1, getColumnValFunc col2) --selector: returns the list of SQLTypes used -- inside the TripleColumnSelect getTripleTypes :: TripleColumnSelect _ _ _ -> [SQLType] getTripleTypes (TripleCS _ (col1, col2, col3) _ _) = getColumnType col1 ++ getColumnType col2 ++ getColumnType col3 --selector: returns the triple of functions to convert the SQLValue --to the resulttype getTripleValFuncs :: TripleColumnSelect a b c -> ((SQLValue -> a), (SQLValue -> b), (SQLValue -> c)) getTripleValFuncs (TripleCS _ (col1, col2, col3) _ _) = (getColumnValFunc col1, getColumnValFunc col2, getColumnValFunc col3) --selector: returns the list of SQLTypes used -- inside the FourColumnSelect getFourTupleTypes :: FourColumnSelect _ _ _ _ -> [SQLType] getFourTupleTypes (FourCS _ (col1, col2, col3, col4) _ _) = getColumnType col1 ++ getColumnType col2 ++ getColumnType col3 ++ getColumnType col4 --selector: returns the fourtuple of functions to convert the --SQLValue to the resulttype getFourTupleValFuncs :: FourColumnSelect a b c d -> ((SQLValue -> a), (SQLValue -> b), (SQLValue -> c), (SQLValue -> d)) getFourTupleValFuncs (FourCS _ (col1, col2, col3, col4) _ _) = (getColumnValFunc col1, getColumnValFunc col2, getColumnValFunc col3, getColumnValFunc col4) --selector: returns the list of SQLTypes used -- inside the FiveColumnSelect getFiveTupleTypes :: FiveColumnSelect a b c d e -> [SQLType] getFiveTupleTypes (FiveCS _ (col1, col2, col3, col4, col5) _ _) = getColumnType col1 ++ getColumnType col2 ++ getColumnType col3 ++ getColumnType col4 ++ getColumnType col5 --selector: returns the fivetuple of functions to convert the --SQLValue to the resulttype getFiveTupleValFuncs :: FiveColumnSelect a b c d e -> ((SQLValue -> a), (SQLValue -> b), (SQLValue -> c), (SQLValue -> d), (SQLValue -> e)) getFiveTupleValFuncs (FiveCS _ (col1, col2, col3, col4, col5) _ _) = (getColumnValFunc col1, getColumnValFunc col2, getColumnValFunc col3, getColumnValFunc col4, getColumnValFunc col5) --selector: returns the list of SQLTypes used -- inside the SixColumnSelect getSixTupleTypes :: SixColumnSelect a b c d e f -> [SQLType] getSixTupleTypes (SixCS _ (col1, col2, col3, col4, col5, col6) _ _) = getColumnType col1 ++ getColumnType col2 ++ getColumnType col3 ++ getColumnType col4 ++ getColumnType col5 ++ getColumnType col6 --selector: returns the sixtuple of functions to convert the --SQLValue to the resulttype getSixTupleValFuncs :: SixColumnSelect a b c d e f -> (SQLValue -> a, SQLValue -> b, SQLValue -> c, SQLValue -> d, SQLValue -> e, SQLValue -> f) getSixTupleValFuncs (SixCS _ (col1, col2, col3, col4, col5, col6) _ _) = (getColumnValFunc col1, getColumnValFunc col2, getColumnValFunc col3, getColumnValFunc col4, getColumnValFunc col5, getColumnValFunc col6) -- ------------------------------------------------------------------------------ -- translation functions -- ------------------------------------------------------------------------------ -- Transform a SingleColumnSelect to its string representation. trSingleSelectQuery :: SingleColumnSelect _ -> String trSingleSelectQuery (SingleCS sp col tabs crit) = ("select "++ trSpecifier sp ++ getResultColumnString col ++" from " ++ (getTableString tabs "") ++ " " ++ trCriteria crit) -- Transform a TupleColumnSelect to its string representation. trTupleSelectQuery :: TupleColumnSelect _ _ -> String trTupleSelectQuery (TupleCS sp (col1, col2) tabs crit) = ("select " ++trSpecifier sp ++ getResultColumnString col1 ++ ", "++ getResultColumnString col2 ++" from " ++ (getTableString tabs "") ++ trCriteria crit ) -- Transform a TripleColumnSelect to its string representation. trTripleSelectQuery :: TripleColumnSelect _ _ _ -> String trTripleSelectQuery (TripleCS sp (col1, col2, col3) tabs crit) = ("select " ++trSpecifier sp ++ getResultColumnString col1 ++ ", "++ getResultColumnString col2 ++ ", "++ getResultColumnString col3 ++ " from " ++ (getTableString tabs "") ++ trCriteria crit ) -- Transform a FourTupleColumnSelect to its string representation. trFourTupleSelectQuery :: FourColumnSelect _ _ _ _ -> String trFourTupleSelectQuery (FourCS sp (col1, col2, col3, col4) tabs crit) = ("select " ++trSpecifier sp ++ getResultColumnString col1 ++ ", "++ getResultColumnString col2 ++ ", "++ getResultColumnString col3 ++ ", "++ getResultColumnString col4 ++ " from " ++ (getTableString tabs "") ++ trCriteria crit ) -- Transform a FiveTupleColumnSelect to its string representation. trFiveTupleSelectQuery :: FiveColumnSelect _ _ _ _ _ -> String trFiveTupleSelectQuery (FiveCS sp (col1, col2, col3, col4, col5) tabs crit) = ("select " ++trSpecifier sp ++ getResultColumnString col1 ++ ", "++ getResultColumnString col2 ++", "++ getResultColumnString col3 ++", "++ getResultColumnString col4 ++ ", "++ getResultColumnString col5 ++" from " ++ (getTableString tabs "") ++ trCriteria crit ) -- Transform a SixTupleColumnSelect to its string representation. trSixTupleSelectQuery :: SixColumnSelect _ _ _ _ _ _ -> String trSixTupleSelectQuery (SixCS sp (col1, col2, col3, col4, col5, col6) tabs crit) = ("select " ++trSpecifier sp ++ getResultColumnString col1 ++ ", "++ getResultColumnString col2 ++ ", " ++ getResultColumnString col3 ++ ", " ++ getResultColumnString col4 ++ ", " ++ getResultColumnString col5 ++ ", "++ getResultColumnString col6 ++ " from " ++ (getTableString tabs "") ++ trCriteria crit ) -- translate set operations trSetOp :: SetOp -> String trSetOp Union = " union " trSetOp Intersect = " intersect " trSetOp Except = " except " -- translate limit clause trLimit :: Maybe Int -> String trLimit limit = case limit of Nothing -> "" Just n -> " Limit "++(show n) -- Create the "as tablename" string asTable :: Table -> Int -> Table asTable table n = case n of 0 -> "" m -> " as '" ++ (show m) ++ table ++ "'" -- translate joins trJoinPart1 :: Join -> String trJoinPart1 Cross = " cross join" trJoinPart1 (Inner _) = " inner join" trJoinPart2 :: Join -> String trJoinPart2 Cross = "" trJoinPart2 (Inner constraint) = " ON (" ++ (trConstraint constraint)++")" -- translate a ColumnSingleCollection getResultColumnString:: ColumnSingleCollection a -> String getResultColumnString (ResultColumnDescription (ColDesc name _ _ _) alias aggr) = aggr ++ (trColumn name alias) ++ ")" getResultColumnString (Case con (val1, val2) _ ) = "( case when " ++ trCondition con ++ " then " ++ trValue val1 ++ " else " ++ trValue val2 ++ " end)" -- translate a table-clause getTableString :: TableClause -> String -> String getTableString (TC tab alias Nothing) join2 = (" '" ++tab ++ "'" ++ (asTable tab alias)++" "++join2) getTableString (TC tab alias (Just (join, tc))) join2 = (" '" ++tab ++ "'" ++ (asTable tab alias)++join2 ++(trJoinPart1 join) ++ (getTableString tc (trJoinPart2 join))) getCharValue :: SQLValue -> Char getCharValue (SQLChar char) = char getDateValue :: SQLValue -> ClockTime getDateValue (SQLDate date) = date getFloatValue :: SQLValue -> Float getFloatValue (SQLFloat float) = float getIntValue :: SQLValue -> Int getIntValue (SQLInt int) = int getStringValue :: SQLValue -> String getStringValue (SQLString str) = str getBoolValue :: SQLValue -> Bool getBoolValue (SQLBool bool) = bool curry-tools-v3.3.0/cpm/vendor/cdbi/src/Database/ERD.curry000066400000000000000000000155731377556325500232120ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains the definition of data types to represent --- entity/relationship diagrams and an I/O operation to read them --- from a term file. --- --- @author Michael Hanus, Marion Mueller --- @version April 2018 --- @category database ------------------------------------------------------------------------------ module Database.ERD ( ERD(..), ERDName, Entity(..), EName, Entity(..) , Attribute(..), AName, Key(..), Null, Domain(..) , Relationship(..), REnd(..), RName, Role, Cardinality(..), MaxValue(..) , readERDTermFile, writeERDTermFile ) where import Data.Char (isSpace) import Data.Time import System.Directory (getAbsolutePath) import System.IO import ReadShowTerm (readUnqualifiedTerm) --- Data type to represent entity/relationship diagrams. --- The components are the name of the ER model, the list of entities, --- and the list of relationships. data ERD = ERD ERDName [Entity] [Relationship] deriving Show --- The name of an ER model (a string). type ERDName = String -- used as the name of the generated module --- Data type to represent the entities of an ER model. --- Each entity consists of a name and a list of attributes. data Entity = Entity EName [Attribute] deriving Show --- The name of an entity (a string). type EName = String --- Data type to represent attributes of entities of an ER model. --- Each attribute consists of --- * a name --- * the domain (i.e., type) of the attribute --- * a value specifying the key property of thi attribute --- (no key, primary key, or unique) --- * a flag indicating whether this attribute can contain null values data Attribute = Attribute AName Domain Key Null deriving Show --- The name of an attribute (a string). type AName = String --- Data type to represent key properties of attributes --- (no key, primary key, or unique). data Key = NoKey | PKey | Unique deriving (Eq, Show) --- Type of the flag of an attribute indicating whether the attribute --- can contain null values (if the flag has value `True`). type Null = Bool --- Data type the domain of an attribute. --- If the attribute has a default value, it can be specified --- as an argument in the domain. data Domain = IntDom (Maybe Int) | FloatDom (Maybe Float) | CharDom (Maybe Char) | StringDom (Maybe String) | BoolDom (Maybe Bool) | DateDom (Maybe CalendarTime) | UserDefined String (Maybe String) | KeyDom String -- for foreign keys deriving Show --- Data type to represent the relationships of an ER model. --- Each relationship consists of a name and a list of end points --- (usually with two elements). data Relationship = Relationship RName [REnd] deriving Show --- The name of a relationship (a string). type RName = String --- An end point of a relationship which consists of the name --- of an entity, the name of the role, and a cardinality constraint. data REnd = REnd EName Role Cardinality deriving Show --- The name of a role (a string). type Role = String --- Cardinality of a relationship w.r.t. some entity. --- The cardinality is either a fixed number (e.g., (Exactly 1) --- representing the cardinality (1,1)) --- or an interval (e.g., (Between 1 (Max 4)) representing the --- cardinality (1,4), or (Between 0 Infinite) representing the --- cardinality (0,n)). data Cardinality = Exactly Int | Between Int MaxValue deriving Show --- The upper bound of a cardinality which is either a finite number --- or infinite. data MaxValue = Max Int | Infinite deriving Show --- Read an ERD specification from a file containing a single ERD term. readERDTermFile :: String -> IO ERD readERDTermFile termfilename = do putStrLn $ "Reading ERD term from file '" ++ termfilename ++ "'..." handle <- openFile termfilename ReadMode line <- skipCommentLines handle termstring <- hGetContents handle return (updateERDTerm (readUnqualifiedTerm ["Database.ERD","Prelude"] (unlines [line,termstring]))) where skipCommentLines h = do line <- hGetLine h >>= return . dropWhile isSpace if null line || take 2 line == "--" then skipCommentLines h else if take 2 line == "{-" -- -} then skipBracketComment h (drop 2 line) else return line skipBracketComment h [] = hGetLine h >>= skipBracketComment h skipBracketComment h [_] = hGetLine h >>= skipBracketComment h skipBracketComment h (c1:c2:cs) = if c1=='-' && c2=='}' then return cs else skipBracketComment h (c2:cs) --- Transforms an ERD term possible containing old, outdated, information. --- In particular, translate (Range ...) into (Between ...). updateERDTerm :: ERD -> ERD updateERDTerm (ERD name es rs) = ERD name es (map updateRel rs) where updateRel (Relationship r ends) = Relationship r (map updateEnd ends) updateEnd (REnd n r c) = REnd n r (updateCard c) updateCard (Exactly n) = Exactly n updateCard (Between min (Max m)) = if min<=m then Between min (Max m) else error ("ERD: Illegal cardinality " ++ show (Between min (Max m))) updateCard (Between min Infinite) = Between min Infinite --- Writes an ERD term into a file with name `ERDMODELNAME.erdterm` --- and returns the absolute path name of the generated term file. writeERDTermFile :: ERD -> IO String writeERDTermFile erd@(ERD name _ _) = do let termfile = name ++ ".erdterm" writeFile termfile (show erd) getAbsolutePath termfile {- -- Example ERD term: (ERD "Uni" [Entity "Student" [Attribute "MatNum" (IntDom Nothing) PKey False, Attribute "Name" (StringDom Nothing) NoKey False, Attribute "Firstname" (StringDom Nothing) NoKey False, Attribute "Email" (UserDefined "MyModule.Email" Nothing) NoKey True], Entity "Lecture" [Attribute "Id" (IntDom Nothing) PKey False, Attribute "Title" (StringDom Nothing) Unique False, Attribute "Hours" (IntDom (Just 4)) NoKey False], Entity "Lecturer" [Attribute "Id" (IntDom Nothing) PKey False, Attribute "Name" (StringDom Nothing) NoKey False, Attribute "Firstname" (StringDom Nothing) NoKey False], Entity "Group" [Attribute "Time" (StringDom Nothing) NoKey False]] [Relationship "Teaching" [REnd "Lecturer" "taught_by" (Exactly 1), REnd "Lecture" "teaches" (Between 0 Infinite)], Relationship "Participation" [REnd "Student" "participated_by" (Between 0 Infinite), REnd "Lecture" "participates" (Between 0 Infinite)], Relationship "Membership" [REnd "Student" "consists_of" (Exactly 3), REnd "Group" "member_of" (Between 0 Infinite)]]) -} curry-tools-v3.3.0/cpm/vendor/containers/000077500000000000000000000000001377556325500204505ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/containers/LICENSE000066400000000000000000000027351377556325500214640ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/containers/README.md000066400000000000000000000002711377556325500217270ustar00rootroot00000000000000containers ========== This package contains the library `Data.Map` implementing finite maps, i.e., efficient purely functional data structures to store a mapping from keys to values. curry-tools-v3.3.0/cpm/vendor/containers/package.json000066400000000000000000000015371377556325500227440ustar00rootroot00000000000000{ "name": "containers", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library implementing various datastructures", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base": ">= 3.0.0, < 4.0.0", "random": ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Data.Map", "Data.Set" ], "testsuite": [ { "src-dir": "src", "modules": [ "Data.Map", "Data.Set" ] }, { "src-dir": "test", "modules": [ "TestMap", "TestSet" ] } ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/containers.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/containers/src/000077500000000000000000000000001377556325500212375ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/containers/src/Data/000077500000000000000000000000001377556325500221105ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/containers/src/Data/Map.curry000066400000000000000000000515111377556325500237160ustar00rootroot00000000000000----------------------------------------------------------------------------- --- A finite map is an efficient purely functional data structure --- to store a mapping from keys to values. --- --- This version was ported from a corresponding Haskell library --- --- @author Frank Huch, Bernd Brassel --- @version March 2013 --- @category algorithm ----------------------------------------------------------------------------- module Data.Map ( Map, -- abstract type empty, singleton, fromList, insert, insertWith, insertList, insertListWith, delete, deleteAll, adjust, splitLookup, union, unionWith, difference, intersection, intersectionWith, foldrWithKey, mapWithKey, filterWithKey, size, null, member, lookup, findWithDefault, toList, keys, elems, sortWithMap, lookupMin, lookupMax, toPreOrderList ) where import Data.Maybe import Prelude hiding (empty) ----------------------------------------------- -- BUILDING finite maps ----------------------------------------------- --- The empty map. --- @result an empty map empty :: Map _ _ empty = Tip --- Construct a map with only a single element. --- @param k key of --- @param a the single element to form --- @result a finite map with only a single element singleton :: k -> a -> Map k a singleton k a = Bin k a 1 Tip Tip --- Builts a map from given list of tuples (key,element). --- For multiple occurences of key, the last corresponding --- element of the list is taken. fromList :: Ord k => [(k,a)] -> Map k a fromList xs = insertList xs empty ----------------------------------------------- -- ADDING AND DELETING ----------------------------------------------- --- Throws away any previous binding and stores the new one given. insert :: Ord k => k -> a -> Map k a -> Map k a insert k a m = insertWith (\ _ new -> new) k a m --- Instead of throwing away the old binding, --- insertWith combines the new element with the old one. --- @param combiner a function combining to elements --- @param k the key of the elements to be combined --- @param a the new element --- @param m a map --- @result a modified map insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a insertWith _ k a Tip = singleton k a insertWith combiner new_k new_a (Bin k a sizeM m_l m_r) = if new_k < k then mkBalBranch k a (insertWith combiner new_k new_a m_l) m_r else if new_k == k then Bin new_k (combiner a new_a) sizeM m_l m_r else mkBalBranch k a m_l (insertWith combiner new_k new_a m_r) --- Throws away any previous bindings and stores the new ones given. --- The items are added starting with the first one in the list insertList :: Ord k => [(k, a)] -> Map k a -> Map k a insertList k_a_pairs m = insertListWith (\ _ new -> new) k_a_pairs m --- Combine with a list of tuples (key, element), cf. insertWith insertListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> Map k a -> Map k a insertListWith combiner k_a_pairs m = foldl add m k_a_pairs -- foldl adds from the left where add m' (k, a) = insertWith combiner k a m' --- Deletes key from map. --- Deletion doesn't complain if you try to delete something --- which isn't there delete :: Ord k => k -> Map k a -> Map k a delete _ Tip = Tip delete del_k (Bin k a _ m_l m_r) = if del_k < k then mkBalBranch k a (delete del_k m_l) m_r else if del_k == k then glueBal m_l m_r else mkBalBranch k a m_l (delete del_k m_r) --- Deletes a list of keys from map. --- Deletion doesn't complain if you try to delete something --- which isn't there deleteAll :: Ord k => [k] -> Map k a -> Map k a deleteAll ks m = foldl (flip delete) m ks --- Applies a function to element bound to given key. adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a adjust _ _ Tip = Tip adjust f i (Bin k x h l r) | i == k = Bin k (f x) h l r | i < k = Bin k x h (adjust f i l) r | otherwise = Bin k x h l (adjust f i r) --- Combines delFrom and lookup. splitLookup :: Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a) splitLookup _ Tip = (Tip, Nothing, Tip) splitLookup i (Bin k a _ m_l m_r) | i == k = (m_l, Just a, m_r) | i < k = let (m_l', v, m_r') = splitLookup i m_l in (m_l', v, glueBal m_r' m_r) | otherwise = let (m_l', v, m_r') = splitLookup i m_r in (glueBal m_l m_l', v, m_r') ------------------------------------------------- -- COMBINING finite maps ------------------------------------------------- --- Efficiently add key/element mappings of two maps into a single one. --- CHANGED: Bindings in left argument shadow those in the right union :: Ord k => Map k a -> Map k a -> Map k a union Tip m2 = m2 union m1@(Bin _ _ _ _ _) Tip = m1 union (Bin split_key1 a1 _ left1 right1) m2@(Bin _ _ _ _ _) = mkVBalBranch split_key1 a1 (union left1 lts) (union right1 gts) where lts = splitLT m2 split_key1 gts = splitGT m2 split_key1 --- Efficiently combine key/element mappings of two maps into a single one, --- cf. insertWith unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a unionWith _ Tip m2 = m2 unionWith _ m1@(Bin _ _ _ _ _) Tip = m1 unionWith combiner (Bin split_key1 a1 _ left1 right1) m2@(Bin _ _ _ _ _) = mkVBalBranch split_key1 new_a (unionWith combiner left1 lts) (unionWith combiner right1 gts) where lts = splitLT m2 split_key1 gts = splitGT m2 split_key1 new_a = case lookup split_key1 m2 of Nothing -> a1 Just a2 -> combiner a2 a1 --- (difference a1 a2) deletes from a1 any bindings which are bound in a2 difference :: Ord k => Map k a -> Map k b -> Map k a difference Tip _ = Tip difference m1@(Bin _ _ _ _ _) Tip = m1 difference m1@(Bin _ _ _ _ _) (Bin split_key2 _ _ left2 right2) = glueVBal (difference lts left2) (difference gts right2) -- The two can be way different, so we need glueVBal where lts = splitLT m1 split_key2 -- NB gt and lt, so the equal ones gts = splitGT m1 split_key2 -- are not in either. --- Filters only those keys that are bound in both of the given maps. --- CHANGED: The elements will be taken from the first map. intersection :: Ord k => Map k a -> Map k a -> Map k a intersection m1 m2 = intersectionWith (\ left _ -> left) m1 m2 --- Filters only those keys that are bound in both of the given maps --- and combines the elements as in insertWith. intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c intersectionWith _ _ Tip = Tip intersectionWith _ Tip (Bin _ _ _ _ _) = Tip intersectionWith combiner m1@(Bin _ _ _ _ _) (Bin split_key2 a2 _ left2 right2) | isJust maybe_a1 -- split_a *is* in intersection = mkVBalBranch split_key2 (combiner a1' a2) (intersectionWith combiner lts left2) (intersectionWith combiner gts right2) | otherwise -- split_a is *not* in intersection = glueVBal (intersectionWith combiner lts left2) (intersectionWith combiner gts right2) where lts = splitLT m1 split_key2 -- NB gt and lt, so the equal ones gts = splitGT m1 split_key2 -- are not in either. maybe_a1 = lookup split_key2 m1 Just a1' = maybe_a1 ------------------------------------------------------------- -- MAPPING, FOLDING, FILTERING on maps ------------------------------------------------------------- --- Folds map by given function. foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b foldrWithKey _ z Tip = z foldrWithKey k z (Bin key elt _ fm_l fm_r) = foldrWithKey k (k key elt (foldrWithKey k z fm_r)) fm_l --- Applies a given function on every element in the map. mapWithKey :: (k -> a -> b) -> Map k a -> Map k b mapWithKey _ Tip = Tip mapWithKey f (Bin key a size' m_l m_r) = Bin key (f key a) size' (mapWithKey f m_l) (mapWithKey f m_r) --- Yields a new map with only those key/element pairs matching the --- given predicate. filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a filterWithKey _ Tip = Tip filterWithKey p (Bin key a _ m_l m_r) | p key a -- Keep the item = mkVBalBranch key a (filterWithKey p m_l) (filterWithKey p m_r) | otherwise -- Drop the item = glueVBal (filterWithKey p m_l) (filterWithKey p m_r) ----------------------------------------------------- -- INTERROGATING maps ----------------------------------------------------- --- How many elements does given map contain? size :: Map _ _ -> Int size Tip = 0 size (Bin _ _ size' _ _) = size' --- Is the given finite map empty? null :: Map _ _ -> Bool null m = size m == 0 --- Does given map contain given key? member :: Ord k => k -> Map k _ -> Bool member k m = isJust (lookup k m) --- Retrieves element bound to given key lookup :: Ord k => k -> Map k a -> Maybe a lookup _ Tip = Nothing lookup key_to_find (Bin k a _ m_l m_r) = if key_to_find < k then lookup key_to_find m_l else if key_to_find == k then Just a else lookup key_to_find m_r --- Retrieves element bound to given key. --- If the element is not contained in map, return --- default value. findWithDefault :: Ord k => a -> k -> Map k a -> a findWithDefault deflt k m = case lookup k m of Nothing -> deflt Just a -> a --- Retrieves the smallest key/element pair in the finite map --- according to the basic key ordering. lookupMin :: Map k a -> Maybe (k, a) lookupMin Tip = Nothing lookupMin (Bin k x _ l _) | isBranch l = lookupMin l | otherwise = Just (k, x) --- Retrieves the greatest key/element pair in the finite map --- according to the basic key ordering. lookupMax :: Map k a -> Maybe (k, a) lookupMax Tip = Nothing lookupMax (Bin k x _ _ r) | isBranch r = lookupMax r | otherwise = Just (k, x) ---------------------------------------------------- -- LISTIFYING: transform finite maps to lists ---------------------------------------------------- --- Builds a list of key/element pairs. The list is ordered --- by the "Ord" context on keys. toList :: Map k a -> [(k, a)] toList m = foldrWithKey (\ k a rest -> (k, a) : rest) [] m --- Retrieves a list of keys contained in map. --- The list is ordered --- by the "Ord" context on keys. keys :: Map k _ -> [k] keys m = foldrWithKey (\ k _ rest -> k : rest) [] m --- Retrieves a list of elements contained in map. --- The list is ordered --- by the "Ord" context on keys. elems :: Map _ a -> [a] elems m = foldrWithKey (\ _ a rest -> a : rest) [] m --- Retrieves list of key/element pairs in preorder of the internal tree. --- Useful for lists that will be retransformed into a tree or to match --- any elements regardless of basic order. toPreOrderList :: Map k a -> [(k, a)] toPreOrderList m = pre m [] where pre Tip xs = xs pre (Bin k x _ l r) xs = (k, x) : pre l (pre r xs) --- Sorts a given list by inserting and retrieving from map. --- Duplicates are deleted. sortWithMap :: Ord k => [k] -> [k] sortWithMap l = keys (fromList (zip l (repeat ()))) ----------------------------------------------------- -- internal Implementation ----------------------------------------------------- data Map k a = Tip | Bin k a -- Key and element stored here Int{-STRICT-} -- Size >= 1 (Map k a) -- Children (Map k a) deriving (Show, Read) instance (Eq k, Eq a) => Eq (Map k a) where m_1 == m_2 = (size m_1 == size m_2) && -- quick test (toList m_1 == toList m_2) isBranch :: Map _ _ -> Bool isBranch (Bin _ _ _ _ _) = True isBranch Tip = False ------------------------------------------------------------------------- -- - -- The implementation of balancing - -- - ------------------------------------------------------------------------- ------------------------------------------------------------------------- -- - -- Basic construction of a FiniteMap - -- - ------------------------------------------------------------------------- sIZE_RATIO :: Int sIZE_RATIO = 5 mkBranch :: Int -> key -> elt -> Map key elt -> Map key elt -> Map key elt mkBranch _{-which-} key elt fm_l fm_r = let result = Bin key elt (unbox (1 + left_size + right_size)) fm_l fm_r in result -- if size result <= 8 then -- result -- else -- pprTrace ("mkBranch:"++(show which)) (ppr result) ( -- result -- ) where {-left_ok = case fm_l of Tip -> True Bin _ _ _ _ _ -> cmpWithBiggest_left_key key cmpWithBiggest_left_key key' = (fst (findMax fm_l)) < key' right_ok = case fm_r of Tip -> True Bin _ _ _ _ _ -> cmpWithSmallest_right_key key cmpWithSmallest_right_key key' = key' < (fst (findMin fm_r)) balance_ok = True -- sigh-} left_size = size fm_l right_size = size fm_r unbox :: Int -> Int unbox x = x ------------------------------------------------------------------------- -- - -- Balanced construction of a FiniteMap - -- - ------------------------------------------------------------------------- mkBalBranch :: key -> elt -> Map key elt -> Map key elt -> Map key elt mkBalBranch key elt fm_L fm_R | size_l + size_r < 2 = mkBranch 1{-which-} key elt fm_L fm_R | size_r > sIZE_RATIO * size_l -- Right tree too big = case fm_R of Bin _ _ _ fm_rl fm_rr -> if size fm_rl < 2 * size fm_rr then single_L fm_L fm_R else double_L fm_L fm_R -- Other case impossible Tip -> error "Data.Map.mkBalBranch" | size_l > sIZE_RATIO * size_r -- Left tree too big = case fm_L of Bin _ _ _ fm_ll fm_lr -> if size fm_lr < 2 * size fm_ll then single_R fm_L fm_R else double_R fm_L fm_R -- Other case impossible Tip -> error "Data.Map.mkBalBranch" | otherwise -- No imbalance = mkBranch 2{-which-} key elt fm_L fm_R where size_l = size fm_L size_r = size fm_R single_L fm_l (Bin key_r elt_r _ fm_rl fm_rr) = mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr single_L _ Tip = error "Data.Map.single_L" double_L fm_l (Bin key_r elt_r _ (Bin key_rl elt_rl _ fm_rll fm_rlr) fm_rr) = mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key elt fm_l fm_rll) (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr) double_L _ Tip = error "Data.Map.double_L" double_L _ (Bin _ _ _ Tip _) = error "Data.Map.double_L" single_R (Bin key_l elt_l _ fm_ll fm_lr) fm_r = mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r) single_R Tip _ = error "Data.Map.single_R" double_R (Bin key_l elt_l _ fm_ll (Bin key_lr elt_lr _ fm_lrl fm_lrr)) fm_r = mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll fm_lrl) (mkBranch 12{-which-} key elt fm_lrr fm_r) double_R Tip _ = error "Data.Map.double_R" double_R (Bin _ _ _ _ Tip) _ = error "Data.Map.double_R" mkVBalBranch :: Ord key => key -> elt -> Map key elt -> Map key elt -> Map key elt -- Assert: in any call to (mkVBalBranch_C comb key elt l r), -- (a) all keys in l are < all keys in r -- (b) all keys in l are < key -- (c) all keys in r are > key mkVBalBranch key elt Tip fm_r = insert key elt fm_r mkVBalBranch key elt (Bin key_l elt_l s_l fm_ll fm_lr) Tip = insert key elt (Bin key_l elt_l s_l fm_ll fm_lr) mkVBalBranch key elt (Bin key_l elt_l s_l fm_ll fm_lr) (Bin key_r elt_r s_r fm_rl fm_rr) | sIZE_RATIO * size_l < size_r = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr | sIZE_RATIO * size_r < size_l = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r) | otherwise = mkBranch 13{-which-} key elt fm_l fm_r where fm_l = Bin key_l elt_l s_l fm_ll fm_lr fm_r = Bin key_r elt_r s_r fm_rl fm_rr size_l = size fm_l size_r = size fm_r ------------------------------------------------------------------------- -- - -- Gluing two trees together - -- - ------------------------------------------------------------------------- glueBal :: Map key elt -> Map key elt -> Map key elt glueBal fm1 fm2 = if null fm1 then fm2 else if null fm2 then fm1 else -- The case analysis here (absent in Adams' program) is really to deal -- with the case where fm2 is a singleton. Then deleting the minimum means -- we pass an empty tree to mkBalBranch, which breaks its invariant. let (mid_key1, mid_elt1) = findMax fm1 (mid_key2, mid_elt2) = findMin fm2 in if size fm2 > size fm1 then mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2) else mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2 glueVBal :: Map key elt -> Map key elt -> Map key elt glueVBal fm_l fm_r = if null fm_l then fm_r else if null fm_r then fm_l else let Bin key_l elt_l _ fm_ll fm_lr = fm_l Bin key_r elt_r _ fm_rl fm_rr = fm_r --(mid_key_l,mid_elt_l) = findMax fm_l --(mid_key_r,mid_elt_r) = findMin fm_r size_l = size fm_l size_r = size fm_r in if sIZE_RATIO * size_l < size_r then mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr else if sIZE_RATIO * size_r < size_l then mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r) -- We now need the same two cases as in glueBal above. else glueBal fm_l fm_r ------------------------------------------------------------------------- -- - -- Local utilities - -- - ------------------------------------------------------------------------- splitLT, splitGT :: Ord key => Map key elt -> key -> Map key elt -- splitLT fm split_key = fm restricted to keys < split_key -- splitGT fm split_key = fm restricted to keys > split_key splitLT Tip _ = Tip splitLT (Bin key elt _ fm_l fm_r) split_key = if split_key < key then splitLT fm_l split_key else if split_key == key then fm_l else mkVBalBranch key elt fm_l (splitLT fm_r split_key) splitGT Tip _ = Tip splitGT (Bin key elt _ fm_l fm_r) split_key = if split_key < key then mkVBalBranch key elt (splitGT fm_l split_key) fm_r else if split_key == key then fm_r else splitGT fm_r split_key findMin :: Map key elt -> (key, elt) findMin Tip = error "Data.Map.findMin: empty map" findMin (Bin key elt _ Tip _) = (key, elt) findMin (Bin _ _ _ (Bin key_l elt_l s_l fm_ll fm_lr)_) = findMin (Bin key_l elt_l s_l fm_ll fm_lr) deleteMin :: Map key elt -> Map key elt deleteMin Tip = error "Data.Map.deleteMin: empty map" deleteMin (Bin _ _ _ Tip fm_r) = fm_r deleteMin (Bin key elt _ (Bin key_l elt_l s_l fm_ll fm_lr) fm_r) = mkBalBranch key elt (deleteMin (Bin key_l elt_l s_l fm_ll fm_lr)) fm_r findMax :: Map key elt -> (key,elt) findMax Tip = error "Data.Map.findMax: empty map" findMax (Bin key elt _ _ Tip) = (key, elt) findMax (Bin _ _ _ _ (Bin key_r elt_r s_r fm_rl fm_rr)) = findMax (Bin key_r elt_r s_r fm_rl fm_rr) deleteMax :: Map key elt -> Map key elt deleteMax Tip = error "FiniteMap.deleteMax: empty map" deleteMax (Bin _ _ _ fm_l Tip) = fm_l deleteMax (Bin key elt _ fm_l (Bin key_r elt_r s_r fm_rl fm_rr)) = mkBalBranch key elt fm_l (deleteMax (Bin key_r elt_r s_r fm_rl fm_rr)) curry-tools-v3.3.0/cpm/vendor/containers/src/Data/Set.curry000066400000000000000000000036741377556325500237430ustar00rootroot00000000000000----------------------------------------------------------------------------- --- An efficient implementation of set based on finite maps. ----------------------------------------------------------------------------- module Data.Set ( Set, null, size, fromList, empty, insert, member, delete , union, toList, difference ) where import qualified Data.Map as Map ------------------------------------------------------------------------- -- - -- FiniteSets --- a thin veneer - -- - ------------------------------------------------------------------------- --- The type of sets of elements. type Set key = Map.Map key () --- Returns an empty set. empty :: Set key empty = Map.empty --- Transforms a list into a set of its elements. fromList :: Ord key => [key] -> Set key fromList xs = Map.fromList [ (x, ()) | x <- xs] --- Test for an empty set. null :: Set key -> Bool null = Map.null --- Inserts an element into a set if it is not already there. insert :: Ord key => key -> Set key -> Set key insert k s = Map.insert k () s --- Deletes an element from a set. delete :: Ord key => key -> Set key -> Set key delete k s = Map.delete k s --- Computes the size of two sets. size :: Set key -> Int size = Map.size --- Returns `True` if an element is contained in a set. --- @param e - an element to be checked for containment --- @param s - a set --- @return `True` if `e` is contained in `s` member :: Ord key => key -> Set key -> Bool member = Map.member --- Computes the difference of two sets. difference :: Ord key => Set key -> Set key -> Set key difference = Map.difference --- Transforms a set into an ordered list of its elements. toList :: Set key -> [key] toList = Map.keys --- Computes the union of two sets. union :: Ord key => Set key -> Set key -> Set key union = Map.union curry-tools-v3.3.0/cpm/vendor/containers/test/000077500000000000000000000000001377556325500214275ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/containers/test/TestMap.curry000066400000000000000000000055261377556325500241020ustar00rootroot00000000000000import Data.List hiding (union) import Data.Maybe import Prelude hiding (lookup) import System.Random import Test.Prop import Data.Map fm f = f . fromList . map (\x ->(x,x)) fms f = map fst . toList . fm f fms' f = map snd . toList . fm f so f = spnub . sortBy (<) . f testInsert = eq (fms (\x-> insert 73 73 x)) (so (73:)) testDeleteAll = test (\nums -> fms (deleteAll (take 500 nums)) nums == so (drop 500) nums) testUnion = test (\nums -> let l=length nums (xs,ys) = splitAt (div l 2) nums in (map fst $ toList $ union (fm id xs) (fm id ys)) == so id nums) testDifference = test (\nums -> let l = length nums (xs,ys) = splitAt (div l 2) nums in (map fst $ toList $ difference (fm id nums) (fm id ys)) == so id xs) testIntersection = test (\nums -> let l=length nums (_,ys) = splitAt (div l 2) nums in (map fst $ toList $ intersection (fm id ys) (fm id nums)) == so id ys) testFoldrWithKey = eq (fm (foldrWithKey (\x _ z->x+z) 0)) (foldl (+) 0) testMapWithKey = eq (fms' (mapWithKey (\_ z->z+1))) (so (map (+1))) testFilterFM = eq (fms (filterWithKey (\x _->x>0))) (so (filter (>0))) testSize = eq (fm size) length testMember_Lookup = eq (fm (\x-> member 73 (insert 73 73 x))) (const True) testKeys_elems = test (\nums -> let finm=fm id nums in unzip (toList finm)==(keys finm, elems finm)) testSortWithMap = eq sortWithMap (so id) testMin_Max = eq (fm (\finm -> (fst $ fromJust $ lookupMin finm, fst $ fromJust $ lookupMax finm))) ((\l->(head l,last l)) .so id) testAdjust = eq (fm (\x-> lookup 73 (adjust (+7) 73 (insert 73 73 x)))) (const $ Just 80) spnub [] = [] spnub [x] = [x] spnub (x:y:xs) = if x==y then spnub (y:xs) else x:spnub (y:xs) ------------------------------------------------------------------------------ -- Random test: --- Tests a given predicate on a list of distinct random numbers. --- In case of a failure, the list of random numbers is returned --- in order to see the test cases in the CurryTest tool. test :: ([Int] -> Bool) -> PropIO test f = (rndList lenRnds >>= \xs -> return (if f xs then Nothing else Just xs)) `returns` Nothing --- Tests whether two operations return equal results --- on a list of distinct random numbers. --- In case of a failure, the list of random numbers is returned --- in order to see the test cases in the CurryTest tool. eq :: Eq a => ([Int] -> a) -> ([Int] -> a) -> PropIO eq f g = test (\x -> (f x)==(g x)) --- generate a list of at most n random numbers (without duplicated elements) rndList :: Int -> IO [Int] rndList n = getRandomSeed >>= return . nub . take n . (flip nextIntRange 100000) --- maximal length of test lists lenRnds :: Int lenRnds = 1000 ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/containers/test/TestSet.curry000066400000000000000000000010501377556325500241040ustar00rootroot00000000000000-- Some tests for sets (to be extended...) import Prelude hiding ( null ) import Test.Prop import Data.Set testSizeFromList1 :: Int -> Prop testSizeFromList1 m = size (fromList [1 .. n]) -=- n where n = toPos m testSizeFromList2 :: Int -> Prop testSizeFromList2 m = size (fromList [n, n-1 .. 1] `union` fromList [1 .. n]) -=- n where n = toPos m testDeleteAll :: Int -> Prop testDeleteAll m = always (null (foldr delete (fromList [1 .. n]) [1 .. n])) where n = toPos m toPos :: Int -> Int toPos n | n < 0 = 2 * abs n | otherwise = n curry-tools-v3.3.0/cpm/vendor/csv/000077500000000000000000000000001377556325500170765ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/csv/LICENSE000066400000000000000000000027351377556325500201120ustar00rootroot00000000000000Copyright (c) 2017, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/csv/README.md000066400000000000000000000005541377556325500203610ustar00rootroot00000000000000csv: Reading/writing files in CSV format ======================================== This package contains a library with operations to read and write files CSV (comma separated values) format. Files in CSV format can be imported and exported by most spreadsheed and database applications. -------------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/csv/package.json000066400000000000000000000011521377556325500213630ustar00rootroot00000000000000{ "name": "csv", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library for reading/writing files in CSV format", "category": [ "Data", "Parsing" ], "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Text.CSV" ], "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "license": "BSD-3-Clause", "licenseFile": "LICENSE", "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/csv.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/csv/src/000077500000000000000000000000001377556325500176655ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/csv/src/Text/000077500000000000000000000000001377556325500206115ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/csv/src/Text/CSV.curry000066400000000000000000000070711377556325500223370ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for reading/writing files in CSV format. --- Files in CSV (comma separated values) format can be imported and exported --- by most spreadsheed and database applications. --- --- @author Michael Hanus --- @version September 2004 --- @category general ------------------------------------------------------------------------------ module Text.CSV ( showCSV, readCSV, readCSVWithDelims , writeCSVFile, readCSVFile, readCSVFileWithDelims ) where import Data.List (intersperse) --- Writes a list of records (where each record is a list of strings) --- into a file in CSV format. --- @param fname - the name of the result file (with standard suffix ".csv") --- @param rows - the list of rows writeCSVFile :: String -> [[String]] -> IO () writeCSVFile fname rows = writeFile fname (showCSV rows) --- Shows a list of records (where each record is a list of strings) --- as a string in CSV format. showCSV :: [[String]] -> String showCSV rows = concatMap showCSVLine rows --- Shows a list of strings as a line in CSV format. showCSVLine :: [String] -> String showCSVLine row = concat (intersperse "," (map convert row)) ++ "\n" where -- enclose in quotation marks if necessary: convert s = if any (\c->c `elem` ['"',',',';',':','\n']) s then '"' : concatMap (\c->if c=='"' then [c,c] else [c]) s ++ "\"" else s --- Reads a file in CSV format and returns the list of records --- (where each record is a list of strings). --- @param fname - the name of the result file (with standard suffix ".csv") readCSVFile :: String -> IO [[String]] readCSVFile = readCSVFileWithDelims [','] --- Reads a file in CSV format and returns the list of records --- (where each record is a list of strings). --- @param delims - the list of characters considered as delimiters --- @param fname - the name of the result file (with standard suffix ".csv") readCSVFileWithDelims :: [Char] -> String -> IO [[String]] readCSVFileWithDelims delims fname = do contents <- readFile fname return (readCSVWithDelims delims contents) --- Reads a string in CSV format and returns the list of records --- (where each record is a list of strings). --- @param str - the string in CSV format readCSV :: String -> [[String]] readCSV = readCSVWithDelims [','] --- Reads a string in CSV format and returns the list of records --- (where each record is a list of strings). --- @param delims - the list of characters considered as delimiters --- @param str - the string in CSV format readCSVWithDelims :: [Char] -> String -> [[String]] readCSVWithDelims delims str = map (components delims) (lines str) --- Breaks a string in CSV record format into a list of components. components :: [Char] -> String -> [String] components _ [] = [[]] components delims (c:cs) = if c=='"' then breakString cs else let (e,s) = break (`elem` delims) (c:cs) in e : (if null s then [] else components delims (tail s)) where breakString [] = delimError breakString [x] = if x=='"' then [[]] else delimError breakString (x:y:zs) | x=='"' && y=='"' = let (b:bs) = breakString zs in (x:b):bs | x=='"' && y `elem` delims = []:components delims zs | otherwise = let (b:bs) = breakString (y:zs) in (x:b):bs delimError = error "Missing closing delimiter in CSV record!" -- Examples: -- writeCSVFile "tmp.csv" [["Name","Value"],["aa\"bb,cc","1"]] -- readCSVFile "tmp.csv" curry-tools-v3.3.0/cpm/vendor/currypath/000077500000000000000000000000001377556325500203245ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/currypath/LICENSE000066400000000000000000000027351377556325500213400ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/currypath/README.md000066400000000000000000000003221377556325500216000ustar00rootroot00000000000000currypath ========= This package provides the library `System.CurryPath` which contains operations to deal with module names and paths used in a Curry system, like finding a module in the standard load path. curry-tools-v3.3.0/cpm/vendor/currypath/package.json000066400000000000000000000013001377556325500226040ustar00rootroot00000000000000{ "name": "currypath", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Operations to deal with Curry module names and paths", "category": [ "System" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "directory" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0", "process" : ">= 3.0.0, < 4.0.0", "propertyfile": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.CurryPath" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/currypath.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/currypath/src/000077500000000000000000000000001377556325500211135ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/currypath/src/System/000077500000000000000000000000001377556325500223775ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/currypath/src/System/CurryPath.curry000066400000000000000000000261701377556325500254140ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains operations related to module names and paths --- used in Curry system. --- --- @author Bernd Brassel, Michael Hanus, Bjoern Peemoeller, Finn Teegen --- @version December 2020 ------------------------------------------------------------------------------ module System.CurryPath ( ModuleIdent , splitProgramName, splitValidProgramName, isValidModuleName , runModuleAction , splitModuleFileName, splitModuleIdentifiers , joinModuleIdentifiers , stripCurrySuffix , ModulePath, modNameToPath , currySubdir, inCurrySubdir, inCurrySubdirModule, addCurrySubdir , sysLibPath, getLoadPathForModule , lookupModuleSourceInLoadPath, lookupModuleSource , curryrcFileName ) where import Control.Monad ( unless ) import Curry.Compiler.Distribution ( curryCompiler, curryCompilerMajorVersion , curryCompilerMinorVersion , curryCompilerRevisionVersion , installDir ) import Data.Char ( toLower ) import Data.List ( init, intercalate, last, split ) import System.Directory ( doesFileExist, getCurrentDirectory , getHomeDirectory, setCurrentDirectory ) import System.Environment ( getEnv ) import System.Process ( system ) import System.FilePath ( FilePath, (), (<.>), addTrailingPathSeparator , dropFileName, joinPath, splitDirectories , splitExtension, splitFileName, splitPath , splitSearchPath , takeFileName, takeExtension, dropExtension ) import Data.PropertyFile ( getPropertyFromFile ) ------------------------------------------------------------------------------ --- Functions for handling file names of Curry modules ------------------------------------------------------------------------------ type ModuleIdent = String --- Splits a program name, i.e., a module name possibly prefixed by --- a directory, into the directory and the module name. --- A possible suffix like `.curry` or `.lcurry` is dropped from the --- module name. --- For instance `splitProgramName "lib/Data.Set.curry"` evaluates --- to `("lib","Data.Set")`. splitProgramName :: String -> (FilePath, ModuleIdent) splitProgramName s | null ps = (".", "") | null (tail ps) = (".", head ps) | otherwise = (concat (init ps), last ps) where ps = splitPath (stripCurrySuffix s) --- Splits a program name, i.e., a module name possibly prefixed by --- a directory, into the directory and a *valid* module name. --- A possible suffix like `.curry` or `.lcurry` is dropped from the --- module name. --- For instance `splitValidProgramName "lib/Data.Set.curry"` evaluates --- to `("lib","Data.Set")`. --- An error is raised if the program name is empty or the module name --- is not valid. splitValidProgramName :: String -> (FilePath, ModuleIdent) splitValidProgramName s | null mname = error $ "The module name is empty." | not (isValidModuleName mname) = error $ "The program name '" ++ s ++ "' contains an invalid module name." | otherwise = (dir,mname) where (dir,mname) = splitProgramName s --- Is the given string a valid module name? isValidModuleName :: String -> Bool isValidModuleName = all isModId . split (=='.') where isModId [] = False isModId (c:cs) = isAlpha c && all (\x -> isAlphaNum x || x `elem` "_'") cs --- Executes an I/O action, which is parameterized over a module name, --- for a given program name. If the program name is prefixed by a directory, --- switch to this directory before executing the action. --- A possible suffix like `.curry` or `.lcurry` is dropped from the --- module name passed to the action. --- An error is raised if the module name is not valid. runModuleAction :: (String -> IO a) -> String -> IO a runModuleAction modaction progname = do let (progdir,mname) = splitValidProgramName progname curdir <- getCurrentDirectory unless (progdir == ".") $ do putStrLn $ "Switching to directory '" ++ progdir ++ "'..." setCurrentDirectory progdir result <- modaction mname unless (progdir == ".") $ setCurrentDirectory curdir return result --- Split the `FilePath` of a module into the directory prefix and the --- `FilePath` corresponding to the module name. --- For instance, the call `splitModuleFileName "Data.Set" "lib/Data/Set.curry"` --- evaluates to `("lib", "Data/Set.curry")`. --- This can be useful to compute output directories while retaining the --- hierarchical module structure. splitModuleFileName :: ModuleIdent -> FilePath -> (FilePath, FilePath) splitModuleFileName mid fn = case splitModuleIdentifiers mid of [_] -> splitFileName fn ms -> let (base, ext) = splitExtension fn dirs = splitDirectories base (pre , suf) = splitAt (length dirs - length ms) dirs path = if null pre then "" else addTrailingPathSeparator (joinPath pre) in (path, joinPath suf <.> ext) --- Split up the components of a module identifier. For instance, --- `splitModuleIdentifiers "Data.Set"` evaluates to `["Data", "Set"]`. splitModuleIdentifiers :: ModuleIdent -> [String] splitModuleIdentifiers = split (=='.') --- Join the components of a module identifier. For instance, --- `joinModuleIdentifiers ["Data", "Set"]` evaluates to `"Data.Set"`. joinModuleIdentifiers :: [String] -> ModuleIdent joinModuleIdentifiers = foldr1 combine where combine xs ys = xs ++ '.' : ys --- Strips the suffix `.curry` or `.lcurry` from a file name. stripCurrySuffix :: String -> String stripCurrySuffix s = if takeExtension s `elem` [".curry",".lcurry"] then dropExtension s else s --- A module path consists of a directory prefix (which can be omitted) --- and a module name (which can be hierarchical). For instance, the --- following strings are module paths in Unix-based systems: --- --- HTML --- Data.Number.Int --- curry/Data.Number.Int type ModulePath = String --- Transforms a hierarchical module name into a path name, i.e., --- replace the dots in the name by directory separator chars. modNameToPath :: ModuleIdent -> String modNameToPath = foldr1 () . split (=='.') --- Name of the sub directory where auxiliary files (.fint, .fcy, etc) --- are stored. Note that the name of this directory depends --- on the compiler to avoid confusion when using different compilers. --- For instance, when using PAKCS 3.2.0, `currySubdir` evaluates --- to `".curry/pakcs-3.2.0"`. currySubdir :: FilePath currySubdir = ".curry" curryCompiler ++ "-" ++ intercalate "." (map show [curryCompilerMajorVersion, curryCompilerMinorVersion, curryCompilerRevisionVersion]) --- Transforms a path to a module name into a file name --- by adding the result of 'currySubDir' to the path and transforming --- a hierarchical module name into a path. --- For instance, when using PAKCS 3.2.0, `inCurrySubdir "mylib/Data.Char"` --- evaluates to `"mylib/.curry/pakcs-3.2.0/Data/Char"`. inCurrySubdir :: FilePath -> FilePath inCurrySubdir filename = let (base,file) = splitFileName filename in base currySubdir modNameToPath file --- Transforms a file name by adding the currySubDir to the file name. --- This version respects hierarchical module names. inCurrySubdirModule :: ModuleIdent -> FilePath -> FilePath inCurrySubdirModule m fn = let (dirP, modP) = splitModuleFileName m fn in dirP currySubdir modP --- Transforms a directory name into the name of the corresponding --- sub directory containing auxiliary files. addCurrySubdir :: FilePath -> FilePath addCurrySubdir dir = dir currySubdir ------------------------------------------------------------------------------ --- Finding files in correspondence to compiler load path ------------------------------------------------------------------------------ --- Returns the current path (list of directory names) of the --- system libraries. sysLibPath :: [String] sysLibPath = case curryCompiler of "pakcs" -> [installDir "lib"] "kics" -> [installDir "src" "lib"] "kics2" -> [installDir "lib"] _ -> error "Distribution.sysLibPath: unknown curryCompiler" --- Returns the current path (list of directory names) that is --- used for loading modules w.r.t. a given module path. --- The directory prefix of the module path (or "." if there is --- no such prefix) is the first element of the load path and the --- remaining elements are determined by the environment variable --- CURRYRPATH and the entry "libraries" of the system's rc file. getLoadPathForModule :: ModulePath -> IO [String] getLoadPathForModule modpath = do rcfile <- curryrcFileName mblib <- getPropertyFromFile rcfile "libraries" let fileDir = dropFileName modpath if curryCompiler `elem` ["pakcs","kics","kics2"] then do currypath <- getEnv "CURRYPATH" let llib = maybe [] (\l -> if null l then [] else splitSearchPath l) mblib return $ (fileDir : (if null currypath then [] else splitSearchPath currypath) ++ llib ++ sysLibPath) else error "Distribution.getLoadPathForModule: unknown curryCompiler" --- Returns a directory name and the actual source file name for a module --- by looking up the module source in the current load path. --- If the module is hierarchical, the directory is the top directory --- of the hierarchy. --- Returns Nothing if there is no corresponding source file. lookupModuleSourceInLoadPath :: ModulePath -> IO (Maybe (String,String)) lookupModuleSourceInLoadPath modpath = do loadpath <- getLoadPathForModule modpath lookupModuleSource loadpath modpath --- Returns a directory name and the actual source file name for a module --- by looking up the module source in the load path provided as the --- first argument. --- If the module is hierarchical, the directory is the top directory --- of the hierarchy. --- Returns Nothing if there is no corresponding source file. lookupModuleSource :: [String] -> String -> IO (Maybe (String,String)) lookupModuleSource loadpath mod = lookupSourceInPath loadpath where fn = takeFileName mod fnlcurry = modNameToPath fn ++ ".lcurry" fncurry = modNameToPath fn ++ ".curry" lookupSourceInPath [] = return Nothing lookupSourceInPath (dir:dirs) = do lcurryExists <- doesFileExist (dir fnlcurry) if lcurryExists then return (Just (dir, dir fnlcurry)) else do curryExists <- doesFileExist (dir fncurry) if curryExists then return (Just (dir, dir fncurry)) else lookupSourceInPath dirs ------------------------------------------------------------------------------ --- The name of the file specifying resource configuration parameters of the --- current distribution. --- This file must have the usual format of property files. curryrcFileName :: IO FilePath curryrcFileName = getHomeDirectory >>= return . ( rcFile) where rcFile = '.' : curryCompiler ++ "rc" ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/det-parse/000077500000000000000000000000001377556325500201675ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/det-parse/README.md000066400000000000000000000062301377556325500214470ustar00rootroot00000000000000# det-parse det-parse is a library of deterministic parser combinators. It is based on the material presented in Frank Huch's functional programming lecture at Kiel University. To use it, you build a `Parser a` using the provided combinators and then apply it to a string using `parse`. The simplest parsers are provided by the primitives `yield`, `failure`, `anyChar` and `check`. `yield` always results in the given value, consuming no input. `yield 1` will successfully parse the empty string to the value `1`. `failure` is a parser that always fails. `anyChar` is a parser that consumes a single character and uses it as the parse result. `check` takes a parser and a predicate on the result type of the parser. From these, it builds a new parser that applies the existing parser and succeeds only if the predicate holds for the parse result. `char` and `word` build parsers for single characters and whole strings from these primitives. `char 'c'` is a parser that consumes the single character `c` and results in the unit value `()`. `word "hello"` consumes the string `hello` and results in the unit value. `empty` is a parser that recognizes an empty string and results in the unit value. The operators `*>` and `<*` are provided to combine parsers into more comples ones. `*>` applies two parsers and returns the result of the second one if both were successful. `char 'a' *> yield 1` is successful if applied to the string `a` and results in the value `1`. `<*` applies two parsers in the same order, i.e. left to right, but returns the result of the first one. `<|>` combines two parsers by applying them both. If the first one is successful, it returns its result. If it is not, but the second one is, then it returns the result of the second one. If both are unsuccessful, the combined parser is unsuccessful as well. The parser `char 'a' *> yield 1 <|> char 'b' *> yield 2` parses the string `a` to the value `1` and the string `b` to the value `2`. `` works similarly to `<|>`, but does not backtrack. That is, it only tries the second parser if the first one was unsuccessful, and only on the remaining input. It can be used if the alternatives do not overlap. The above example would also work if `<|>` were replaced by ``, while `word "ab" *> yield 1 word "abc" *> yield 2` would fail to parse `abc` into the value `2` since the first alternative has already consumed `ab`. `<$>` builds a new parser from an existing parser by applying a function to the result of that parser. For example, `(+ 1) <$> (char 'a' *> yield 1)` is a parser that parses the string `a` into the value `2`. `<*> :: Parser (a -> b) -> Parser a -> Parser b ` combines two parsers, one that results in a function from `a` to `b`, and one that results in an `a` value. It applies the parsers in order and then applies the function result of the first parser to the value result of the second parser. `many :: Parser a -> Parser [a]` builds a parser that parses whatever the original parser parses arbitrarily many times. `some` is similar, but requires that the original parser succeed at least once. Applying `many (char 'a' *> yield 1)` to the string `aaaa` results in the value `[1,1,1,1]`. curry-tools-v3.3.0/cpm/vendor/det-parse/package.json000066400000000000000000000007451377556325500224630ustar00rootroot00000000000000{ "name": "det-parse", "version": "3.0.0", "synopsis": "Deterministic parser combinators", "category": [ "Parsing" ], "author": "Jonas Oberschweiber", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/det-parse.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/det-parse/src/000077500000000000000000000000001377556325500207565ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/det-parse/src/DetParse.curry000066400000000000000000000062701377556325500235600ustar00rootroot00000000000000module DetParse where import Prelude hiding ((<$>)) --- A parser type Parser a = String -> [(a, String)] --- Applies a parser to a string. If it succeeds, returns the result of the --- parser. Returns `Nothing` if it does not. parse :: Parser a -> String -> Maybe a parse p s = case filter (null . snd) $ p s of ((x, _):_) -> Just x _ -> Nothing --- A parser that always fails. failure :: Parser a failure = \_ -> [] --- A parser that consumes no input and results in the given value. yield :: a -> Parser a yield x = \s -> [(x, s)] --- A parser that consumes no input and results in the unit value. empty :: Parser () empty = yield () --- A parser that consumes an arbitrary single character. anyChar :: Parser Char anyChar = \s -> case s of [] -> [] (c:cs) -> [(c,cs)] --- Builds a parser that succeeds if the predicate holds on the result of the --- original parser. check :: (a -> Bool) -> Parser a -> Parser a check ok p = filter (ok . fst) . p --- Builds a parser that consumes a specific character and results in the unit --- value. char :: Char -> Parser () char c = check (c==) anyChar *> yield () --- Builds a parser that consumes the given string and results in the unit --- value. word :: String -> Parser () word [] = empty word (c:cs) = char c *> word cs infixl 3 <|>, --- Builds a parser that tries both its argument parsers and results in the --- result of the first one to succeed. (<|>) :: Parser a -> Parser a -> Parser a p <|> q = \s -> p s ++ q s --- Builds a parser that tries its first argument parser and alternatively, if --- the first one does not succeed, its second argument parser. In contrast to --- `<|>`, this combinator does not backtrack. The second parser is applied to --- the leftovers of the first parser. Use it if the alternatives are mutually --- exclusive. () :: Parser a -> Parser a -> Parser a p q = \s -> case p s of [] -> q s xs -> xs infixl 4 <$> --- Builds a parser that applies a function to the result of the original --- parser. (<$>) :: (a -> b) -> Parser a -> Parser b f <$> p = map (\(x, s) -> (f x, s)) . p infixl 4 <*>, <*, *> --- Applies the function returned by the first parser to the result of the --- second parser. Applies the parsers in order. (<*>) :: Parser (a -> b) -> Parser a -> Parser b p <*> q = \s -> [ (f x, s2) | (f, s1) <- p s, (x, s2) <- q s1 ] --- Builds a parser that applies both parsers in order and returns the result of --- the first one. (<*) :: Parser a -> Parser b -> Parser a p <* q = (\x _ -> x) <$> p <*> q --- Builds a parser that applies both parsers in order and returns the result of --- the second one. (*>) :: Parser a -> Parser b -> Parser b p *> q = (\_ y -> y) <$> p <*> q infixl 1 *>= (*>=) :: Parser a -> (a -> Parser b) -> Parser b p *>= f = \s -> [ (y, s2) | (x, s1) <- p s, (y, s2) <- (f x) s1 ] --- Builds a parser that will apply the original parser arbitrarily many times. many :: Parser a -> Parser [a] many p = some p <|> yield [] --- Builds a parser that will apply the original parser at least once. some :: Parser a -> Parser [a] some p = (:) <$> p <*> many p curry-tools-v3.3.0/cpm/vendor/directory/000077500000000000000000000000001377556325500203075ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/directory/LICENSE000066400000000000000000000027351377556325500213230ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/directory/package.json000066400000000000000000000014611377556325500225770ustar00rootroot00000000000000{ "name": "directory", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library for accessing the directory structure of the underlying operating system.", "category": [ "System" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "filepath": ">= 3.0.0, < 4.0.0", "time" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.Directory" ], "testsuite": { "src-dir": "test", "modules": [ "TestDirectory" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/directory.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/directory/src/000077500000000000000000000000001377556325500210765ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/directory/src/System/000077500000000000000000000000001377556325500223625ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/directory/src/System/Directory.curry000066400000000000000000000142261377556325500254210ustar00rootroot00000000000000--- Library for accessing the directory structure of the --- underlying operating system. --- --- @author Michael Hanus --- @version January 2013 --- @category general module System.Directory ( doesFileExist, doesDirectoryExist, getFileSize, getModificationTime , getCurrentDirectory, setCurrentDirectory , getDirectoryContents, createDirectory, createDirectoryIfMissing , removeDirectory, renameDirectory , getHomeDirectory, getTemporaryDirectory , getAbsolutePath , removeFile, renameFile, copyFile , findFileWithSuffix, getFileWithSuffix ) where import System.FilePath ( FilePath, (), splitDirectories, isAbsolute , normalise, pathSeparator, searchPathSeparator) import System.Environment (getEnv, isWindows) import Data.List (isPrefixOf, scanl1, last, intersperse) import Data.Time (ClockTime) --- Returns true if the argument is the name of an existing file. doesFileExist :: FilePath -> IO Bool doesFileExist fname = prim_doesFileExist $## fname prim_doesFileExist :: FilePath -> IO Bool prim_doesFileExist external --- Returns true if the argument is the name of an existing directory. doesDirectoryExist :: FilePath -> IO Bool doesDirectoryExist dir = prim_doesDirectoryExist $## dir prim_doesDirectoryExist :: FilePath -> IO Bool prim_doesDirectoryExist external --- Returns the size of the file. getFileSize :: FilePath -> IO Int getFileSize fname = prim_fileSize $## fname prim_fileSize :: FilePath -> IO Int prim_fileSize external --- Returns the modification time of the file. getModificationTime :: FilePath -> IO ClockTime getModificationTime fname = prim_getModificationTime $## fname prim_getModificationTime :: FilePath -> IO ClockTime prim_getModificationTime external --- Returns the current working directory. getCurrentDirectory :: IO FilePath getCurrentDirectory external --- Sets the current working directory. setCurrentDirectory :: FilePath -> IO () setCurrentDirectory dir = prim_setCurrentDirectory $## dir prim_setCurrentDirectory :: FilePath -> IO () prim_setCurrentDirectory external --- Returns the list of all entries in a directory. getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents dir = prim_getDirectoryContents $## dir prim_getDirectoryContents :: FilePath -> IO [FilePath] prim_getDirectoryContents external --- Creates a new directory with the given name. createDirectory :: FilePath -> IO () createDirectory dir = prim_createDirectory $## dir prim_createDirectory :: FilePath -> IO () prim_createDirectory external --- Creates a new directory with the given name if it does not already exist. --- If the first parameter is `True` it will also create all missing --- parent directories. createDirectoryIfMissing :: Bool -> FilePath -> IO () createDirectoryIfMissing createParents path = if createParents then createDirs parents else createDirs [last parents] where parents = scanl1 () $ splitDirectories $ path createDirs [] = return () createDirs (d:ds) = do exists <- doesDirectoryExist d if exists then return () else createDirectory d createDirs ds --- Deletes a directory from the file system. removeDirectory :: FilePath -> IO () removeDirectory dir = prim_removeDirectory $## dir prim_removeDirectory :: FilePath -> IO () prim_removeDirectory external --- Renames a directory. renameDirectory :: FilePath -> FilePath -> IO () renameDirectory dir1 dir2 = (prim_renameDirectory $## dir1) $## dir2 prim_renameDirectory :: FilePath -> FilePath -> IO () prim_renameDirectory external --- Returns the home directory of the current user. getHomeDirectory :: IO FilePath getHomeDirectory = if isWindows then getEnv "USERPROFILE" else getEnv "HOME" --- Returns the temporary directory of the operating system. getTemporaryDirectory :: IO FilePath getTemporaryDirectory = if isWindows then getEnv "TMP" else return "/tmp" --- Convert a path name into an absolute one. --- For instance, a leading `~` is replaced by the current home directory. getAbsolutePath :: FilePath -> IO FilePath getAbsolutePath path | isAbsolute path = return (normalise path) | path == "~" = getHomeDirectory | "~/" `isPrefixOf` path = do homedir <- getHomeDirectory return (normalise (homedir drop 2 path)) | otherwise = do curdir <- getCurrentDirectory return (normalise (curdir path)) --- Deletes a file from the file system. removeFile :: FilePath -> IO () removeFile file = prim_removeFile $## file prim_removeFile :: FilePath -> IO () prim_removeFile external --- Renames a file. renameFile :: FilePath -> FilePath -> IO () renameFile file1 file2 = (prim_renameFile $## file1) $## file2 prim_renameFile :: FilePath -> FilePath -> IO () prim_renameFile external --- Copy the contents from one file to another file copyFile :: FilePath -> FilePath -> IO () copyFile src dest = readFile src >>= writeFile dest --- Looks up the first file with a possible suffix in a list of directories. --- Returns Nothing if such a file does not exist. findFileWithSuffix :: String -> [String] -> [String] -> IO (Maybe String) findFileWithSuffix file suffixes path = if isAbsolute file then lookupFirstFileWithSuffix file suffixes else lookupFirstFile path where lookupFirstFile [] = return Nothing lookupFirstFile (dir:dirs) = do mbfile <- lookupFirstFileWithSuffix (dir++pathSeparator:file) suffixes maybe (lookupFirstFile dirs) (return . Just) mbfile lookupFirstFileWithSuffix _ [] = return Nothing lookupFirstFileWithSuffix f (suf:sufs) = do let fsuf = f++suf exfile <- doesFileExist fsuf if exfile then return (Just fsuf) else lookupFirstFileWithSuffix f sufs --- Gets the first file with a possible suffix in a list of directories. --- An error message is delivered if there is no such file. getFileWithSuffix :: String -> [String] -> [String] -> IO String getFileWithSuffix file suffixes path = do mbfile <- findFileWithSuffix file suffixes path maybe (error $ "File "++file++" not found in path "++ concat (intersperse [searchPathSeparator] path)) return mbfile curry-tools-v3.3.0/cpm/vendor/directory/src/System/Directory.kics2000066400000000000000000000056421377556325500252720ustar00rootroot00000000000000import System.Directory import System.IO import System.Time external_d_C_prim_doesFileExist :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_doesFileExist s _ _ = toCurry doesFileExist s external_d_C_prim_doesDirectoryExist :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_doesDirectoryExist s _ _ = toCurry doesDirectoryExist s external_d_C_prim_fileSize :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_prim_fileSize s _ _ = toCurry (\f -> do h <- openFile f ReadMode i <- hFileSize h hClose h return i ) s external_d_C_prim_getModificationTime :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Time.C_ClockTime external_d_C_prim_getModificationTime s _ _ = toCurry getModificationTime s external_d_C_getCurrentDirectory :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_String) external_d_C_getCurrentDirectory _ _ = toCurry getCurrentDirectory external_d_C_prim_setCurrentDirectory :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_setCurrentDirectory s _ _ = toCurry setCurrentDirectory s external_d_C_prim_getDirectoryContents :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_List (Curry_Prelude.C_String)) external_d_C_prim_getDirectoryContents s _ _ = toCurry getDirectoryContents s external_d_C_prim_createDirectory :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_createDirectory s _ _ = toCurry createDirectory s external_d_C_prim_removeFile :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_removeFile s _ _ = toCurry removeFile s external_d_C_prim_removeDirectory :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_removeDirectory s _ _ = toCurry removeDirectory s external_d_C_prim_renameFile :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_renameFile s1 s2 _ _ = toCurry renameFile s1 s2 external_d_C_prim_renameDirectory :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_renameDirectory s1 s2 _ _= toCurry renameDirectory s1 s2 curry-tools-v3.3.0/cpm/vendor/directory/src/System/Directory.pakcs.pl000066400000000000000000000035011377556325500257620ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module Directory: % 'System.Directory.prim_doesFileExist'(FileName,Exists) :- string2Atom(FileName,FName), (existsFile(FName) -> Exists='Prelude.True' ; Exists='Prelude.False'). 'System.Directory.prim_doesDirectoryExist'(DirName,Exists) :- string2Atom(DirName,Dir), (existsDirectory(Dir) -> Exists='Prelude.True' ; Exists='Prelude.False'). 'System.Directory.prim_getModificationTime'(FileName,'Data.Time.CTime'(Time)) :- string2Atom(FileName,FName), fileModTime(FName,Time). 'System.Directory.prim_fileSize'(FileName,Size) :- string2Atom(FileName,FName), fileSize(FName,Size). 'System.Directory.getCurrentDirectory'(DirName) :- workingDirectory(Dir), atom2String(Dir,DirName). 'System.Directory.prim_setCurrentDirectory'(DirName,'Prelude.()') :- string2Atom(DirName,Dir), setWorkingDirectory(Dir). 'System.Directory.prim_getDirectoryContents'(DirName,EntryNames) :- string2Atom(DirName,Dir), directoryFiles(Dir,Entries), map2M(basics:atom2String,Entries,EntryNames). 'System.Directory.prim_createDirectory'(DirName,'Prelude.()') :- string2Atom(DirName,DName), makeDirectory(DName). 'System.Directory.prim_removeFile'(FileName,'Prelude.()') :- string2Atom(FileName,FName), deleteFile(FName). 'System.Directory.prim_removeDirectory'(DirName,'Prelude.()') :- string2Atom(DirName,DName), deleteDirectory(DName). 'System.Directory.prim_renameFile'(FileName1,FileName2,'Prelude.()') :- string2Atom(FileName1,FName1), string2Atom(FileName2,FName2), renameFile(FName1,FName2). 'System.Directory.prim_renameDirectory'(DirName1,DirName2,'Prelude.()') :- string2Atom(DirName1,DName1), string2Atom(DirName2,DName2), renameDirectory(DName1,DName2). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% curry-tools-v3.3.0/cpm/vendor/directory/test/000077500000000000000000000000001377556325500212665ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/directory/test/TestDirectory.curry000066400000000000000000000041721377556325500251640ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some tests for library System.Directory --- --- To run all tests automatically by the currycheck tool, use the command: --- "curry-check TestDirectory" --- --- @author Michael Hanus --- @version November 2020 ------------------------------------------------------------------------------ import System.Directory import Data.List --import System import Test.Prop testCreateRenameDeleteFile = fileOps `returns` (True,False,True,False) where fileOps = do let fname = "xxx1234" fnamebak = fname++".bak" writeFile fname "test\n" ex1 <- doesFileExist fname renameFile fname fnamebak ex2 <- doesFileExist fname ex3 <- doesFileExist fnamebak removeFile fnamebak ex4 <- doesFileExist fnamebak return (ex1,ex2,ex3,ex4) testCreateRenameDeleteDirectory = dirOps `returns` (True,False,True,False) where dirOps = do let dname = "xxx1111" dnamebak = dname++".bak" createDirectory dname ex1 <- doesDirectoryExist dname renameDirectory dname dnamebak ex2 <- doesDirectoryExist dname ex3 <- doesDirectoryExist dnamebak removeDirectory dnamebak ex4 <- doesDirectoryExist dnamebak return (ex1,ex2,ex3,ex4) testGetSetDirectory = dirOps `returns` (True,True,"abcdef",False) where dirOps = do cdir <- getCurrentDirectory let dname = cdir++"/xxx2222" createDirectory dname ex1 <- doesDirectoryExist dname writeFile (dname++"/xxx") "abcdef" setCurrentDirectory dname ex2 <- doesFileExist "xxx" cnt <- readFile "xxx" cnt==cnt `seq` removeFile "xxx" setCurrentDirectory cdir removeDirectory dname ex3 <- doesDirectoryExist dname return (ex1,ex2,cnt,ex3) testGetDirectoryContents = dirOps `returns` [".","..","xxx"] where dirOps = do cdir <- getCurrentDirectory let dname = cdir++"/xxx3333" createDirectory dname setCurrentDirectory dname d <- getCurrentDirectory writeFile "xxx" "Hello\n" fs <- getDirectoryContents d fs==fs `seq` removeFile "xxx" setCurrentDirectory cdir removeDirectory dname return (sort fs) curry-tools-v3.3.0/cpm/vendor/distribution/000077500000000000000000000000001377556325500210225ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/distribution/LICENSE000066400000000000000000000027351377556325500220360ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/distribution/package.json000066400000000000000000000014411377556325500233100ustar00rootroot00000000000000{ "name": "distribution", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "This module contains definition of constants to obtain information concerning the current distribution of the Curry implementation.", "category": [ "Meta" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "directory" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Language.Curry.Distribution" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/distribution.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/distribution/src/000077500000000000000000000000001377556325500216115ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/distribution/src/Language/000077500000000000000000000000001377556325500233345ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/distribution/src/Language/Curry/000077500000000000000000000000001377556325500244405ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/distribution/src/Language/Curry/Distribution.curry000066400000000000000000000045271377556325500302150ustar00rootroot00000000000000-------------------------------------------------------------------------------- --- This module contains definition of constants to obtain information --- concerning the current distribution of the Curry implementation, e.g., --- compiler version, run-time version, installation directory. --- --- @author Michael Hanus --- @version December 2018 -------------------------------------------------------------------------------- module Language.Curry.Distribution ( curryCompiler, curryCompilerMajorVersion, curryCompilerMinorVersion , curryCompilerRevisionVersion , curryRuntime, curryRuntimeMajorVersion, curryRuntimeMinorVersion , baseVersion, installDir, rcFileName ) where import System.Directory ( getHomeDirectory ) import System.FilePath ( FilePath, () ) ----------------------------------------------------------------- -- Compiler and run-time environment name and version ----------------------------------------------------------------- --- The name of the Curry compiler (e.g., "pakcs" or "kics2"). curryCompiler :: String curryCompiler external --- The major version number of the Curry compiler. curryCompilerMajorVersion :: Int curryCompilerMajorVersion external --- The minor version number of the Curry compiler. curryCompilerMinorVersion :: Int curryCompilerMinorVersion external --- The revision version number of the Curry compiler. curryCompilerRevisionVersion :: Int curryCompilerRevisionVersion external --- The name of the run-time environment (e.g., "sicstus", "swi", or "ghc") curryRuntime :: String curryRuntime external --- The major version number of the Curry run-time environment. curryRuntimeMajorVersion :: Int curryRuntimeMajorVersion external --- The minor version number of the Curry run-time environment. curryRuntimeMinorVersion :: Int curryRuntimeMinorVersion external --- The version number of the base libraries (e.g., "1.0.5"). baseVersion :: String baseVersion external --- Path of the main installation directory of the Curry compiler. installDir :: FilePath installDir external --- The name of the file specifying configuration parameters of the --- current distribution. --- This file must have the usual format of property files. rcFileName :: IO String rcFileName = getHomeDirectory >>= return . ( rcFile) where rcFile = '.' : curryCompiler ++ "rc" ----------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/distribution/src/Language/Curry/Distribution.kics2000066400000000000000000000024621377556325500300600ustar00rootroot00000000000000import qualified Installation as I external_d_C_curryCompiler :: Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_curryCompiler _ _ = toCurry I.compilerName external_d_C_curryCompilerMajorVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryCompilerMajorVersion _ _ = toCurry I.majorVersion external_d_C_curryCompilerMinorVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryCompilerMinorVersion _ _ = toCurry I.minorVersion external_d_C_curryCompilerRevisionVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryCompilerRevisionVersion _ _ = toCurry I.revisionVersion external_d_C_curryRuntime :: Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_curryRuntime _ _ = toCurry I.runtime external_d_C_curryRuntimeMajorVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryRuntimeMajorVersion _ _ = toCurry I.runtimeMajor external_d_C_curryRuntimeMinorVersion :: Cover -> ConstStore -> Curry_Prelude.C_Int external_d_C_curryRuntimeMinorVersion _ _ = toCurry I.runtimeMinor external_d_C_baseVersion :: Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_baseVersion _ _ = toCurry I.baseVersion external_d_C_installDir :: Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_installDir _ _ = toCurry I.installDir curry-tools-v3.3.0/cpm/vendor/distribution/src/Language/Curry/Distribution.pakcs.pl000066400000000000000000000020761377556325500305610ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module Distribution % 'Language.Curry.Distribution.curryCompiler'(CS) :- atom2String(pakcs,CS). 'Language.Curry.Distribution.curryCompilerMajorVersion'(V) :- compilerMajorVersion(V). 'Language.Curry.Distribution.curryCompilerMinorVersion'(V) :- compilerMinorVersion(V). 'Language.Curry.Distribution.curryCompilerRevisionVersion'(V) :- compilerRevisionVersion(V). 'Language.Curry.Distribution.curryRuntime'(PrologS) :- prolog(Prolog), atom2String(Prolog,PrologS). 'Language.Curry.Distribution.curryRuntimeMajorVersion'(V) :- prologMajorVersion(V). 'Language.Curry.Distribution.curryRuntimeMinorVersion'(V) :- prologMinorVersion(V). 'Language.Curry.Distribution.baseVersion'(BVS) :- baseVersion(BVA), atom2String(BVA,BVS). 'Language.Curry.Distribution.installDir'(PHS) :- installDir(PH) -> atom2String(PH,PHS) ; raise_exception('Language.Curry.Distribution.installDir: cannot determine installation directory!'). curry-tools-v3.3.0/cpm/vendor/execpath/000077500000000000000000000000001377556325500201045ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/execpath/LICENSE000066400000000000000000000027351377556325500211200ustar00rootroot00000000000000Copyright (c) 2018, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/execpath/README.md000066400000000000000000000002471377556325500213660ustar00rootroot00000000000000execpath ======== This package provides the library `System.Path` which contains operations related to the program execution path, i.e., environment variable `PATH`. curry-tools-v3.3.0/cpm/vendor/execpath/package.json000066400000000000000000000013031377556325500223670ustar00rootroot00000000000000{ "name": "execpath", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Operations related to the program execution path", "category": [ "System" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "directory": ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.Path" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/execpath.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/execpath/src/000077500000000000000000000000001377556325500206735ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/execpath/src/System/000077500000000000000000000000001377556325500221575ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/execpath/src/System/Path.curry000066400000000000000000000030331377556325500241400ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to support operations related to the program execution path, --- i.e., environment variable `PATH`. --- --- @author Michael Hanus --- @version November 2018 ------------------------------------------------------------------------------ module System.Path ( dirsInPath, fileInPath, getFileInPath ) where import System.Directory ( doesFileExist, getAbsolutePath ) import System.FilePath ( (), searchPathSeparator ) import System.Environment ( getEnv ) import Data.List ( split ) --- Returns the list of the directories of the environment variable `PATH`. dirsInPath :: IO [String] dirsInPath = do path <- getEnv "PATH" return $ split (== searchPathSeparator) path --- Checks whether a file exists in one of the directories --- of the environment variable `PATH`. fileInPath :: String -> IO Bool fileInPath file = do dirs <- dirsInPath or <$> mapM (doesFileExist . ( file)) dirs --- Checks whether a file exists in one of the directories --- of the environment variable `PATH` and returns its absolute path, --- otherwise returns `Nothing`. getFileInPath :: String -> IO (Maybe String) getFileInPath file = dirsInPath >>= checkPath where checkPath [] = return Nothing checkPath (dir:dirs) = do let dirfile = dir file direx <- doesFileExist dirfile if direx then getAbsolutePath dirfile >>= return . Just else checkPath dirs ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/filepath/000077500000000000000000000000001377556325500200775ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/filepath/LICENSE000066400000000000000000000027351377556325500211130ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/filepath/package.json000066400000000000000000000013521377556325500223660ustar00rootroot00000000000000{ "name": "filepath", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "A library for FilePath manipulations, using Posix or Windows filepaths depending on the platform.", "category": [ "System" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.FilePath" ], "testsuite": { "src-dir": "test", "modules": [ "TestFilePath" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/filepath.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/filepath/src/000077500000000000000000000000001377556325500206665ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/filepath/src/System/000077500000000000000000000000001377556325500221525ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/filepath/src/System/FilePath.curry000066400000000000000000000733751377556325500247530ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library is a direct port of the Haskell library System.FilePath --- of Neil Mitchell. --- --- @author Bjoern Peemoeller --- @version November 2011 --- @category general ------------------------------------------------------------------------------ -- -- Some short examples: -- -- You are given a C file, you want to figure out the corresponding object (.o) file: -- -- @'replaceExtension' file \"o\"@ -- -- Haskell module Main imports Test, you have the file named main: -- -- @['replaceFileName' path_to_main \"Test\" '<.>' ext | ext <- [\"hs\",\"lhs\"] ]@ -- -- You want to download a file from the web and save it to disk: -- -- @do let file = 'makeValid' url -- System.IO.createDirectoryIfMissing True ('takeDirectory' file)@ -- -- You want to compile a Haskell file, but put the hi file under \"interface\" -- -- @'takeDirectory' file '' \"interface\" '' ('takeFileName' file \`replaceExtension\` \"hi\"@) -- -- The examples in code format descibed by each function are used to generate -- tests, and should give clear semantics for the functions. ----------------------------------------------------------------------------- module System.FilePath ( -- * Separator predicates FilePath, pathSeparator, pathSeparators, isPathSeparator, searchPathSeparator, isSearchPathSeparator, extSeparator, isExtSeparator, -- * Path methods (environment $PATH) splitSearchPath, getSearchPath, -- * Extension methods splitExtension, takeExtension, replaceExtension, dropExtension, addExtension, hasExtension, (<.>), splitExtensions, dropExtensions, takeExtensions, isExtensionOf, -- * Drive methods splitDrive, joinDrive, takeDrive, hasDrive, dropDrive, isDrive, -- * Operations on a FilePath, as a list of directories splitFileName, takeFileName, replaceFileName, dropFileName, takeBaseName, replaceBaseName, takeDirectory, replaceDirectory, combine, (), splitPath, joinPath, splitDirectories, -- * Low level FilePath operators hasTrailingPathSeparator, addTrailingPathSeparator, dropTrailingPathSeparator, -- * File name manipulators normalise, equalFilePath, makeRelative, isRelative, isAbsolute, isValid, makeValid ) where import Data.Char (toLower, toUpper) import Data.List (isSuffixOf, isPrefixOf, init, last, intersperse) import Data.Maybe (isJust, fromJust) import System.Environment (getEnv, isPosix, isWindows) infixr 7 <.> infixr 5 --------------------------------------------------------------------- -- The basic functions -- | The character that separates directories. In the case where more than -- one character is possible, 'pathSeparator' is the \'ideal\' one. -- -- > Windows: pathSeparator == '\\' -- > Posix: pathSeparator == '/' -- > isPathSeparator pathSeparator pathSeparator :: Char pathSeparator = if isWindows then '\\' else '/' -- | The list of all possible separators. -- -- > Windows: pathSeparators == ['\\', '/'] -- > Posix: pathSeparators == ['/'] -- > pathSeparator `elem` pathSeparators pathSeparators :: [Char] pathSeparators = if isWindows then "\\/" else "/" -- | Rather than using @(== 'pathSeparator')@, use this. Test if something -- is a path separator. -- -- > isPathSeparator a == (a `elem` pathSeparators) isPathSeparator :: Char -> Bool isPathSeparator = (`elem` pathSeparators) -- | The character that is used to separate the entries in the $PATH -- environment variable. -- -- > Windows: searchPathSeparator == ';' -- > Posix: searchPathSeparator == ':' searchPathSeparator :: Char searchPathSeparator = if isWindows then ';' else ':' -- | Is the character a file separator? -- -- > isSearchPathSeparator a == (a == searchPathSeparator) isSearchPathSeparator :: Char -> Bool isSearchPathSeparator = (== searchPathSeparator) -- | File extension character -- -- > extSeparator == '.' extSeparator :: Char extSeparator = '.' -- | Is the character an extension character? -- -- > isExtSeparator a == (a == extSeparator) isExtSeparator :: Char -> Bool isExtSeparator = (== extSeparator) --------------------------------------------------------------------- -- Path methods (environment $PATH) -- | Take a string, split it on the 'searchPathSeparator' character. -- -- Follows the recommendations in -- -- -- > Posix: splitSearchPath "File1:File2:File3" == ["File1","File2","File3"] -- > Posix: splitSearchPath "File1::File2:File3" == ["File1",".","File2","File3"] -- > Windows: splitSearchPath "File1;File2;File3" == ["File1","File2","File3"] -- > Windows: splitSearchPath "File1;;File2;File3" == ["File1","File2","File3"] splitSearchPath :: String -> [FilePath] splitSearchPath = f where f xs = case break isSearchPathSeparator xs of (pre, [] ) -> g pre (pre, _:post) -> g pre ++ f post g [] = ["." | isPosix] g x@(_:_) = [x] -- | Get a list of filepaths in the $PATH. getSearchPath :: IO [FilePath] getSearchPath = getEnv "PATH" >>= return . splitSearchPath --------------------------------------------------------------------- -- Extension methods -- | Split on the extension. 'addExtension' is the inverse. -- -- > uncurry (++) (splitExtension x) == x -- > uncurry addExtension (splitExtension x) == x -- > splitExtension "file.txt" == ("file",".txt") -- > splitExtension "file" == ("file","") -- > splitExtension "file/file.txt" == ("file/file",".txt") -- > splitExtension "file.txt/boris" == ("file.txt/boris","") -- > splitExtension "file.txt/boris.ext" == ("file.txt/boris",".ext") -- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") -- > splitExtension "file/path.txt/" == ("file/path.txt/","") splitExtension :: FilePath -> (String, String) splitExtension x = case d of [] -> (x,"") (y:ys) -> (a ++ reverse ys, y : reverse c) where (a,b) = splitFileName_ x (c,d) = break isExtSeparator $ reverse b -- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. -- -- > takeExtension x == snd (splitExtension x) -- > Valid x => takeExtension (addExtension x "ext") == ".ext" -- > Valid x => takeExtension (replaceExtension x "ext") == ".ext" takeExtension :: FilePath -> String takeExtension = snd . splitExtension -- | Set the extension of a file, overwriting one if already present. -- -- > replaceExtension "file.txt" ".bob" == "file.bob" -- > replaceExtension "file.txt" "bob" == "file.bob" -- > replaceExtension "file" ".bob" == "file.bob" -- > replaceExtension "file.txt" "" == "file" -- > replaceExtension "file.fred.bob" "txt" == "file.fred.txt" replaceExtension :: FilePath -> String -> FilePath replaceExtension x y = dropExtension x <.> y -- | Alias to 'addExtension', for people who like that sort of thing. (<.>) :: FilePath -> String -> FilePath (<.>) = addExtension -- | Remove last extension, and the \".\" preceding it. -- -- > dropExtension x == fst (splitExtension x) dropExtension :: FilePath -> FilePath dropExtension = fst . splitExtension -- | Add an extension, even if there is already one there. -- E.g. @addExtension \"foo.txt\" \"bat\" -> \"foo.txt.bat\"@. -- -- > addExtension "file.txt" "bib" == "file.txt.bib" -- > addExtension "file." ".bib" == "file..bib" -- > addExtension "file" ".bib" == "file.bib" -- > addExtension "/" "x" == "/.x" -- > Valid x => takeFileName (addExtension (addTrailingPathSeparator x) "ext") == ".ext" -- > Windows: addExtension "\\\\share" ".txt" == "\\\\share\\.txt" addExtension :: FilePath -> String -> FilePath addExtension file [] = file addExtension file xs@(x:_) = joinDrive a res where res = if isExtSeparator x then b ++ xs else b ++ [extSeparator] ++ xs (a,b) = splitDrive file -- | Does the given filename have an extension? -- -- > null (takeExtension x) == not (hasExtension x) hasExtension :: FilePath -> Bool hasExtension = any isExtSeparator . takeFileName -- | Split on all extensions -- -- > uncurry (++) (splitExtensions x) == x -- > uncurry addExtension (splitExtensions x) == x -- > splitExtensions "file.tar.gz" == ("file",".tar.gz") splitExtensions :: FilePath -> (FilePath, String) splitExtensions x = (a ++ c, d) where (a,b) = splitFileName_ x (c,d) = break isExtSeparator b -- | Drop all extensions -- -- > not $ hasExtension (dropExtensions x) dropExtensions :: FilePath -> FilePath dropExtensions = fst . splitExtensions -- | Get all extensions -- -- > takeExtensions "file.tar.gz" == ".tar.gz" takeExtensions :: FilePath -> String takeExtensions = snd . splitExtensions -- | Does the given filename have the specified extension? -- -- > "png" `isExtensionOf` "/directory/file.png" == True -- > ".png" `isExtensionOf` "/directory/file.png" == True -- > ".tar.gz" `isExtensionOf` "bar/foo.tar.gz" == True -- > "ar.gz" `isExtensionOf` "bar/foo.tar.gz" == False -- > "png" `isExtensionOf` "/directory/file.png.jpg" == False -- > "csv/table.csv" `isExtensionOf` "/data/csv/table.csv" == False isExtensionOf :: String -> FilePath -> Bool isExtensionOf extension path = case extension of ext@('.':_) -> isSuffixOf ext $ takeExtensions path ext -> isSuffixOf ('.':ext) $ takeExtensions path --------------------------------------------------------------------- -- Drive methods -- | Is the given character a valid drive letter? -- only a-z and A-Z are letters, not isAlpha which is more unicodey isLetter :: Char -> Bool isLetter x = (x >= 'a' && x <= 'z') || (x >= 'A' && x <= 'Z') -- | Split a path into a drive and a path. -- On Unix, \/ is a Drive. -- -- > uncurry (++) (splitDrive x) == x -- > Windows: splitDrive "file" == ("","file") -- > Windows: splitDrive "c:/file" == ("c:/","file") -- > Windows: splitDrive "c:\\file" == ("c:\\","file") -- > Windows: splitDrive "\\\\shared\\test" == ("\\\\shared\\","test") -- > Windows: splitDrive "\\\\shared" == ("\\\\shared","") -- > Windows: splitDrive "\\\\?\\UNC\\shared\\file" == ("\\\\?\\UNC\\shared\\","file") -- > Windows: splitDrive "\\\\?\\UNCshared\\file" == ("\\\\?\\","UNCshared\\file") -- > Windows: splitDrive "\\\\?\\d:\\file" == ("\\\\?\\d:\\","file") -- > Windows: splitDrive "/d" == ("","/d") -- > Posix: splitDrive "/test" == ("/","test") -- > Posix: splitDrive "//test" == ("//","test") -- > Posix: splitDrive "test/file" == ("","test/file") -- > Posix: splitDrive "file" == ("","file") splitDrive :: FilePath -> (FilePath, FilePath) splitDrive x | isPosix = span (== '/') x | isJust dl = fromJust dl | isJust unc = fromJust unc | isJust shr = fromJust shr | otherwise = ("",x) where dl = readDriveLetter x unc = readDriveUNC x shr = readDriveShare x addSlash :: FilePath -> FilePath -> (FilePath, FilePath) addSlash a xs = (a++c,d) where (c,d) = span isPathSeparator xs -- http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp -- "\\?\D:\" or "\\?\UNC\\" -- a is "\\?\" readDriveUNC :: FilePath -> Maybe (FilePath, FilePath) readDriveUNC path = case path of (s1:s2:'?':s3:xs) -> if all isPathSeparator [s1,s2,s3] then let rdl = case readDriveLetter xs of Just (a,b) -> Just (s1:s2:'?':s3:a,b) Nothing -> Nothing in case map toUpper xs of ('U':'N':'C':s4:_) -> if isPathSeparator s4 then let (a,b) = readDriveShareName (drop 4 xs) in Just (s1:s2:'?':s3:take 4 xs ++ a, b) else rdl _ -> rdl else Nothing _ -> Nothing {- c:\ -} readDriveLetter :: String -> Maybe (FilePath, FilePath) readDriveLetter path = case path of (x:':':y:xs) -> if isLetter x && isPathSeparator y then Just $ addSlash [x,':'] (y:xs) else if isLetter x then Just ([x,':'], (y:xs)) else Nothing (x:':':xs) -> if isLetter x then Just ([x,':'], xs) else Nothing _ -> Nothing {- \\sharename\ -} readDriveShare :: String -> Maybe (FilePath, FilePath) readDriveShare path = case path of (s1:s2:xs) -> if isPathSeparator s1 && isPathSeparator s2 then let (a,b) = readDriveShareName xs in Just (s1:s2:a,b) else Nothing _ -> Nothing {- assume you have already seen \\ -} {- share\bob -> "share","\","bob" -} readDriveShareName :: String -> (FilePath, FilePath) readDriveShareName name = addSlash a b where (a,b) = break isPathSeparator name -- | Join a drive and the rest of the path. -- -- > uncurry joinDrive (splitDrive x) == x -- > Windows: joinDrive "C:" "foo" == "C:foo" -- > Windows: joinDrive "C:\\" "bar" == "C:\\bar" -- > Windows: joinDrive "\\\\share" "foo" == "\\\\share\\foo" -- > Windows: joinDrive "/:" "foo" == "/:\\foo" joinDrive :: FilePath -> FilePath -> FilePath joinDrive a b | isPosix = a ++ b | null a = b | null b = a | isPathSeparator (last a) = a ++ b | otherwise = case a of [a1,':'] -> if isLetter a1 then a ++ b else a ++ [pathSeparator] ++ b _ -> a ++ [pathSeparator] ++ b -- | Get the drive from a filepath. -- -- > takeDrive x == fst (splitDrive x) takeDrive :: FilePath -> FilePath takeDrive = fst . splitDrive -- | Delete the drive, if it exists. -- -- > dropDrive x == snd (splitDrive x) dropDrive :: FilePath -> FilePath dropDrive = snd . splitDrive -- | Does a path have a drive. -- -- > not (hasDrive x) == null (takeDrive x) hasDrive :: FilePath -> Bool hasDrive = not . null . takeDrive -- | Is an element a drive isDrive :: FilePath -> Bool isDrive = null . dropDrive --------------------------------------------------------------------- -- Operations on a filepath, as a list of directories -- | Split a filename into directory and file. 'combine' is the inverse. -- -- > Valid x => uncurry () (splitFileName x) == x || fst (splitFileName x) == "./" -- > Valid x => isValid (fst (splitFileName x)) -- > splitFileName "file/bob.txt" == ("file/", "bob.txt") -- > splitFileName "file/" == ("file/", "") -- > splitFileName "bob" == ("./", "bob") -- > Posix: splitFileName "/" == ("/","") -- > Windows: splitFileName "c:" == ("c:","") splitFileName :: FilePath -> (String, String) splitFileName x = (if null dir then "./" else dir, name) where (dir, name) = splitFileName_ x -- version of splitFileName where, if the FilePath has no directory -- component, the returned directory is "" rather than "./". This -- is used in cases where we are going to combine the returned -- directory to make a valid FilePath, and having a "./" appear would -- look strange and upset simple equality properties. See -- e.g. replaceFileName. splitFileName_ :: FilePath -> (String, String) splitFileName_ x = (c ++ reverse b, reverse a) where (a,b) = break isPathSeparator $ reverse d (c,d) = splitDrive x -- | Set the filename. -- -- > Valid x => replaceFileName x (takeFileName x) == x replaceFileName :: FilePath -> String -> FilePath replaceFileName x y = a y where (a,_) = splitFileName_ x -- | Drop the filename. -- -- > dropFileName x == fst (splitFileName x) dropFileName :: FilePath -> FilePath dropFileName = fst . splitFileName -- | Get the file name. -- -- > takeFileName "test/" == "" -- > takeFileName x `isSuffixOf` x -- > takeFileName x == snd (splitFileName x) -- > Valid x => takeFileName (replaceFileName x "fred") == "fred" -- > Valid x => takeFileName (x "fred") == "fred" -- > Valid x => isRelative (takeFileName x) takeFileName :: FilePath -> FilePath takeFileName = snd . splitFileName -- | Get the base name, without an extension or path. -- -- > takeBaseName "file/test.txt" == "test" -- > takeBaseName "dave.ext" == "dave" -- > takeBaseName "" == "" -- > takeBaseName "test" == "test" -- > takeBaseName (addTrailingPathSeparator x) == "" -- > takeBaseName "file/file.tar.gz" == "file.tar" takeBaseName :: FilePath -> String takeBaseName = dropExtension . takeFileName -- | Set the base name. -- -- > replaceBaseName "file/test.txt" "bob" == "file/bob.txt" -- > replaceBaseName "fred" "bill" == "bill" -- > replaceBaseName "/dave/fred/bob.gz.tar" "new" == "/dave/fred/new.tar" -- > Valid x => replaceBaseName x (takeBaseName x) == x replaceBaseName :: FilePath -> String -> FilePath replaceBaseName pth nam = combineAlways a (nam <.> ext) where (a,b) = splitFileName_ pth ext = takeExtension b -- | Is an item either a directory or the last character a path separator? -- -- > hasTrailingPathSeparator "test" == False -- > hasTrailingPathSeparator "test/" == True hasTrailingPathSeparator :: FilePath -> Bool hasTrailingPathSeparator [] = False hasTrailingPathSeparator x@(_:_) = isPathSeparator (last x) -- | Add a trailing file path separator if one is not already present. -- -- > hasTrailingPathSeparator (addTrailingPathSeparator x) -- > hasTrailingPathSeparator x ==> addTrailingPathSeparator x == x -- > Posix: addTrailingPathSeparator "test/rest" == "test/rest/" addTrailingPathSeparator :: FilePath -> FilePath addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pathSeparator] -- | Remove any trailing path separators -- -- > dropTrailingPathSeparator "file/test/" == "file/test" -- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x -- > Posix: dropTrailingPathSeparator "/" == "/" -- > Windows: dropTrailingPathSeparator "\\" == "\\" dropTrailingPathSeparator :: FilePath -> FilePath dropTrailingPathSeparator x = if hasTrailingPathSeparator x && not (isDrive x) then let x' = reverse $ dropWhile isPathSeparator $ reverse x in if null x' then [pathSeparator] else x' else x -- | Get the directory name, move up one level. -- -- > takeDirectory x `isPrefixOf` x || takeDirectory x == "." -- > takeDirectory "foo" == "." -- > takeDirectory "/foo/bar/baz" == "/foo/bar" -- > takeDirectory "/foo/bar/baz/" == "/foo/bar/baz" -- > takeDirectory "foo/bar/baz" == "foo/bar" -- > Windows: takeDirectory "foo\\bar" == "foo" -- > Windows: takeDirectory "foo\\bar\\\\" == "foo\\bar" -- > Windows: takeDirectory "C:\\" == "C:\\" takeDirectory :: FilePath -> FilePath takeDirectory x = if isDrive file then file else if null res && not (null file) then file else res where res = reverse $ dropWhile isPathSeparator $ reverse file file = dropFileName x _ = isPrefixOf x -- warning suppression -- | Set the directory, keeping the filename the same. -- -- > Valid x => replaceDirectory x (takeDirectory x) `equalFilePath` x replaceDirectory :: FilePath -> String -> FilePath replaceDirectory x dir = combineAlways dir (takeFileName x) -- | Combine two paths, if the second path 'isAbsolute', then it returns the second. -- -- > Valid x => combine (takeDirectory x) (takeFileName x) `equalFilePath` x -- > Posix: combine "/" "test" == "/test" -- > Posix: combine "home" "bob" == "home/bob" -- > Windows: combine "home" "bob" == "home\\bob" -- > Windows: combine "home" "/bob" == "/bob" combine :: FilePath -> FilePath -> FilePath combine a b | hasDrive b || (not (null b) && isPathSeparator (head b)) = b | otherwise = combineAlways a b -- | Combine two paths, assuming rhs is NOT absolute. combineAlways :: FilePath -> FilePath -> FilePath combineAlways a b | null a = b | null b = a | isPathSeparator (last a) = a ++ b | isDrive a = joinDrive a b | otherwise = a ++ [pathSeparator] ++ b -- | A nice alias for 'combine'. () :: FilePath -> FilePath -> FilePath () = combine -- | Split a path by the directory separator. -- -- > concat (splitPath x) == x -- > splitPath "test//item/" == ["test//","item/"] -- > splitPath "test/item/file" == ["test/","item/","file"] -- > splitPath "" == [] -- > Windows: splitPath "c:\\test\\path" == ["c:\\","test\\","path"] -- > Posix: splitPath "/file/test" == ["/","file/","test"] splitPath :: FilePath -> [FilePath] splitPath x = [drive | drive /= ""] ++ f path where (drive,path) = splitDrive x f [] = [] f y@(_:_) = (a ++ c) : f d where (a,b) = break isPathSeparator y (c,d) = break (not . isPathSeparator) b -- | Just as 'splitPath', but don't add the trailing slashes to each element. -- -- > splitDirectories "test/file" == ["test","file"] -- > splitDirectories "/test/file" == ["/","test","file"] -- > Valid x => joinPath (splitDirectories x) `equalFilePath` x -- > splitDirectories "" == [] splitDirectories :: FilePath -> [FilePath] splitDirectories path = if hasDrive path then head pathComponents : f (tail pathComponents) else f pathComponents where pathComponents = splitPath path f xs = map g xs g x = if null res then x else res where res = takeWhile (not . isPathSeparator) x -- | Join path elements back together. -- -- > Valid x => joinPath (splitPath x) == x -- > joinPath [] == "" -- > Posix: joinPath ["test","file","path"] == "test/file/path" -- Note that this definition on c:\\c:\\, join then split will give c:\\. joinPath :: [FilePath] -> FilePath joinPath x = foldr combine "" x --------------------------------------------------------------------- -- File name manipulators -- | Equality of two 'FilePath's. -- If you call @System.Directory.canonicalizePath@ -- first this has a much better chance of working. -- Note that this doesn't follow symlinks or DOSNAM~1s. -- -- > x == y ==> equalFilePath x y -- > normalise x == normalise y ==> equalFilePath x y -- > Posix: equalFilePath "foo" "foo/" -- > Posix: not (equalFilePath "foo" "/foo") -- > Posix: not (equalFilePath "foo" "FOO") -- > Windows: equalFilePath "foo" "FOO" equalFilePath :: FilePath -> FilePath -> Bool equalFilePath a b = f a == f b where f x | isWindows = dropTrailSlash $ map toLower $ normalise x | otherwise = dropTrailSlash $ normalise x dropTrailSlash x | length x >= 2 && isPathSeparator (last x) = init x | otherwise = x -- | Contract a filename, based on a relative path. -- -- There is no corresponding @makeAbsolute@ function, instead use -- @System.Directory.canonicalizePath@ which has the same effect. -- -- > Valid y => equalFilePath x y || (isRelative x && makeRelative y x == x) || equalFilePath (y makeRelative y x) x -- > makeRelative x x == "." -- > null y || equalFilePath (makeRelative x (x y)) y || null (takeFileName x) -- > Windows: makeRelative "C:\\Home" "c:\\home\\bob" == "bob" -- > Windows: makeRelative "C:\\Home" "c:/home/bob" == "bob" -- > Windows: makeRelative "C:\\Home" "D:\\Home\\Bob" == "D:\\Home\\Bob" -- > Windows: makeRelative "C:\\Home" "C:Home\\Bob" == "C:Home\\Bob" -- > Windows: makeRelative "/Home" "/home/bob" == "bob" -- > Posix: makeRelative "/Home" "/home/bob" == "/home/bob" -- > Posix: makeRelative "/home/" "/home/bob/foo/bar" == "bob/foo/bar" -- > Posix: makeRelative "/fred" "bob" == "bob" -- > Posix: makeRelative "/file/test" "/file/test/fred" == "fred" -- > Posix: makeRelative "/file/test" "/file/test/fred/" == "fred/" -- > Posix: makeRelative "some/path" "some/path/a/b/c" == "a/b/c" makeRelative :: FilePath -> FilePath -> FilePath makeRelative root path | equalFilePath root path = "." | takeAbs root /= takeAbs path = path | otherwise = f (dropAbs root) (dropAbs path) where f [] y = dropWhile isPathSeparator y f x@(_:_) y = let (x1,x2) = g x (y1,y2) = g y in if equalFilePath x1 y1 then f x2 y2 else path g x = (dropWhile isPathSeparator a, dropWhile isPathSeparator b) where (a,b) = break isPathSeparator $ dropWhile isPathSeparator x -- on windows, need to drop '/' which is kind of absolute, but not a drive dropAbs [] = dropDrive [] dropAbs (x:xs) | isPathSeparator x = xs | otherwise = dropDrive (x:xs) takeAbs [] = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive [] takeAbs xs@(x:_) | isPathSeparator x = [pathSeparator] | otherwise = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive xs -- | Normalise a file -- -- * \/\/ outside of the drive can be made blank -- -- * \/ -> 'pathSeparator' -- -- * .\/ -> \"\" -- -- > Posix: normalise "/file/\\test////" == "/file/\\test/" -- > Posix: normalise "/file/./test" == "/file/test" -- > Posix: normalise "/test/file/../bob/fred/" == "/test/file/../bob/fred/" -- > Posix: normalise "../bob/fred/" == "../bob/fred/" -- > Posix: normalise "./bob/fred/" == "bob/fred/" -- > Windows: normalise "c:\\file/bob\\" == "C:\\file\\bob\\" -- > Windows: normalise "c:\\" == "C:\\" -- > Windows: normalise "\\\\server\\test" == "\\\\server\\test" -- > Windows: normalise "c:/file" == "C:\\file" -- > normalise "." == "." -- > Posix: normalise "./" == "./" -- > Posix: normalise "./." == "./" -- > Posix: normalise "bob/fred/." == "bob/fred/" normalise :: FilePath -> FilePath normalise path = joinDrive (normaliseDrive drv) (f pth) ++ [pathSeparator | isDirPath pth] where (drv,pth) = splitDrive path isDirPath xs = lastSep xs || not (null xs) && last xs == '.' && lastSep (init xs) lastSep xs = not (null xs) && isPathSeparator (last xs) f = joinPath . dropDots . splitDirectories . propSep propSep [] = [] propSep xs@[x] | isPathSeparator x = [pathSeparator] | otherwise = xs propSep (x:y:xs) | isPathSeparator x && isPathSeparator y = propSep (x:xs) | isPathSeparator x = pathSeparator : propSep (y:xs) | otherwise = x : propSep (y:xs) dropDots xs | all (== ".") xs = ["."] | otherwise = dropDots' [] xs dropDots' acc [] = reverse acc dropDots' acc (x:xs) | x == "." = dropDots' acc xs | otherwise = dropDots' (x:acc) xs normaliseDrive :: FilePath -> FilePath normaliseDrive drive | isPosix = drive | otherwise = if isJust $ readDriveLetter x2 then map toUpper x2 else drive where x2 = map repSlash drive repSlash x = if isPathSeparator x then pathSeparator else x -- information for validity functions on Windows -- see http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp badCharacters :: [Char] badCharacters = ":*?><|\"" badElements :: [FilePath] badElements = ["CON", "PRN", "AUX", "NUL", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9", "CLOCK$"] -- | Is a FilePath valid, i.e. could you create a file like it? -- -- > isValid "" == False -- > Posix: isValid "/random_ path:*" == True -- > Posix: isValid x == not (null x) -- > Windows: isValid "c:\\test" == True -- > Windows: isValid "c:\\test:of_test" == False -- > Windows: isValid "test*" == False -- > Windows: isValid "c:\\test\\nul" == False -- > Windows: isValid "c:\\test\\prn.txt" == False -- > Windows: isValid "c:\\nul\\file" == False -- > Windows: isValid "\\\\" == False isValid :: FilePath -> Bool isValid [] = False isValid path@(_:_) | isPosix = True | otherwise = not (any (`elem` badCharacters) x2) && not (any f $ splitDirectories x2) && not (length path >= 2 && all isPathSeparator path) where x2 = dropDrive path f x = map toUpper (dropExtensions x) `elem` badElements -- | Take a FilePath and make it valid; does not change already valid FilePaths. -- -- > isValid (makeValid x) -- > isValid x ==> makeValid x == x -- > makeValid "" == "_" -- > Windows: makeValid "c:\\test:of_test" == "c:\\test_of_test" -- > Windows: makeValid "test*" == "test_" -- > Windows: makeValid "c:\\test\\nul" == "c:\\test\\nul_" -- > Windows: makeValid "c:\\test\\prn.txt" == "c:\\test\\prn_.txt" -- > Windows: makeValid "c:\\test/prn.txt" == "c:\\test/prn_.txt" -- > Windows: makeValid "c:\\nul\\file" == "c:\\nul_\\file" makeValid :: FilePath -> FilePath makeValid [] = "_" makeValid path@(_:_) | isPosix = path | length path >= 2 && all isPathSeparator path = take 2 path ++ "drive" | otherwise = joinDrive drv $ validElements $ validChars pth where (drv,pth) = splitDrive path validChars x = map f x f x | x `elem` badCharacters = '_' | otherwise = x validElements x = joinPath $ map g $ splitPath x g x = h (reverse b) ++ reverse a where (a,b) = span isPathSeparator $ reverse x h x = if map toUpper a `elem` badElements then a ++ "_" <.> b else x where (a,b) = splitExtensions x -- | Is a path relative, or is it fixed to the root? -- -- > Windows: isRelative "path\\test" == True -- > Windows: isRelative "c:\\test" == False -- > Windows: isRelative "c:test" == True -- > Windows: isRelative "c:" == True -- > Windows: isRelative "\\\\foo" == False -- > Windows: isRelative "/foo" == True -- > Posix: isRelative "test/path" == True -- > Posix: isRelative "/test" == False isRelative :: FilePath -> Bool isRelative = isRelativeDrive . takeDrive -- > isRelativeDrive "" == True -- > Windows: isRelativeDrive "c:\\" == False -- > Windows: isRelativeDrive "c:/" == False -- > Windows: isRelativeDrive "c:" == True -- > Windows: isRelativeDrive "\\\\foo" == False -- > Posix: isRelativeDrive "/" == False isRelativeDrive :: String -> Bool isRelativeDrive x = null x || maybe False (not . isPathSeparator . last . fst) (readDriveLetter x) -- | @not . 'isRelative'@ -- -- > isAbsolute x == not (isRelative x) isAbsolute :: FilePath -> Bool isAbsolute = not . isRelative curry-tools-v3.3.0/cpm/vendor/filepath/test/000077500000000000000000000000001377556325500210565ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/filepath/test/TestFilePath.curry000066400000000000000000000025411377556325500245020ustar00rootroot00000000000000----------------------------------------------------------------------------- -- A few tests for module System.FilePath ----------------------------------------------------------------------------- import Test.Prop import Data.List import System.FilePath sp1 :: [String] sp1 = ["Dir1","Dir2","Dir3"] testSplitSearchPath :: Prop testSplitSearchPath = splitSearchPath (intercalate [searchPathSeparator] sp1) -=- sp1 splitExtProp s = uncurry (++) (splitExtension s) -=- s addSplitProp s = uncurry addExtension (splitExtension s) -=- s testSplitExt1 = splitExtension "file.txt" -=- ("file",".txt") testSplitExt2 = splitExtension "file" -=- ("file","") testSplitExt3 = splitExtension "file/file.txt" -=- ("file/file",".txt") testSplitExt4 = splitExtension "file.txt/boris" -=- ("file.txt/boris","") testSplitExt5 = splitExtension "file.txt/boris.ext" -=- ("file.txt/boris",".ext") testSplitExt6 = splitExtension "file/path.txt.bob.fred" -=- ("file/path.txt.bob",".fred") testSplitExt7 = splitExtension "file/path.txt/" -=- ("file/path.txt/","") testReplExt1 = replaceExtension "file.txt" ".bob" -=- "file.bob" testReplExt2 = replaceExtension "file.txt" "bob" -=- "file.bob" testReplExt3 = replaceExtension "file" ".bob" -=- "file.bob" testReplExt4 = replaceExtension "file.txt" "" -=- "file" testReplExt5 = replaceExtension "file.fred.bob" "txt" -=- "file.fred.txt" curry-tools-v3.3.0/cpm/vendor/flatcurry/000077500000000000000000000000001377556325500203165ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/flatcurry/LICENSE000066400000000000000000000027351377556325500213320ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/flatcurry/README.md000066400000000000000000000032221377556325500215740ustar00rootroot00000000000000flatcurry ========= This package contains libraries to deal with FlatCurry programs. Currently, it contains the following modules: * `FlatCurry.Compact`: This module contains operations to reduce the size of FlatCurry programs by combining the main module and all imports into a single program that contains only the functions directly or indirectly called from a set of main functions. * `FlatCurry.Files`: This module defines operations to read and write FlatCurry programs. * `FlatCurry.FlexRigid`: provides a function to compute the rigid/flex status of a FlatCurry expression (right-hand side of a function definition). * `FlatCurry.Goodies`: This library provides selector functions, test and update operations as well as some useful auxiliary functions for FlatCurry data terms. * `FlatCurry.Pretty`: This library provides pretty-printers for FlatCurry modules and all substructures (e.g., expressions). * `FlatCurry.Read`: This library defines operations to read FlatCurry programs or interfaces together with all its imported modules in the current load path. * `FlatCurry.Show`: This library contains operations to transform FlatCurry programs into string representations, either in a FlatCurry format or in a Curry-like syntax. * `FlatCurry.Types`: This module defines the data types to represent FlatCurry programs in Curry. * `FlatCurry.XML`: This module contains operations to convert FlatCurry programs into corresponding XML expressions and vice versa. This can be used to store Curry programs in a way independent of a Curry system or to use a Curry system, like PAKCS, as back end by other functional logic programming systems. curry-tools-v3.3.0/cpm/vendor/flatcurry/package.json000066400000000000000000000025611377556325500226100ustar00rootroot00000000000000{ "name": "flatcurry", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Libraries to deal with FlatCurry programs", "category": [ "Metaprogramming" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "currypath" : ">= 3.0.0, < 4.0.0", "directory" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0", "frontend-exec" : ">= 3.0.0, < 4.0.0", "read-legacy" : ">= 3.0.0, < 4.0.0", "redblacktree" : ">= 3.0.0, < 4.0.0", "wl-pprint" : ">= 3.0.0, < 4.0.0", "xml" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "FlatCurry.Compact", "FlatCurry.Files", "FlatCurry.FlexRigid", "FlatCurry.Goodies", "FlatCurry.Pretty", "FlatCurry.Read", "FlatCurry.Show", "FlatCurry.Types", "FlatCurry.XML" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/flatcurry.git", "tag": "$version" }, "testsuite": { "src-dir": "test", "modules": [ "TestFlatCurryGoodies", "TestFlatCurryXML" ] } } curry-tools-v3.3.0/cpm/vendor/flatcurry/src/000077500000000000000000000000001377556325500211055ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/flatcurry/src/FlatCurry/000077500000000000000000000000001377556325500230205ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/flatcurry/src/FlatCurry/Compact.curry000066400000000000000000000572161377556325500255070ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains functions to reduce the size of FlatCurry programs --- by combining the main module and all imports into a single program --- that contains only the functions directly or indirectly called from --- a set of main functions. --- --- @author Michael Hanus, Carsten Heine --- @version December 2018 ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module FlatCurry.Compact(generateCompactFlatCurryFile,computeCompactFlatCurry, Option(..),RequiredSpec,requires,alwaysRequired, defaultRequired) where import FlatCurry.Types import FlatCurry.Files import qualified Data.Set.RBTree as RBS import qualified Data.Table.RBTree as RBT import Data.Maybe import Data.List ( nub, union ) import System.CurryPath ( lookupModuleSourceInLoadPath, stripCurrySuffix) import System.FilePath ( takeFileName, () ) import System.Directory import XML infix 0 `requires` ------------------------------------------------------------------------------ --- Options to guide the compactification process. --- @cons Verbose - for more output --- @cons Main - optimize for one main (unqualified!) function supplied here --- @cons Exports - optimize w.r.t. the exported functions of the module only --- @cons InitFuncs - optimize w.r.t. given list of initially required functions --- @cons Required - list of functions that are implicitly required and, thus, --- should not be deleted if the corresponding module --- is imported --- @cons Import - module that should always be imported --- (useful in combination with option InitFuncs) data Option = Verbose | Main String | Exports | InitFuncs [QName] | Required [RequiredSpec] | Import String deriving Eq isMainOption :: Option -> Bool isMainOption o = case o of Main _ -> True _ -> False getMainFuncFromOptions :: [Option] -> String getMainFuncFromOptions (o:os) = case o of Main f -> f _ -> getMainFuncFromOptions os getRequiredFromOptions :: [Option] -> [RequiredSpec] getRequiredFromOptions options = concat [ fs | Required fs <- options ] -- add Import for modules containing always required functions: addImport2Options :: [Option] -> [Option] addImport2Options options = options ++ map Import (nub (concatMap alwaysReqMod (getRequiredFromOptions options))) where alwaysReqMod (AlwaysReq (m,_)) = [m] alwaysReqMod (Requires _ _) = [] ------------------------------------------------------------------------------ --- Data type to specify requirements of functions. data RequiredSpec = AlwaysReq QName | Requires QName QName deriving Eq --- (fun `requires` reqfun) specifies that the use of the function "fun" --- implies the application of function "reqfun". requires :: QName -> QName -> RequiredSpec requires fun reqfun = Requires fun reqfun --- (alwaysRequired fun) specifies that the function "fun" should be --- always present if the corresponding module is loaded. alwaysRequired :: QName -> RequiredSpec alwaysRequired fun = AlwaysReq fun --- Functions that are implicitly required in a FlatCurry program --- (since they might be generated by external functions like --- "==" or "=:=" on the fly). defaultRequired :: [RequiredSpec] defaultRequired = [alwaysRequired (prelude,"apply"), alwaysRequired (prelude,"letrec"), alwaysRequired (prelude,"cond"), alwaysRequired (prelude,"failure"), (prelude,"==") `requires` (prelude,"&&"), (prelude,"=:=") `requires` (prelude,"&"), (prelude,"=:<=") `requires` (prelude,"ifVar"), (prelude,"=:<=") `requires` (prelude,"=:="), (prelude,"=:<=") `requires` (prelude,"&>"), (prelude,"=:<<=") `requires` (prelude,"&"), (prelude,"$#") `requires` (prelude,"ensureNotFree"), (prelude,"readFile") `requires` (prelude,"prim_readFileContents"), ("Ports","prim_openPortOnSocket") `requires` ("Ports","basicServerLoop"), ("Ports","prim_timeoutOnStream") `requires` ("Ports","basicServerLoop"), ("Ports","prim_choiceSPEP") `requires` ("Ports","basicServerLoop"), ("Dynamic","getDynamicKnowledge") `requires` ("Dynamic","isKnownAtTime") ] prelude :: String prelude = "Prelude" --- Get functions that are required in a module w.r.t. --- a requirement specification. getRequiredInModule :: [RequiredSpec] -> String -> [QName] getRequiredInModule reqspecs mod = concatMap getImpReq reqspecs where getImpReq (AlwaysReq (mf,f)) = if mf==mod then [(mf,f)] else [] getImpReq (Requires _ _) = [] --- Get functions that are implicitly required by a function w.r.t. --- a requirement specification. getImplicitlyRequired :: [RequiredSpec] -> QName -> [QName] getImplicitlyRequired reqspecs fun = concatMap getImpReq reqspecs where getImpReq (AlwaysReq _) = [] getImpReq (Requires f reqf) = if f==fun then [reqf] else [] --- The basic types that are always required in a FlatCurry program. defaultRequiredTypes :: [QName] defaultRequiredTypes = [(prelude,"()"),(prelude,"Int"),(prelude,"Float"),(prelude,"Char"), (prelude,"Success"),(prelude,"IO")] ------------------------------------------------------------------------------- -- Main functions: ------------------------------------------------------------------------------- --- Computes a single FlatCurry program containing all functions potentially --- called from a set of main functions and writes it into a FlatCurry file. --- This is done by merging all imported FlatCurry modules and removing --- the imported functions that are definitely not used. --- @param options - list of options --- @param progname - name of the Curry program that should be compacted --- @param target - name of the target file where the compact program is saved generateCompactFlatCurryFile :: [Option] -> String -> String -> IO () generateCompactFlatCurryFile options progname target = do optprog <- computeCompactFlatCurry options progname writeFCY target optprog --- Computes a single FlatCurry program containing all functions potentially --- called from a set of main functions. --- This is done by merging all imported FlatCurry modules (these are loaded --- demand-driven so that modules that contains no potentially called functions --- are not loaded) and removing the imported functions that are definitely --- not used. --- @param options - list of options --- @param progname - name of the Curry program that should be compacted --- @return the compact FlatCurry program computeCompactFlatCurry :: [Option] -> String -> IO Prog computeCompactFlatCurry orgoptions progname = let options = addImport2Options orgoptions in if (elem Exports options) && (any isMainOption options) then error "CompactFlat: Options 'Main' and 'Exports' can't be be used together!" else do putStr "CompactFlat: Searching relevant functions in module " prog <- readCurrentFlatCurry progname resultprog <- makeCompactFlatCurry prog options putStrLn ("CompactFlat: Number of functions after optimization: " ++ show (length (moduleFuns resultprog))) return resultprog --- Create the optimized program. makeCompactFlatCurry :: Prog -> [Option] -> IO Prog makeCompactFlatCurry mainmod options = do (initfuncs,loadedmnames,loadedmods) <- requiredInCompactProg mainmod options let initFuncTable = extendFuncTable (RBT.empty (<)) (concatMap moduleFuns loadedmods) required = getRequiredFromOptions options loadedreqfuns = concatMap (getRequiredInModule required) (map moduleName loadedmods) initreqfuncs = initfuncs ++ loadedreqfuns (finalmods,finalfuncs,finalcons,finaltcons) <- getCalledFuncs required loadedmnames loadedmods initFuncTable (foldr RBS.insert (RBS.empty (<)) initreqfuncs) (RBS.empty (<)) (RBS.empty (<)) initreqfuncs putStrLn ("\nCompactFlat: Total number of functions (without unused imports): " ++ show (foldr (+) 0 (map (length . moduleFuns) finalmods))) let finalfnames = map functionName finalfuncs return (Prog (moduleName mainmod) [] (let allTDecls = concatMap moduleTypes finalmods reqTCons = extendTConsWithConsType finalcons finaltcons allTDecls allReqTCons = requiredDatatypes reqTCons allTDecls in filter (\tdecl->tconsName tdecl `RBS.member` allReqTCons) allTDecls) finalfuncs (filter (\ (Op oname _ _) -> oname `elem` finalfnames) (concatMap moduleOps finalmods))) -- compute the transitive closure of a set of type constructors w.r.t. -- to a given list of type declaration so that the set contains -- all type constructor names occurring in the type declarations: requiredDatatypes :: RBS.SetRBT QName -> [TypeDecl] -> RBS.SetRBT QName requiredDatatypes tcnames tdecls = let newtcons = concatMap (newTypeConsOfTDecl tcnames) tdecls in if null newtcons then tcnames else requiredDatatypes (foldr RBS.insert tcnames newtcons) tdecls -- Extract the new type constructors (w.r.t. a given set) contained in a -- type declaration: newTypeConsOfTDecl :: RBS.SetRBT QName -> TypeDecl -> [QName] newTypeConsOfTDecl tcnames (TypeSyn tcons _ _ texp) = if tcons `RBS.member` tcnames then filter (\tc -> not (tc `RBS.member` tcnames)) (allTypesOfTExpr texp) else [] newTypeConsOfTDecl tcnames (TypeNew tcons _ _ (NewCons _ _ texp)) = if tcons `RBS.member` tcnames then filter (\tc -> not (tc `RBS.member` tcnames)) (allTypesOfTExpr texp) else [] newTypeConsOfTDecl tcnames (Type tcons _ _ cdecls) = if tcons `RBS.member` tcnames then filter (\tc -> not (tc `RBS.member` tcnames)) (concatMap (\ (Cons _ _ _ texps) -> concatMap allTypesOfTExpr texps) cdecls) else [] -- Extend set of type constructor with type constructors of data declarations -- contain some constructor. extendTConsWithConsType :: RBS.SetRBT QName -> RBS.SetRBT QName -> [TypeDecl] -> RBS.SetRBT QName extendTConsWithConsType _ tcons [] = tcons extendTConsWithConsType cnames tcons (TypeSyn tname _ _ _ : tds) = extendTConsWithConsType cnames (RBS.insert tname tcons) tds extendTConsWithConsType cnames tcons (TypeNew tname _ _ cdecl : tds) = if newConsName cdecl `RBS.member` cnames then extendTConsWithConsType cnames (RBS.insert tname tcons) tds else extendTConsWithConsType cnames tcons tds extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) = if tname `elem` defaultRequiredTypes || any (\cdecl->consName cdecl `RBS.member` cnames) cdecls then extendTConsWithConsType cnames (RBS.insert tname tcons) tds else extendTConsWithConsType cnames tcons tds -- Extend function table (mapping from qualified names to function declarations) -- by some new function declarations: extendFuncTable :: RBT.TableRBT QName FuncDecl -> [FuncDecl] -> RBT.TableRBT QName FuncDecl extendFuncTable ftable fdecls = foldr (\f t -> RBT.update (functionName f) f t) ftable fdecls ------------------------------------------------------------------------------- -- Generate the Prog to start with: ------------------------------------------------------------------------------- -- Compute the initially required functions in the compact program -- together with the set of module names and contents that are initially loaded: requiredInCompactProg :: Prog -> [Option] -> IO ([QName],RBS.SetRBT String,[Prog]) requiredInCompactProg mainmod options | not (null initfuncs) = do impprogs <- mapM readCurrentFlatCurry imports return (concat initfuncs, add2mainmodset imports, mainmod:impprogs) | Exports `elem` options = do impprogs <- mapM readCurrentFlatCurry imports return (nub mainexports, add2mainmodset imports, mainmod:impprogs) | any isMainOption options = let func = getMainFuncFromOptions options in if (mainmodname,func) `elem` (map functionName (moduleFuns mainmod)) then do impprogs <- mapM readCurrentFlatCurry imports return ([(mainmodname,func)], add2mainmodset imports, mainmod:impprogs) else error $ "CompactFlat: Cannot find main function \""++func++"\"!" | otherwise = do impprogs <- mapM readCurrentFlatCurry (nub (imports ++ moduleImports mainmod)) return (nub (mainexports ++ concatMap (exportedFuncNames . moduleFuns) impprogs), add2mainmodset (map moduleName impprogs), mainmod:impprogs) where imports = nub [ mname | Import mname <- options ] mainmodname = moduleName mainmod initfuncs = [ fs | InitFuncs fs <- options ] mainexports = exportedFuncNames (moduleFuns mainmod) mainmodset = RBS.insert mainmodname $ RBS.empty (<) add2mainmodset mnames = foldr RBS.insert mainmodset mnames -- extract the names of all exported functions: exportedFuncNames :: [FuncDecl] -> [QName] exportedFuncNames funs = map (\(Func name _ _ _ _)->name) (filter (\(Func _ _ vis _ _)->vis==Public) funs) ------------------------------------------------------------------------------- --- Adds all required functions to the program and load modules, if necessary. --- @param required - list of potentially required functions --- @param loadedmnames - set of already considered module names --- @param progs - list of already loaded modules --- @param functable - mapping from (loaded) function names to their definitions --- @param loadedfnames - set of already loaded function names --- @param loadedcnames - set of already required data constructors --- @param loadedtnames - set of already required data constructors --- @param fnames - list of function names to be analyzed for dependencies --- @return (list of loaded modules, list of required function declarations, --- set of required data constructors, set of required type names) getCalledFuncs :: [RequiredSpec] -> RBS.SetRBT String -> [Prog] -> RBT.TableRBT QName FuncDecl -> RBS.SetRBT QName -> RBS.SetRBT QName -> RBS.SetRBT QName -> [QName] -> IO ([Prog],[FuncDecl],RBS.SetRBT QName,RBS.SetRBT QName) getCalledFuncs _ _ progs _ _ dcs ts [] = return (progs,[],dcs,ts) getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames loadedtnames ((m,f):fs) | not (m `RBS.member` loadedmnames) = do newmod <- readCurrentFlatCurry m let reqnewfun = getRequiredInModule required m getCalledFuncs required (RBS.insert m loadedmnames) (newmod:progs) (extendFuncTable functable (moduleFuns newmod)) (foldr RBS.insert loadedfnames reqnewfun) loadedcnames loadedtnames ((m,f):fs ++ reqnewfun) | isNothing (RBT.lookup (m,f) functable) = -- this must be a data constructor: ingore it since already considered getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames loadedtnames fs | otherwise = do let fdecl = fromJust (RBT.lookup (m,f) functable) funcCalls = allFuncCalls fdecl newFuncCalls = filter (\qn->not (qn `RBS.member` loadedfnames)) funcCalls newReqs = concatMap (getImplicitlyRequired required) newFuncCalls consCalls = allConstructorsOfFunc fdecl newConsCalls = filter (\qn->not (qn `RBS.member` loadedcnames)) consCalls newtcons = allTypesOfFunc fdecl (newprogs,newfuns,newcons, newtypes) <- getCalledFuncs required loadedmnames progs functable (foldr RBS.insert loadedfnames (newFuncCalls++newReqs)) (foldr RBS.insert loadedcnames consCalls) (foldr RBS.insert loadedtnames newtcons) (fs ++ newFuncCalls ++ newReqs ++ newConsCalls) return (newprogs, fdecl:newfuns, newcons, newtypes) ------------------------------------------------------------------------------- -- Operations to get all function calls, types,... in a function declaration: ------------------------------------------------------------------------------- --- Get all function calls in a function declaration and remove duplicates. --- @param funcDecl - a function declaration in FlatCurry --- @return a list of all function calls allFuncCalls :: FuncDecl -> [QName] allFuncCalls (Func _ _ _ _ (External _)) = [] allFuncCalls (Func _ _ _ _ (Rule _ expr)) = nub (allFuncCallsOfExpr expr) --- Get all function calls in an expression. --- @param expr - an expression --- @return a list of all function calls allFuncCallsOfExpr :: Expr -> [QName] allFuncCallsOfExpr (Var _) = [] allFuncCallsOfExpr (Lit _) = [] allFuncCallsOfExpr (Comb ctype fname exprs) = case ctype of FuncCall -> fname:fnames FuncPartCall _ -> fname:fnames _ -> fnames where fnames = concatMap allFuncCallsOfExpr exprs allFuncCallsOfExpr (Free _ expr) = allFuncCallsOfExpr expr allFuncCallsOfExpr (Let bs expr) = concatMap (allFuncCallsOfExpr . snd) bs ++ allFuncCallsOfExpr expr allFuncCallsOfExpr (Or expr1 expr2) = allFuncCallsOfExpr expr1 ++ allFuncCallsOfExpr expr2 allFuncCallsOfExpr (Case _ expr branchExprs) = allFuncCallsOfExpr expr ++ concatMap allFuncCallsOfBranchExpr branchExprs allFuncCallsOfExpr (Typed expr _) = allFuncCallsOfExpr expr --- Get all function calls in a branch expression in case expressions. --- @param branchExpr - a branch expression --- @return a list of all function calls allFuncCallsOfBranchExpr :: BranchExpr -> [QName] allFuncCallsOfBranchExpr (Branch _ expr) = allFuncCallsOfExpr expr --- Get all data constructors in a function declaration. allConstructorsOfFunc :: FuncDecl -> [QName] allConstructorsOfFunc (Func _ _ _ _ (External _)) = [] allConstructorsOfFunc (Func _ _ _ _ (Rule _ expr)) = allConsOfExpr expr --- Get all data constructors in an expression. allConsOfExpr :: Expr -> [QName] allConsOfExpr (Var _) = [] allConsOfExpr (Lit _) = [] allConsOfExpr (Comb ctype cname exprs) = case ctype of ConsCall -> cname:cnames ConsPartCall _ -> cname:cnames _ -> cnames where cnames = unionMap allConsOfExpr exprs allConsOfExpr (Free _ expr) = allConsOfExpr expr allConsOfExpr (Let bs expr) = union (unionMap (allConsOfExpr . snd) bs) (allConsOfExpr expr) allConsOfExpr (Or expr1 expr2) = union (allConsOfExpr expr1) (allConsOfExpr expr2) allConsOfExpr (Case _ expr branchExprs) = union (allConsOfExpr expr) (unionMap consOfBranch branchExprs) where consOfBranch (Branch (LPattern _) e) = allConsOfExpr e consOfBranch (Branch (Pattern c _) e) = union [c] (allConsOfExpr e) allConsOfExpr (Typed expr _) = allConsOfExpr expr --- Get all type constructors in a function declaration. allTypesOfFunc :: FuncDecl -> [QName] allTypesOfFunc (Func _ _ _ texp _) = allTypesOfTExpr texp --- Get all data constructors in an expression. allTypesOfTExpr :: TypeExpr -> [QName] allTypesOfTExpr (TVar _) = [] allTypesOfTExpr (FuncType texp1 texp2) = union (allTypesOfTExpr texp1) (allTypesOfTExpr texp2) allTypesOfTExpr (TCons tcons args) = union [tcons] (unionMap allTypesOfTExpr args) unionMap :: Eq b => (a -> [b]) -> [a] -> [b] unionMap f = foldr union [] . map f ------------------------------------------------------------------------------- -- Functions to get direct access to some data inside a datatype: ------------------------------------------------------------------------------- --- Extracts the function name of a function declaration. functionName :: FuncDecl -> QName functionName (Func name _ _ _ _) = name --- Extracts the constructor name of a constructor declaration. consName :: ConsDecl -> QName consName (Cons name _ _ _) = name --- Extracts the constructor name of a newtype constructor declaration. newConsName :: NewConsDecl -> QName newConsName (NewCons name _ _) = name --- Extracts the type name of a type declaration. tconsName :: TypeDecl -> QName tconsName (Type name _ _ _) = name tconsName (TypeSyn name _ _ _) = name tconsName (TypeNew name _ _ _) = name --- Extracts the names of imported modules of a FlatCurry program. moduleImports :: Prog -> [String] moduleImports (Prog _ imports _ _ _) = imports --- Extracts the types of a FlatCurry program. moduleTypes :: Prog -> [TypeDecl] moduleTypes (Prog _ _ types _ _) = types --- Extracts the operators of a FlatCurry program. moduleOps :: Prog -> [OpDecl] moduleOps (Prog _ _ _ _ ops) = ops --- Extracts the name of the Prog. moduleName :: Prog -> String moduleName (Prog name _ _ _ _) = name --- Extracts the functions of the program. moduleFuns :: Prog -> [FuncDecl] moduleFuns (Prog _ _ _ funs _) = funs ------------------------------------------------------------------------------- -- Functions for comparison: ------------------------------------------------------------------------------- --- Compares two qualified names. --- Returns True, if the first name is lexicographically smaller than --- the second name using the leString function to compare String. leqQName :: QName -> QName -> Bool leqQName (m1,n1) (m2,n2) = let cm = compare m1 m2 in cm == LT || (cm == EQ && n1 <= n2) ------------------------------------------------------------------------------- -- I/O functions: ------------------------------------------------------------------------------- -- Read a FlatCurry program (parse only if necessary): readCurrentFlatCurry :: String -> IO Prog readCurrentFlatCurry modname = do putStr (modname++"...") mbsrc <- lookupModuleSourceInLoadPath modname case mbsrc of Nothing -> error ("Curry file for module \""++modname++"\" not found!") Just (moddir,progname) -> do let fcyname = flatCurryFileName (moddir takeFileName modname) fcyexists <- doesFileExist fcyname if not fcyexists then readFlatCurry modname >>= processPrimitives progname else do ctime <- getModificationTime progname ftime <- getModificationTime fcyname if ctime>ftime then readFlatCurry progname >>= processPrimitives progname else readFlatCurryFile fcyname >>= processPrimitives progname -- read primitive specification and transform FlatCurry program accordingly: processPrimitives :: String -> Prog -> IO Prog processPrimitives progname prog = do pspecs <- readPrimSpec (moduleName prog) (stripCurrySuffix progname ++ ".pakcs") return (mergePrimSpecIntoModule pspecs prog) mergePrimSpecIntoModule :: [(QName,QName)] -> Prog -> Prog mergePrimSpecIntoModule trans (Prog name imps types funcs ops) = Prog name imps types (concatMap (mergePrimSpecIntoFunc trans) funcs) ops mergePrimSpecIntoFunc :: [(QName,QName)] -> FuncDecl -> [FuncDecl] mergePrimSpecIntoFunc trans (Func name ar vis tp rule) = let fname = lookup name trans in if fname==Nothing then [Func name ar vis tp rule] else let Just (lib,entry) = fname in if null entry then [] else [Func name ar vis tp (External (lib++' ':entry))] readPrimSpec :: String -> String -> IO [(QName,QName)] readPrimSpec mod xmlfilename = do existsXml <- doesFileExist xmlfilename if existsXml then do --putStrLn $ "Reading specification '"++xmlfilename++"'..." xmldoc <- readXmlFile xmlfilename return (xml2primtrans mod xmldoc) else return [] xml2primtrans :: String -> XmlExp -> [(QName,QName)] xml2primtrans mod (XElem "primitives" [] primitives) = map xml2prim primitives where xml2prim (XElem "primitive" (("name",fname):_) [XElem "library" [] xlib, XElem "entry" [] xfun]) = ((mod,fname),(textOfXml xlib,textOfXml xfun)) xml2prim (XElem "ignore" (("name",fname):_) []) = ((mod,fname),("","")) ------------------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/flatcurry/src/FlatCurry/Files.curry000066400000000000000000000157201377556325500251550ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library supports meta-programming, i.e., the manipulation of --- Curry programs in Curry. This library defines I/O actions --- to read Curry programs and transform them into this representation. --- --- @author Michael Hanus, Finn Teegen --- @version November 2020 ------------------------------------------------------------------------------ module FlatCurry.Files where import System.Directory ( doesFileExist, getFileWithSuffix , findFileWithSuffix ) import System.FilePath ( takeFileName, (), (<.>)) import System.CurryPath ( inCurrySubdir, stripCurrySuffix , lookupModuleSourceInLoadPath, getLoadPathForModule ) import System.FrontendExec ( FrontendParams, FrontendTarget (..), defaultParams , setQuiet, callFrontendWithParams ) import ReadShowTerm (readUnqualifiedTerm, showTerm) import FlatCurry.Types --- I/O action which parses a Curry program and returns the corresponding --- FlatCurry program. --- Thus, the argument is the module path (without suffix ".curry" --- or ".lcurry") and the result is a FlatCurry term representing this --- program. readFlatCurry :: String -> IO Prog readFlatCurry progname = readFlatCurryWithParseOptions progname (setQuiet True defaultParams) --- I/O action which parses a Curry program --- with respect to some parser options and returns the --- corresponding FlatCurry program. --- This I/O action is used by the standard action `readFlatCurry`. --- @param progfile - the program file name (without suffix ".curry") --- @param options - parameters passed to the front end readFlatCurryWithParseOptions :: String -> FrontendParams -> IO Prog readFlatCurryWithParseOptions progname options = do mbsrc <- lookupModuleSourceInLoadPath progname case mbsrc of Nothing -> do -- no source file, try to find FlatCurry file in load path: loadpath <- getLoadPathForModule progname filename <- getFileWithSuffix (flatCurryFileName (takeFileName progname)) [""] loadpath readFlatCurryFile filename Just (dir,_) -> do callFrontendWithParams FCY options progname readFlatCurryFile (flatCurryFileName (dir takeFileName progname)) --- Transforms a name of a Curry program (with or without suffix ".curry" --- or ".lcurry") into the name of the file containing the --- corresponding FlatCurry program. flatCurryFileName :: String -> String flatCurryFileName prog = inCurrySubdir (stripCurrySuffix prog) <.> "fcy" --- Transforms a name of a Curry program (with or without suffix ".curry" --- or ".lcurry") into the name of the file containing the --- corresponding FlatCurry program. flatCurryIntName :: String -> String flatCurryIntName prog = inCurrySubdir (stripCurrySuffix prog) <.> "fint" --- I/O action which reads a FlatCurry program from a file in ".fcy" format. --- In contrast to `readFlatCurry`, this action does not parse --- a source program. Thus, the argument must be the name of an existing --- file (with suffix ".fcy") containing a FlatCurry program in ".fcy" --- format and the result is a FlatCurry term representing this program. readFlatCurryFile :: String -> IO Prog readFlatCurryFile filename = do exfcy <- doesFileExist filename if exfcy then readExistingFCY filename else do let subdirfilename = inCurrySubdir filename exdirfcy <- doesFileExist subdirfilename if exdirfcy then readExistingFCY subdirfilename else error ("EXISTENCE ERROR: FlatCurry file '" ++ filename ++ "' does not exist") where readExistingFCY fname = do filecontents <- readFile fname return (readUnqualifiedTerm ["FlatCurry.Types","Prelude"] filecontents) --- I/O action which returns the interface of a Curry module, i.e., --- a FlatCurry program containing only "Public" entities and function --- definitions without rules (i.e., external functions). --- The argument is the file name without suffix ".curry" --- (or ".lcurry") and the result is a FlatCurry term representing the --- interface of this module. readFlatCurryInt :: String -> IO Prog readFlatCurryInt progname = do readFlatCurryIntWithParseOptions progname (setQuiet True defaultParams) --- I/O action which parses Curry program --- with respect to some parser options and returns the FlatCurry --- interface of this program, i.e., --- a FlatCurry program containing only "Public" entities and function --- definitions without rules (i.e., external functions). --- The argument is the file name without suffix ".curry" --- (or ".lcurry") and the result is a FlatCurry term representing the --- interface of this module. readFlatCurryIntWithParseOptions :: String -> FrontendParams -> IO Prog readFlatCurryIntWithParseOptions progname options = do mbsrc <- lookupModuleSourceInLoadPath progname case mbsrc of Nothing -> do -- no source file, try to find FlatCurry file in load path: loadpath <- getLoadPathForModule progname filename <- getFileWithSuffix (flatCurryIntName (takeFileName progname)) [""] loadpath readFlatCurryFile filename Just (dir,_) -> do callFrontendWithParams FINT options progname readFlatCurryFile (flatCurryIntName (dir takeFileName progname)) --- Writes a FlatCurry program into a file in `.fcy` format. --- The file is written in the standard location for intermediate files, --- i.e., in the 'flatCurryFileName' relative to the directory of the --- Curry source program (which must exist!). writeFlatCurry :: Prog -> IO () writeFlatCurry prog@(Prog mname _ _ _ _) = do mbsrc <- lookupModuleSourceInLoadPath mname case mbsrc of Nothing -> error $ "Curry source file for module '" ++ mname ++ "' not found!" Just (dir,_) -> writeFlatCurryFile (flatCurryFileName (dir mname)) prog --- Writes a FlatCurry program into a file in ".fcy" format. --- The first argument must be the name of the target file --- (usually with suffix ".fcy"). writeFlatCurryFile :: String -> Prog -> IO () writeFlatCurryFile file prog = writeFile file (showTerm prog) --- Writes a FlatCurry program into a file in ".fcy" format. --- The first argument must be the name of the target file --- (usually with suffix ".fcy"). writeFCY :: String -> Prog -> IO () writeFCY = writeFlatCurryFile --- Returns the name of the FlatCurry file of a module in the load path, --- if this file exists. lookupFlatCurryFileInLoadPath :: String -> IO (Maybe String) lookupFlatCurryFileInLoadPath modname = getLoadPathForModule modname >>= findFileWithSuffix (flatCurryFileName modname) [""] --- Returns the name of the FlatCurry file of a module in the load path, --- if this file exists. getFlatCurryFileInLoadPath :: String -> IO String getFlatCurryFileInLoadPath modname = getLoadPathForModule modname >>= getFileWithSuffix (flatCurryFileName modname) [""] curry-tools-v3.3.0/cpm/vendor/flatcurry/src/FlatCurry/FlexRigid.curry000066400000000000000000000044231377556325500257660ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library provides a function to compute the rigid/flex status --- of a FlatCurry expression (right-hand side of a function definition). --- --- @author Michael Hanus --- @version April 2005 ------------------------------------------------------------------------------ module FlatCurry.FlexRigid(FlexRigidResult(..),getFlexRigid) where import FlatCurry.Types --- Datatype for representing a flex/rigid status of an expression. data FlexRigidResult = UnknownFR | ConflictFR | KnownFlex | KnownRigid --- Computes the rigid/flex status of a FlatCurry expression. --- This function checks all cases in this expression. --- If the expression has rigid as well as flex cases (which cannot --- be the case for source level programs but might occur after --- some program transformations), the result ConflictFR is returned. getFlexRigid :: Expr -> FlexRigidResult getFlexRigid (Var _) = UnknownFR getFlexRigid (Lit _) = UnknownFR getFlexRigid (Comb _ _ args) = foldr joinCaseTypes UnknownFR (map getFlexRigid args) getFlexRigid (Let _ e) = getFlexRigid e getFlexRigid (Free _ e) = getFlexRigid e getFlexRigid (Or e1 e2) = joinCaseTypes (getFlexRigid e1) (getFlexRigid e2) getFlexRigid (Case ctype e bs) = foldr joinCaseTypes (if ctype==Flex then KnownFlex else KnownRigid) (map getFlexRigid (e : map (\(Branch _ be)->be) bs)) getFlexRigid (Typed e _) = getFlexRigid e joinCaseTypes :: FlexRigidResult -> FlexRigidResult -> FlexRigidResult joinCaseTypes ConflictFR ConflictFR = ConflictFR joinCaseTypes ConflictFR UnknownFR = ConflictFR joinCaseTypes ConflictFR KnownFlex = ConflictFR joinCaseTypes ConflictFR KnownRigid = ConflictFR joinCaseTypes UnknownFR ConflictFR = ConflictFR joinCaseTypes KnownFlex ConflictFR = ConflictFR joinCaseTypes KnownRigid ConflictFR = ConflictFR joinCaseTypes UnknownFR UnknownFR = UnknownFR joinCaseTypes UnknownFR KnownFlex = KnownFlex joinCaseTypes UnknownFR KnownRigid = KnownRigid joinCaseTypes KnownFlex UnknownFR = KnownFlex joinCaseTypes KnownFlex KnownFlex = KnownFlex joinCaseTypes KnownFlex KnownRigid = ConflictFR joinCaseTypes KnownRigid UnknownFR = KnownRigid joinCaseTypes KnownRigid KnownFlex = ConflictFR joinCaseTypes KnownRigid KnownRigid = KnownRigid curry-tools-v3.3.0/cpm/vendor/flatcurry/src/FlatCurry/Goodies.curry000066400000000000000000000764451377556325500255170ustar00rootroot00000000000000---------------------------------------------------------------------------- --- This library provides selector functions, test and update operations --- as well as some useful auxiliary functions for FlatCurry data terms. --- Most of the provided functions are based on general transformation --- functions that replace constructors with user-defined --- functions. For recursive datatypes the transformations are defined --- inductively over the term structure. This is quite usual for --- transformations on FlatCurry terms, --- so the provided functions can be used to implement specific transformations --- without having to explicitly state the recursion. Essentially, the tedious --- part of such transformations - descend in fairly complex term structures - --- is abstracted away, which hopefully makes the code more clear and brief. --- --- @author Sebastian Fischer --- @version November 2020 ---------------------------------------------------------------------------- module FlatCurry.Goodies where import FlatCurry.Types type Update a b = (b -> b) -> a -> a -- Prog ---------------------------------------------------------------------- --- transform program trProg :: (String -> [String] -> [TypeDecl] -> [FuncDecl] -> [OpDecl] -> a) -> Prog -> a trProg prog (Prog name imps types funcs ops) = prog name imps types funcs ops -- Selectors --- get name from program progName :: Prog -> String progName = trProg (\name _ _ _ _ -> name) --- get imports from program progImports :: Prog -> [String] progImports = trProg (\_ imps _ _ _ -> imps) --- get type declarations from program progTypes :: Prog -> [TypeDecl] progTypes = trProg (\_ _ types _ _ -> types) --- get functions from program progFuncs :: Prog -> [FuncDecl] progFuncs = trProg (\_ _ _ funcs _ -> funcs) --- get infix operators from program progOps :: Prog -> [OpDecl] progOps = trProg (\_ _ _ _ ops -> ops) -- Update Operations --- update program updProg :: (String -> String) -> ([String] -> [String]) -> ([TypeDecl] -> [TypeDecl]) -> ([FuncDecl] -> [FuncDecl]) -> ([OpDecl] -> [OpDecl]) -> Prog -> Prog updProg fn fi ft ff fo = trProg prog where prog name imps types funcs ops = Prog (fn name) (fi imps) (ft types) (ff funcs) (fo ops) --- update name of program updProgName :: Update Prog String updProgName f = updProg f id id id id --- update imports of program updProgImports :: Update Prog [String] updProgImports f = updProg id f id id id --- update type declarations of program updProgTypes :: Update Prog [TypeDecl] updProgTypes f = updProg id id f id id --- update functions of program updProgFuncs :: Update Prog [FuncDecl] updProgFuncs f = updProg id id id f id --- update infix operators of program updProgOps :: Update Prog [OpDecl] updProgOps = updProg id id id id -- Auxiliary Functions --- get all program variables (also from patterns) allVarsInProg :: Prog -> [VarIndex] allVarsInProg = concatMap allVarsInFunc . progFuncs --- lift transformation on expressions to program updProgExps :: Update Prog Expr updProgExps = updProgFuncs . map . updFuncBody --- rename programs variables rnmAllVarsInProg :: Update Prog VarIndex rnmAllVarsInProg = updProgFuncs . map . rnmAllVarsInFunc --- update all qualified names in program updQNamesInProg :: Update Prog QName updQNamesInProg f = updProg id id (map (updQNamesInType f)) (map (updQNamesInFunc f)) (map (updOpName f)) --- rename program (update name of and all qualified names in program) rnmProg :: String -> Prog -> Prog rnmProg name p = updProgName (const name) (updQNamesInProg rnm p) where rnm (mod,n) | mod==progName p = (name,n) | otherwise = (mod,n) -- TypeDecl ------------------------------------------------------------------ -- Selectors --- transform type declaration trType :: (QName -> Visibility -> [(TVarIndex,Kind)] -> [ConsDecl] -> a) -> (QName -> Visibility -> [(TVarIndex,Kind)] -> TypeExpr -> a) -> (QName -> Visibility -> [(TVarIndex,Kind)] -> NewConsDecl -> a) -> TypeDecl -> a trType typ _ _ (Type name vis params cs) = typ name vis params cs trType _ typesyn _ (TypeSyn name vis params syn) = typesyn name vis params syn trType _ _ typenew (TypeNew name vis params c) = typenew name vis params c --- get name of type declaration typeName :: TypeDecl -> QName typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name) (\name _ _ _ -> name) --- get visibility of type declaration typeVisibility :: TypeDecl -> Visibility typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) --- get type parameters of type declaration typeParams :: TypeDecl -> [(TVarIndex, Kind)] typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params) (\_ _ params _ -> params) --- get constructor declarations from type declaration typeConsDecls :: TypeDecl -> [ConsDecl] typeConsDecls = trType (\_ _ _ cs -> cs) failed failed --- get synonym of type declaration typeSyn :: TypeDecl -> TypeExpr typeSyn = trType failed (\_ _ _ syn -> syn) failed --- is type declaration a basic data type? isTypeData :: TypeDecl -> Bool isTypeData = trType (\_ _ _ _ -> True) (\_ _ _ _ -> False) (\_ _ _ _ -> False) --- is type declaration a type synonym? isTypeSyn :: TypeDecl -> Bool isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True) (\_ _ _ _ -> False) --- is type declaration a newtype? isTypeNew :: TypeDecl -> Bool isTypeNew = trType (\_ _ _ _ -> False) (\_ _ _ _ -> False) (\_ _ _ _ -> True) -- Update Operations --- update type declaration updType :: (QName -> QName) -> (Visibility -> Visibility) -> ([(TVarIndex,Kind)] -> [(TVarIndex,Kind)]) -> ([ConsDecl] -> [ConsDecl]) -> (NewConsDecl -> NewConsDecl) -> (TypeExpr -> TypeExpr) -> TypeDecl -> TypeDecl updType fn fv fp fc fnc fs = trType typ typesyn typenew where typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs) typesyn name vis params syn = TypeSyn (fn name) (fv vis) (fp params) (fs syn) typenew name vis params nc = TypeNew (fn name) (fv vis) (fp params) (fnc nc) --- update name of type declaration updTypeName :: Update TypeDecl QName updTypeName f = updType f id id id id id --- update visibility of type declaration updTypeVisibility :: Update TypeDecl Visibility updTypeVisibility f = updType id f id id id id --- update type parameters of type declaration updTypeParams :: Update TypeDecl [(TVarIndex, Kind)] updTypeParams f = updType id id f id id id --- update constructor declarations of type declaration updTypeConsDecls :: Update TypeDecl [ConsDecl] updTypeConsDecls f = updType id id id f id id --- update newtype constructor declaration of type declaration updTypeNewConsDecl :: Update TypeDecl NewConsDecl updTypeNewConsDecl f = updType id id id id f id --- update synonym of type declaration updTypeSynonym :: Update TypeDecl TypeExpr updTypeSynonym = updType id id id id id -- Auxiliary Functions --- update all qualified names in type declaration updQNamesInType :: Update TypeDecl QName updQNamesInType f = updType f id id (map (updQNamesInConsDecl f)) (updQNamesInNewConsDecl f) (updQNamesInTypeExpr f) -- ConsDecl ------------------------------------------------------------------ -- Selectors --- transform constructor declaration trCons :: (QName -> Int -> Visibility -> [TypeExpr] -> a) -> ConsDecl -> a trCons cons (Cons name arity vis args) = cons name arity vis args --- get name of constructor declaration consName :: ConsDecl -> QName consName = trCons (\name _ _ _ -> name) --- get arity of constructor declaration consArity :: ConsDecl -> Int consArity = trCons (\_ arity _ _ -> arity) --- get visibility of constructor declaration consVisibility :: ConsDecl -> Visibility consVisibility = trCons (\_ _ vis _ -> vis) --- get arguments of constructor declaration consArgs :: ConsDecl -> [TypeExpr] consArgs = trCons (\_ _ _ args -> args) -- Update Operations --- update constructor declaration updCons :: (QName -> QName) -> (Int -> Int) -> (Visibility -> Visibility) -> ([TypeExpr] -> [TypeExpr]) -> ConsDecl -> ConsDecl updCons fn fa fv fas = trCons cons where cons name arity vis args = Cons (fn name) (fa arity) (fv vis) (fas args) --- update name of constructor declaration updConsName :: Update ConsDecl QName updConsName f = updCons f id id id --- update arity of constructor declaration updConsArity :: Update ConsDecl Int updConsArity f = updCons id f id id --- update visibility of constructor declaration updConsVisibility :: Update ConsDecl Visibility updConsVisibility f = updCons id id f id --- update arguments of constructor declaration updConsArgs :: Update ConsDecl [TypeExpr] updConsArgs = updCons id id id -- Auxiliary Functions --- update all qualified names in constructor declaration updQNamesInConsDecl :: Update ConsDecl QName updQNamesInConsDecl f = updCons f id id (map (updQNamesInTypeExpr f)) -- NewConsDecl ------------------------------------------------------------------ --- transform newtype constructor declaration trNewCons :: (QName -> Visibility -> TypeExpr -> a) -> NewConsDecl -> a trNewCons cons (NewCons name vis arg) = cons name vis arg -- get argument of newtype constructor declaration newConsArg :: NewConsDecl -> TypeExpr newConsArg = trNewCons (\_ _ arg -> arg) -- get name of newtype constructor declaration newConsName :: NewConsDecl -> QName newConsName = trNewCons (\name _ _ -> name) -- get visibility of newtype constructor declaration newConsVisibility :: NewConsDecl -> Visibility newConsVisibility = trNewCons (\_ vis _ -> vis) -- Update Operations --- update newtype constructor declaration updNewCons :: (QName -> QName) -> (Visibility -> Visibility) -> (TypeExpr -> TypeExpr) -> NewConsDecl -> NewConsDecl updNewCons fn fv fas = trNewCons newcons where newcons name vis args = NewCons (fn name) (fv vis) (fas args) --- update name of newtype constructor declaration updNewConsName :: Update NewConsDecl QName updNewConsName f = updNewCons f id id --- update visibility of newtype constructor declaration updNewConsVisibility :: Update NewConsDecl Visibility updNewConsVisibility f = updNewCons id f id --- update argument of newtype constructor declaration updNewConsArg :: Update NewConsDecl TypeExpr updNewConsArg = updNewCons id id -- Auxiliary Functions updQNamesInNewConsDecl :: Update NewConsDecl QName updQNamesInNewConsDecl f = updNewCons f id (updQNamesInTypeExpr f) -- TypeExpr ------------------------------------------------------------------ -- Selectors --- get index from type variable tVarIndex :: TypeExpr -> TVarIndex tVarIndex texpr = case texpr of (TVar n) -> n _ -> error "FlatCurryGoodies.tVarIndex: no type variable" --- get domain from functional type domain :: TypeExpr -> TypeExpr domain texpr = case texpr of (FuncType dom _) -> dom _ -> error "FlatCurryGoodies.domain: no functional type" --- get range from functional type range :: TypeExpr -> TypeExpr range texpr = case texpr of (FuncType _ ran) -> ran _ -> error "FlatCurryGoodies.range: no functional type" --- get name from constructed type tConsName :: TypeExpr -> QName tConsName texpr = case texpr of (TCons name _) -> name _ -> error "FlatCurryGoodies.tConsName: no constructed type" --- get arguments from constructed type tConsArgs :: TypeExpr -> [TypeExpr] tConsArgs texpr = case texpr of (TCons _ args) -> args _ -> error "FlatCurryGoodies.tConsArgs: no constructed type" --- transform type expression trTypeExpr :: (TVarIndex -> a) -> (QName -> [a] -> a) -> (a -> a -> a) -> ([(TVarIndex, Kind)] -> a -> a) -> TypeExpr -> a trTypeExpr tvar _ _ _ (TVar tv) = tvar tv trTypeExpr tvar tcons functype foralltype (TCons name args) = tcons name (map (trTypeExpr tvar tcons functype foralltype) args) trTypeExpr tvar tcons functype foralltype (FuncType from to) = functype (f from) (f to) where f = trTypeExpr tvar tcons functype foralltype trTypeExpr tvar tcons functype foralltype (ForallType ns t) = foralltype ns (trTypeExpr tvar tcons functype foralltype t) -- Test Operations --- is type expression a type variable? isTVar :: TypeExpr -> Bool isTVar = trTypeExpr (\_ -> True) (\_ _ -> False) (\_ _ -> False) (\_ _ -> False) --- is type declaration a constructed type? isTCons :: TypeExpr -> Bool isTCons = trTypeExpr (\_ -> False) (\_ _ -> True) (\_ _ -> False) (\_ _ -> False) --- is type declaration a functional type? isFuncType :: TypeExpr -> Bool isFuncType = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> True) (\_ _ -> False) --- is type declaration a forall type? isForallType :: TypeExpr -> Bool isForallType = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> False) (\_ _ -> True) -- Update Operations --- update all type variables updTVars :: (TVarIndex -> TypeExpr) -> TypeExpr -> TypeExpr updTVars tvar = trTypeExpr tvar TCons FuncType ForallType --- update all type constructors updTCons :: (QName -> [TypeExpr] -> TypeExpr) -> TypeExpr -> TypeExpr updTCons tcons = trTypeExpr TVar tcons FuncType ForallType --- update all functional types updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr updFuncTypes functype = trTypeExpr TVar TCons functype ForallType --- update all forall types updForallTypes :: ([(TVarIndex, Kind)] -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr updForallTypes = trTypeExpr TVar TCons FuncType -- Auxiliary Functions --- get argument types from functional type argTypes :: TypeExpr -> [TypeExpr] argTypes (TVar _) = [] argTypes (TCons _ _) = [] argTypes (FuncType dom ran) = dom : argTypes ran argTypes (ForallType _ _) = [] --- get result type from (nested) functional type resultType :: TypeExpr -> TypeExpr resultType (TVar n) = TVar n resultType (TCons name args) = TCons name args resultType (FuncType _ ran) = resultType ran resultType (ForallType ns t) = ForallType ns t --- rename variables in type expression rnmAllVarsInTypeExpr :: (TVarIndex -> TVarIndex) -> TypeExpr -> TypeExpr rnmAllVarsInTypeExpr f = updTVars (TVar . f) --- update all qualified names in type expression updQNamesInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr updQNamesInTypeExpr f = updTCons (\name args -> TCons (f name) args) -- OpDecl -------------------------------------------------------------------- --- transform operator declaration trOp :: (QName -> Fixity -> Int -> a) -> OpDecl -> a trOp op (Op name fix prec) = op name fix prec -- Selectors --- get name from operator declaration opName :: OpDecl -> QName opName = trOp (\name _ _ -> name) --- get fixity of operator declaration opFixity :: OpDecl -> Fixity opFixity = trOp (\_ fix _ -> fix) --- get precedence of operator declaration opPrecedence :: OpDecl -> Int opPrecedence = trOp (\_ _ prec -> prec) -- Update Operations --- update operator declaration updOp :: (QName -> QName) -> (Fixity -> Fixity) -> (Int -> Int) -> OpDecl -> OpDecl updOp fn ff fp = trOp op where op name fix prec = Op (fn name) (ff fix) (fp prec) --- update name of operator declaration updOpName :: Update OpDecl QName updOpName f = updOp f id id --- update fixity of operator declaration updOpFixity :: Update OpDecl Fixity updOpFixity f = updOp id f id --- update precedence of operator declaration updOpPrecedence :: Update OpDecl Int updOpPrecedence = updOp id id -- FuncDecl ------------------------------------------------------------------ --- transform function trFunc :: (QName -> Int -> Visibility -> TypeExpr -> Rule -> a) -> FuncDecl -> a trFunc func (Func name arity vis t rule) = func name arity vis t rule -- Selectors --- get name of function funcName :: FuncDecl -> QName funcName = trFunc (\name _ _ _ _ -> name) --- get arity of function funcArity :: FuncDecl -> Int funcArity = trFunc (\_ arity _ _ _ -> arity) --- get visibility of function funcVisibility :: FuncDecl -> Visibility funcVisibility = trFunc (\_ _ vis _ _ -> vis) --- get type of function funcType :: FuncDecl -> TypeExpr funcType = trFunc (\_ _ _ t _ -> t) --- get rule of function funcRule :: FuncDecl -> Rule funcRule = trFunc (\_ _ _ _ rule -> rule) -- Update Operations --- update function updFunc :: (QName -> QName) -> (Int -> Int) -> (Visibility -> Visibility) -> (TypeExpr -> TypeExpr) -> (Rule -> Rule) -> FuncDecl -> FuncDecl updFunc fn fa fv ft fr = trFunc func where func name arity vis t rule = Func (fn name) (fa arity) (fv vis) (ft t) (fr rule) --- update name of function updFuncName :: Update FuncDecl QName updFuncName f = updFunc f id id id id --- update arity of function updFuncArity :: Update FuncDecl Int updFuncArity f = updFunc id f id id id --- update visibility of function updFuncVisibility :: Update FuncDecl Visibility updFuncVisibility f = updFunc id id f id id --- update type of function updFuncType :: Update FuncDecl TypeExpr updFuncType f = updFunc id id id f id --- update rule of function updFuncRule :: Update FuncDecl Rule updFuncRule = updFunc id id id id -- Auxiliary Functions --- is function externally defined? isExternal :: FuncDecl -> Bool isExternal = isRuleExternal . funcRule --- get variable names in a function declaration allVarsInFunc :: FuncDecl -> [Int] allVarsInFunc = allVarsInRule . funcRule --- get arguments of function, if not externally defined funcArgs :: FuncDecl -> [Int] funcArgs = ruleArgs . funcRule --- get body of function, if not externally defined funcBody :: FuncDecl -> Expr funcBody = ruleBody . funcRule funcRHS :: FuncDecl -> [Expr] funcRHS f | not (isExternal f) = orCase (funcBody f) | otherwise = [] where orCase e | isOr e = concatMap orCase (orExps e) | isCase e = concatMap orCase (map branchExpr (caseBranches e)) | otherwise = [e] --- rename all variables in function rnmAllVarsInFunc :: Update FuncDecl VarIndex rnmAllVarsInFunc = updFunc id id id id . rnmAllVarsInRule --- update all qualified names in function updQNamesInFunc :: Update FuncDecl QName updQNamesInFunc f = updFunc f id id (updQNamesInTypeExpr f) (updQNamesInRule f) --- update arguments of function, if not externally defined updFuncArgs :: Update FuncDecl [VarIndex] updFuncArgs = updFuncRule . updRuleArgs --- update body of function, if not externally defined updFuncBody :: Update FuncDecl Expr updFuncBody = updFuncRule . updRuleBody -- Rule ---------------------------------------------------------------------- --- transform rule trRule :: ([Int] -> Expr -> a) -> (String -> a) -> Rule -> a trRule rule _ (Rule args exp) = rule args exp trRule _ ext (External s) = ext s -- Selectors --- get rules arguments if it's not external ruleArgs :: Rule -> [Int] ruleArgs = trRule (\args _ -> args) failed --- get rules body if it's not external ruleBody :: Rule -> Expr ruleBody = trRule (\_ exp -> exp) failed --- get rules external declaration ruleExtDecl :: Rule -> String ruleExtDecl = trRule failed id -- Test Operations --- is rule external? isRuleExternal :: Rule -> Bool isRuleExternal = trRule (\_ _ -> False) (\_ -> True) -- Update Operations --- update rule updRule :: ([Int] -> [Int]) -> (Expr -> Expr) -> (String -> String) -> Rule -> Rule updRule fa fe fs = trRule rule ext where rule args exp = Rule (fa args) (fe exp) ext s = External (fs s) --- update rules arguments updRuleArgs :: Update Rule [VarIndex] updRuleArgs f = updRule f id id --- update rules body updRuleBody :: Update Rule Expr updRuleBody f = updRule id f id --- update rules external declaration updRuleExtDecl :: Update Rule String updRuleExtDecl f = updRule id id f -- Auxiliary Functions --- get variable names in a functions rule allVarsInRule :: Rule -> [Int] allVarsInRule = trRule (\args body -> args ++ allVars body) (\_ -> []) --- rename all variables in rule rnmAllVarsInRule :: Update Rule VarIndex rnmAllVarsInRule f = updRule (map f) (rnmAllVars f) id --- update all qualified names in rule updQNamesInRule :: Update Rule QName updQNamesInRule = updRuleBody . updQNames -- CombType ------------------------------------------------------------------ --- transform combination type trCombType :: a -> (Int -> a) -> a -> (Int -> a) -> CombType -> a trCombType fc _ _ _ FuncCall = fc trCombType _ fpc _ _ (FuncPartCall n) = fpc n trCombType _ _ cc _ ConsCall = cc trCombType _ _ _ cpc (ConsPartCall n) = cpc n -- Test Operations --- is type of combination FuncCall? isCombTypeFuncCall :: CombType -> Bool isCombTypeFuncCall = trCombType True (\_ -> False) False (\_ -> False) --- is type of combination FuncPartCall? isCombTypeFuncPartCall :: CombType -> Bool isCombTypeFuncPartCall = trCombType False (\_ -> True) False (\_ -> False) --- is type of combination ConsCall? isCombTypeConsCall :: CombType -> Bool isCombTypeConsCall = trCombType False (\_ -> False) True (\_ -> False) --- is type of combination ConsPartCall? isCombTypeConsPartCall :: CombType -> Bool isCombTypeConsPartCall = trCombType False (\_ -> False) False (\_ -> True) -- Auxiliary Functions missingArgs :: CombType -> Int missingArgs = trCombType 0 id 0 id -- Expr ---------------------------------------------------------------------- -- Selectors --- get internal number of variable varNr :: Expr -> Int varNr expr = case expr of (Var n) -> n _ -> error "FlatCurryGoodies.varNr: no variable" --- get literal if expression is literal expression literal :: Expr -> Literal literal expr = case expr of (Lit l) -> l _ -> error "FlatCurryGoodies.literal: no literal" --- get combination type of a combined expression combType :: Expr -> CombType combType expr = case expr of (Comb ct _ _) -> ct _ -> error "FlatCurryGoodies.combType: no combined expression" --- get name of a combined expression combName :: Expr -> QName combName expr = case expr of (Comb _ name _) -> name _ -> error "FlatCurryGoodies.combName: no combined expression" --- get arguments of a combined expression combArgs :: Expr -> [Expr] combArgs expr = case expr of (Comb _ _ args) -> args _ -> error "FlatCurryGoodies.combArgs: no combined expression" --- get number of missing arguments if expression is combined missingCombArgs :: Expr -> Int missingCombArgs = missingArgs . combType --- get indices of variables in let declaration letBinds :: Expr -> [(Int,Expr)] letBinds expr = case expr of (Let vs _) -> vs _ -> error "FlatCurryGoodies.letBinds: no let declaration" --- get body of let declaration letBody :: Expr -> Expr letBody expr = case expr of (Let _ e) -> e _ -> error "FlatCurryGoodies.letBody: no let declaration" --- get variable indices from declaration of free variables freeVars :: Expr -> [Int] freeVars expr = case expr of (Free vs _) -> vs _ -> error "FlatCurryGoodies.freeVars: no free variable declaration" --- get expression from declaration of free variables freeExpr :: Expr -> Expr freeExpr expr = case expr of (Free _ e) -> e _ -> error "FlatCurryGoodies.freeExpr: no free variable declaration" --- get expressions from or-expression orExps :: Expr -> [Expr] orExps expr = case expr of (Or e1 e2) -> [e1,e2] _ -> error "FlatCurryGoodies.orExps: no or-expression" --- get case-type of case expression caseType :: Expr -> CaseType caseType expr = case expr of (Case ct _ _) -> ct _ -> error "FlatCurryGoodies.caseType: no case expression" --- get scrutinee of case expression caseExpr :: Expr -> Expr caseExpr expr = case expr of (Case _ e _) -> e _ -> error "FlatCurryGoodies.caseExpr: no case expression" --- get branch expressions from case expression caseBranches :: Expr -> [BranchExpr] caseBranches expr = case expr of (Case _ _ bs) -> bs _ -> error "FlatCurryGoodies.caseBranches: no case expression" -- Test Operations --- is expression a variable? isVar :: Expr -> Bool isVar e = case e of Var _ -> True _ -> False --- is expression a literal expression? isLit :: Expr -> Bool isLit e = case e of Lit _ -> True _ -> False --- is expression combined? isComb :: Expr -> Bool isComb e = case e of Comb _ _ _ -> True _ -> False --- is expression a let expression? isLet :: Expr -> Bool isLet e = case e of Let _ _ -> True _ -> False --- is expression a declaration of free variables? isFree :: Expr -> Bool isFree e = case e of Free _ _ -> True _ -> False --- is expression an or-expression? isOr :: Expr -> Bool isOr e = case e of Or _ _ -> True _ -> False --- is expression a case expression? isCase :: Expr -> Bool isCase e = case e of Case _ _ _ -> True _ -> False --- transform expression trExpr :: (Int -> a) -> (Literal -> a) -> (CombType -> QName -> [a] -> a) -> ([(Int,a)] -> a -> a) -> ([Int] -> a -> a) -> (a -> a -> a) -> (CaseType -> a -> [b] -> a) -> (Pattern -> a -> b) -> (a -> TypeExpr -> a) -> Expr -> a trExpr var _ _ _ _ _ _ _ _ (Var n) = var n trExpr _ lit _ _ _ _ _ _ _ (Lit l) = lit l trExpr var lit comb lt fr or cas branch typed (Comb ct name args) = comb ct name (map (trExpr var lit comb lt fr or cas branch typed) args) trExpr var lit comb lt fr or cas branch typed (Let bs e) = lt (map (\ (n,exp) -> (n,f exp)) bs) (f e) where f = trExpr var lit comb lt fr or cas branch typed trExpr var lit comb lt fr or cas branch typed (Free vs e) = fr vs (trExpr var lit comb lt fr or cas branch typed e) trExpr var lit comb lt fr or cas branch typed (Or e1 e2) = or (f e1) (f e2) where f = trExpr var lit comb lt fr or cas branch typed trExpr var lit comb lt fr or cas branch typed (Case ct e bs) = cas ct (f e) (map (\ (Branch pat exp) -> branch pat (f exp)) bs) where f = trExpr var lit comb lt fr or cas branch typed trExpr var lit comb lt fr or cas branch typed (Typed e ty) = typed (trExpr var lit comb lt fr or cas branch typed e) ty -- Update Operations --- update all variables in given expression updVars :: (Int -> Expr) -> Expr -> Expr updVars var = trExpr var Lit Comb Let Free Or Case Branch Typed --- update all literals in given expression updLiterals :: (Literal -> Expr) -> Expr -> Expr updLiterals lit = trExpr Var lit Comb Let Free Or Case Branch Typed --- update all combined expressions in given expression updCombs :: (CombType -> QName -> [Expr] -> Expr) -> Expr -> Expr updCombs comb = trExpr Var Lit comb Let Free Or Case Branch Typed --- update all let expressions in given expression updLets :: ([(Int,Expr)] -> Expr -> Expr) -> Expr -> Expr updLets lt = trExpr Var Lit Comb lt Free Or Case Branch Typed --- update all free declarations in given expression updFrees :: ([Int] -> Expr -> Expr) -> Expr -> Expr updFrees fr = trExpr Var Lit Comb Let fr Or Case Branch Typed --- update all or expressions in given expression updOrs :: (Expr -> Expr -> Expr) -> Expr -> Expr updOrs or = trExpr Var Lit Comb Let Free or Case Branch Typed --- update all case expressions in given expression updCases :: (CaseType -> Expr -> [BranchExpr] -> Expr) -> Expr -> Expr updCases cas = trExpr Var Lit Comb Let Free Or cas Branch Typed --- update all case branches in given expression updBranches :: (Pattern -> Expr -> BranchExpr) -> Expr -> Expr updBranches branch = trExpr Var Lit Comb Let Free Or Case branch Typed --- update all typed expressions in given expression updTypeds :: (Expr -> TypeExpr -> Expr) -> Expr -> Expr updTypeds typed = trExpr Var Lit Comb Let Free Or Case Branch typed -- Auxiliary Functions --- is expression a call of a function where all arguments are provided? isFuncCall :: Expr -> Bool isFuncCall e = isComb e && isCombTypeFuncCall (combType e) --- is expression a partial function call? isFuncPartCall :: Expr -> Bool isFuncPartCall e = isComb e && isCombTypeFuncPartCall (combType e) --- is expression a call of a constructor? isConsCall :: Expr -> Bool isConsCall e = isComb e && isCombTypeConsCall (combType e) --- is expression a partial constructor call? isConsPartCall :: Expr -> Bool isConsPartCall e = isComb e && isCombTypeConsPartCall (combType e) --- is expression fully evaluated? isGround :: Expr -> Bool isGround exp = case exp of Comb ConsCall _ args -> all isGround args _ -> isLit exp --- get all variables (also pattern variables) in expression allVars :: Expr -> [Int] allVars e = trExpr (:) (const id) comb lt fr (.) cas branch const e [] where comb _ _ = foldr (.) id lt bs exp = exp . foldr (.) id (map (\ (n,ns) -> (n:) . ns) bs) fr vs exp = (vs++) . exp cas _ exp bs = exp . foldr (.) id bs branch pat exp = ((args pat)++) . exp args pat | isConsPattern pat = patArgs pat | otherwise = [] --- rename all variables (also in patterns) in expression rnmAllVars :: Update Expr Int rnmAllVars f = trExpr (Var . f) Lit Comb lt (Free . map f) Or Case branch Typed where lt = Let . map (\ (n,exp) -> (f n,exp)) branch = Branch . updPatArgs (map f) --- update all qualified names in expression updQNames :: Update Expr QName updQNames f = trExpr Var Lit comb Let Free Or Case (Branch . updPatCons f) typed where comb ct name args = Comb ct (f name) args typed e ty = Typed e (updQNamesInTypeExpr f ty) -- BranchExpr ---------------------------------------------------------------- --- transform branch expression trBranch :: (Pattern -> Expr -> a) -> BranchExpr -> a trBranch branch (Branch pat exp) = branch pat exp -- Selectors --- get pattern from branch expression branchPattern :: BranchExpr -> Pattern branchPattern = trBranch (\pat _ -> pat) --- get expression from branch expression branchExpr :: BranchExpr -> Expr branchExpr = trBranch (\_ e -> e) -- Update Operations --- update branch expression updBranch :: (Pattern -> Pattern) -> (Expr -> Expr) -> BranchExpr -> BranchExpr updBranch fp fe = trBranch branch where branch pat exp = Branch (fp pat) (fe exp) --- update pattern of branch expression updBranchPattern :: Update BranchExpr Pattern updBranchPattern f = updBranch f id --- update expression of branch expression updBranchExpr :: Update BranchExpr Expr updBranchExpr = updBranch id -- Pattern ------------------------------------------------------------------- --- transform pattern trPattern :: (QName -> [Int] -> a) -> (Literal -> a) -> Pattern -> a trPattern pattern _ (Pattern name args) = pattern name args trPattern _ lpattern (LPattern l) = lpattern l -- Selectors --- get name from constructor pattern patCons :: Pattern -> QName patCons = trPattern (\name _ -> name) failed --- get arguments from constructor pattern patArgs :: Pattern -> [Int] patArgs = trPattern (\_ args -> args) failed --- get literal from literal pattern patLiteral :: Pattern -> Literal patLiteral = trPattern failed id -- Test Operations --- is pattern a constructor pattern? isConsPattern :: Pattern -> Bool isConsPattern = trPattern (\_ _ -> True) (\_ -> False) -- Update Operations --- update pattern updPattern :: (QName -> QName) -> ([Int] -> [Int]) -> (Literal -> Literal) -> Pattern -> Pattern updPattern fn fa fl = trPattern pattern lpattern where pattern name args = Pattern (fn name) (fa args) lpattern l = LPattern (fl l) --- update constructors name of pattern updPatCons :: (QName -> QName) -> Pattern -> Pattern updPatCons f = updPattern f id id --- update arguments of constructor pattern updPatArgs :: ([Int] -> [Int]) -> Pattern -> Pattern updPatArgs f = updPattern id f id --- update literal of pattern updPatLiteral :: (Literal -> Literal) -> Pattern -> Pattern updPatLiteral f = updPattern id id f -- Auxiliary Functions --- build expression from pattern patExpr :: Pattern -> Expr patExpr = trPattern (\ name -> Comb ConsCall name . map Var) Lit curry-tools-v3.3.0/cpm/vendor/flatcurry/src/FlatCurry/Pretty.curry000066400000000000000000000307501377556325500254020ustar00rootroot00000000000000--- -------------------------------------------------------------------------- --- This library provides pretty-printers for FlatCurry modules --- and all substructures (e.g., expressions). --- --- @author Bjoern Peemoeller --- @version November 2020 --- -------------------------------------------------------------------------- module FlatCurry.Pretty where import Prelude hiding (empty) import Text.Pretty import FlatCurry.Types --- Options for pretty printing --- @field indentWidth - number of columns for indentation of substructures --- @field qualMode - Qualification mode of pretty printer --- @field currentModule - Name of current module to be pretty-printed, used --- for proper qualification data Options = Options { indentWidth :: Int , qualMode :: QualMode , currentModule :: String } --- Qualification mode, determines whether identifiers are printed qualified --- or unqualified. While `QualNone` and `QualImports` aim at readability, --- there may be ambiguities due to shadowing. On the contrary, `QualImports` --- and `QualAll` produce correct output at the cost of readability. --- --- @cons QualNone - no qualification, only unqualified names --- @cons QualImportsButPrelude - qualify all imports except those from --- the module `Prelude` --- @cons QualImports - qualify all imports, including `Prelude` --- @cons QualAll - qualify all names data QualMode = QualNone | QualImportsButPrelude | QualImports | QualAll -- deriving Eq instance Eq QualMode where QualNone == x = case x of { QualNone -> True ; _ -> False } QualImportsButPrelude == x = case x of { QualImportsButPrelude -> True ; _ -> False } QualImports == x = case x of { QualImports -> True ; _ -> False } QualAll == x = case x of { QualAll -> True ; _ -> False } --- Default `Options` for pretty-printing. defaultOptions :: Options defaultOptions = Options { indentWidth = 2 , qualMode = QualImportsButPrelude , currentModule = "" } -- --------------------------------------------------------------------------- -- Pretty printing of Flat modules -- --------------------------------------------------------------------------- --- pretty-print a FlatCurry module ppProg :: Options -> Prog -> Doc ppProg o (Prog m is ts fs os) = vsepBlank [ ppHeader o' m ts fs , ppImports o' is , ppOpDecls o' os , ppTypeDecls o' ts , ppFuncDecls o' fs ] where o' = o { currentModule = m } --- pretty-print the module header ppHeader :: Options -> String -> [TypeDecl] -> [FuncDecl] -> Doc ppHeader o m ts fs = indent o $ sep [text "module" <+> text m, ppExports o ts fs, text "where"] --- pretty-print the export list ppExports :: Options -> [TypeDecl] -> [FuncDecl] -> Doc ppExports o ts fs = tupledSpaced (map (ppTypeExport o) ts ++ ppFuncExports o fs) --- pretty-print a type export ppTypeExport :: Options -> TypeDecl -> Doc ppTypeExport o (Type qn vis _ cs) | vis == Private = empty | null cs = ppPrefixQOp o qn | all isPublicCons cs = ppPrefixQOp o qn <+> text "(..)" | otherwise = ppPrefixQOp o qn <+> tupled (ppConsExports o cs) where isPublicCons (Cons _ _ v _) = v == Public ppTypeExport o (TypeSyn qn vis _ _ ) | vis == Private = empty | otherwise = ppPrefixQOp o qn ppTypeExport o (TypeNew qn vis _ (NewCons _ vis' _)) | vis == Private || vis' == Private = empty | otherwise = ppPrefixQOp o qn <+> text "(..)" --- pretty-print the export list of constructors ppConsExports :: Options -> [ConsDecl] -> [Doc] ppConsExports o cs = [ ppPrefixQOp o qn | Cons qn _ Public _ <- cs] --- pretty-print the export list of functions ppFuncExports :: Options -> [FuncDecl] -> [Doc] ppFuncExports o fs = [ ppPrefixQOp o qn | Func qn _ Public _ _ <- fs] --- pretty-print a list of import statements ppImports :: Options -> [String] -> Doc ppImports o = vsep . map (ppImport o) --- pretty-print a single import statement ppImport :: Options -> String -> Doc ppImport o m = indent o $ text "import" <+> text m --- pretty-print a list of operator fixity declarations ppOpDecls :: Options -> [OpDecl] -> Doc ppOpDecls o = vsep . map (ppOpDecl o) --- pretty-print a single operator fixity declaration ppOpDecl :: Options -> OpDecl -> Doc ppOpDecl o (Op qn fix n) = indent o $ ppFixity fix <+> int n <+> ppInfixQOp o qn --- pretty-print the associativity keyword ppFixity :: Fixity -> Doc ppFixity InfixOp = text "infix" ppFixity InfixlOp = text "infixl" ppFixity InfixrOp = text "infixr" --- pretty-print a list of type declarations ppTypeDecls :: Options -> [TypeDecl] -> Doc ppTypeDecls o = vsepBlank . map (ppTypeDecl o) --- pretty-print a type declaration ppTypeDecl :: Options -> TypeDecl -> Doc ppTypeDecl o (Type qn _ vs cs) = indent o $ (text "data" <+> ppName qn <+> hsep (empty : map (ppTVarIndex . fst) vs)) $$ ppConsDecls o cs ppTypeDecl o (TypeSyn qn _ vs ty) = indent o $ text "type" <+> ppName qn <+> hsep (empty : map (ppTVarIndex . fst) vs) equals <+> ppTypeExp o ty ppTypeDecl o (TypeNew qn _ vs c) = indent o $ text "newtype" <+> ppName qn <+> hsep (empty : map (ppTVarIndex . fst) vs) $$ ppNewConsDecl o c --- pretty-print the constructor declarations ppConsDecls :: Options -> [ConsDecl] -> Doc ppConsDecls o cs = vsep $ zipWith (<+>) (equals : repeat bar) (map (ppConsDecl o) cs) --- pretty print a single constructor ppConsDecl :: Options -> ConsDecl -> Doc ppConsDecl o (Cons qn _ _ tys) = hsep $ ppPrefixOp qn : map (ppTypeExpr o 2) tys --- pretty print a single newtype constructor ppNewConsDecl :: Options -> NewConsDecl -> Doc ppNewConsDecl o (NewCons qn _ ty) = hsep [ppPrefixOp qn, ppTypeExpr o 2 ty] --- pretty a top-level type expression ppTypeExp :: Options -> TypeExpr -> Doc ppTypeExp o = ppTypeExpr o 0 --- pretty-print a type expression ppTypeExpr :: Options -> Int -> TypeExpr -> Doc ppTypeExpr _ _ (TVar v) = ppTVarIndex v ppTypeExpr o p (FuncType ty1 ty2) = parensIf (p > 0) $ ppTypeExpr o 1 ty1 rarrow <+> ppTypeExp o ty2 ppTypeExpr o p (TCons qn tys) | isListId qn && length tys == 1 = brackets (ppTypeExp o (head tys)) | isTupleId qn = tupled (map (ppTypeExp o) tys) | otherwise = parensIf (p > 1 && not (null tys)) $ sep (ppPrefixQOp o qn : map (ppTypeExpr o 2) tys) ppTypeExpr o p (ForallType vs ty) | null vs = ppTypeExpr o p ty | otherwise = parensIf (p > 0) $ ppQuantifiedVars vs <+> ppTypeExpr o 0 ty --- pretty-print explicitly quantified type variables ppQuantifiedVars :: [(TVarIndex, Kind)] -> Doc ppQuantifiedVars vs | null vs = empty | otherwise = text "forall" <+> hsep (map (ppTVarIndex . fst) vs) <+> char '.' --- pretty-print a type variable ppTVarIndex :: TVarIndex -> Doc ppTVarIndex i = text $ vars !! i where vars = [ chr c : if n == 0 then [] else show n | n <- [0 ..], c <- [ord 'a' .. ord 'z'] ] --- pretty-print a list of function declarations ppFuncDecls :: Options -> [FuncDecl] -> Doc ppFuncDecls o = vsepBlank . map (ppFuncDecl o) --- pretty-print a function declaration ppFuncDecl :: Options -> FuncDecl -> Doc ppFuncDecl o (Func qn _ _ ty r) = indent o (sep [ppPrefixOp qn, text "::", ppTypeExp o ty]) $$ indent o (ppPrefixOp qn <+> ppRule o r) --- pretty-print a function rule ppRule :: Options -> Rule -> Doc ppRule o (Rule vs e) | null vs = equals <+> ppExp o e | otherwise = hsep (map ppVarIndex vs) equals <+> ppExp o e ppRule _ (External e) = text "external" <+> dquotes (text e) --- Pretty-print a top-level expression. ppExp :: Options -> Expr -> Doc ppExp o = ppExpr o 0 --- pretty-print an expression ppExpr :: Options -> Int -> Expr -> Doc ppExpr _ _ (Var v) = ppVarIndex v ppExpr _ _ (Lit l) = ppLiteral l ppExpr o p (Comb _ qn es) = ppComb o p qn es ppExpr o p (Free vs e) | null vs = ppExpr o p e | otherwise = parensIf (p > 0) $ sep [ text "let" <+> sep (punctuate comma (map ppVarIndex vs)) <+> text "free" , text "in" ppExp o e ] ppExpr o p (Let ds e) = parensIf (p > 0) $ sep [ text "let" <+> ppDecls o ds , text "in" <+> ppExp o e ] ppExpr o p (Or e1 e2) = parensIf (p > 0) $ ppExpr o 1 e1 <+> text "?" <+> ppExpr o 1 e2 ppExpr o p (Case ct e bs) = parensIf (p > 0) $ indent o $ ppCaseType ct <+> ppExpr o 1 e <+> text "of" $$ vsep (map (ppBranch o) bs) ppExpr o p (Typed e ty) = parensIf (p > 0) $ ppExp o e <+> text "::" <+> ppTypeExp o ty --- pretty-print a variable ppVarIndex :: VarIndex -> Doc ppVarIndex i | i < 0 = text $ 'x' : show (negate i) | otherwise = text $ 'v' : show i --- pretty-print a literal ppLiteral :: Literal -> Doc ppLiteral (Intc i) = int i ppLiteral (Floatc f) = float f ppLiteral (Charc c) = text (show c) --- Pretty print a constructor or function call ppComb :: Options -> Int -> QName -> [Expr] -> Doc ppComb o p qn es | isListId qn && null es = text "[]" | isTupleId qn = tupled (map (ppExp o) es) | otherwise = case es of [] -> ppPrefixQOp o qn [e1,e2] | isInfixOp qn -> parensIf (p > 0) $ fillSep [ppExpr o 1 e1, ppInfixQOp o qn, ppExpr o 1 e2] _ -> parensIf (p > 0) $ fillSep (ppPrefixQOp o qn : map (ppExpr o 1) es) --- pretty-print a list of declarations ppDecls :: Options -> [(VarIndex, Expr)] -> Doc ppDecls o = align . vsep . map (ppDecl o) --- pretty-print a single declaration ppDecl :: Options -> (VarIndex, Expr) -> Doc ppDecl o (v, e) = ppVarIndex v <+> equals <+> ppExp o e --- Pretty print the type of a case expression ppCaseType :: CaseType -> Doc ppCaseType Rigid = text "case" ppCaseType Flex = text "fcase" --- Pretty print a case branch ppBranch :: Options -> BranchExpr -> Doc ppBranch o (Branch p e) = ppPattern o p <+> rarrow <+> indent o (ppExp o e) --- Pretty print a pattern ppPattern :: Options -> Pattern -> Doc ppPattern o (Pattern c vs) | isListId c && null vs = text "[]" | isTupleId c = tupled (map ppVarIndex vs) | otherwise = case vs of [v1,v2] | isInfixOp c -> ppVarIndex v1 <+> ppInfixQOp o c <+> ppVarIndex v2 _ -> hsep (ppPrefixQOp o c : map ppVarIndex vs) ppPattern _ (LPattern l) = ppLiteral l -- --------------------------------------------------------------------------- -- Names -- --------------------------------------------------------------------------- --- pretty-print a qualified prefix operator. ppPrefixQOp :: Options -> QName -> Doc ppPrefixQOp o qn = parensIf (isInfixOp qn) (ppQName o qn) --- pretty-print a prefix operator unqualified. ppPrefixOp :: QName -> Doc ppPrefixOp qn = parensIf (isInfixOp qn) (ppName qn) --- pretty-print an infix operator ppInfixQOp :: Options -> QName -> Doc ppInfixQOp o qn = if isInfixOp qn then ppQName o qn else bquotes (ppQName o qn) --- Pretty-print a qualified name ppQName :: Options -> QName -> Doc ppQName o qn@(m, i) | null m = text i | isConsId qn || isListId qn || isTupleId qn = text i | q == QualNone = text i | q == QualImportsButPrelude && (m == m' || m == "Prelude") = text i | q == QualImports && m == m' = text i | otherwise = text $ m ++ '.' : i where q = qualMode o m' = currentModule o --- Pretty-print a qualified name unqualified (e.g., for type definitions). ppName :: QName -> Doc ppName (_, i) = text i --- Check whether an operator is an infix operator isInfixOp :: QName -> Bool isInfixOp = all (`elem` "~!@#$%^&*+-=<>:?./|\\") . snd --- Check whether an identifier represents the `:` list constructor. isConsId :: QName -> Bool isConsId (m, i) = m `elem` ["Prelude", ""] && i == ":" --- Check whether an identifier represents a list isListId :: QName -> Bool isListId (m, i) = m `elem` ["Prelude", ""] && i == "[]" --- Check whether an identifier represents a tuple isTupleId :: QName -> Bool isTupleId (m, i) = m `elem` ["Prelude", ""] && i == mkTuple (length i) where mkTuple n = '(' : replicate (n - 2) ',' ++ ")" --- Indentation indent :: Options -> Doc -> Doc indent o d = nest (indentWidth o) d curry-tools-v3.3.0/cpm/vendor/flatcurry/src/FlatCurry/Read.curry000066400000000000000000000164121377556325500247650ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library defines operations to read FlatCurry programs or interfaces --- together with all its imported modules in the current load path. --- --- @author Michael Hanus, Bjoern Peemoeller, Finn Teegen --- @version November 2020 ------------------------------------------------------------------------------ module FlatCurry.Read ( readFlatCurryInPath , readFlatCurryWithImports , readFlatCurryWithImportsInPath , readFlatCurryIntWithImports , readFlatCurryIntWithImportsInPath ) where import Control.Monad ( when ) import System.Directory ( getModificationTime, getFileWithSuffix , findFileWithSuffix ) import System.FilePath ( dropExtension, normalise, takeFileName ) import System.CurryPath ( getLoadPathForModule, lookupModuleSource ) import System.FrontendExec ( FrontendTarget (FCY), callFrontendWithParams , defaultParams, setQuiet, setFullPath ) import FlatCurry.Types import FlatCurry.Files --- Reads a FlatCurry program together in a given load path. --- The arguments are a load path and the name of the module. readFlatCurryInPath :: [String] -> String -> IO Prog readFlatCurryInPath loadpath modname = do [prog] <- readFlatCurryFileInPath False False loadpath modname [".fcy"] return prog --- Reads a FlatCurry program together with all its imported modules. --- The argument is the name of the main module, --- possibly with a directory prefix. readFlatCurryWithImports :: String -> IO [Prog] readFlatCurryWithImports modname = do loadpath <- getLoadPathForModule modname readFlatCurryFileInPath True False loadpath (takeFileName modname) [".fcy"] --- Reads a FlatCurry program together with all its imported modules --- in a given load path. --- The arguments are a load path and the name of the main module. readFlatCurryWithImportsInPath :: [String] -> String -> IO [Prog] readFlatCurryWithImportsInPath loadpath modname = readFlatCurryFileInPath True False loadpath modname [".fcy"] --- Reads a FlatCurry interface together with all its imported module --- interfaces. --- The argument is the name of the main module, --- possibly with a directory prefix. --- If there is no interface file but a FlatCurry file (suffix ".fcy"), --- the FlatCurry file is read instead of the interface. readFlatCurryIntWithImports :: String -> IO [Prog] readFlatCurryIntWithImports modname = do loadpath <- getLoadPathForModule modname readFlatCurryFileInPath True False loadpath (takeFileName modname) [".fint",".fcy"] --- Reads a FlatCurry interface together with all its imported module --- interfaces in a given load path. --- The arguments are a load path and the name of the main module. --- If there is no interface file but a FlatCurry file (suffix ".fcy"), --- the FlatCurry file is read instead of the interface. readFlatCurryIntWithImportsInPath :: [String] -> String -> IO [Prog] readFlatCurryIntWithImportsInPath loadpath modname = readFlatCurryFileInPath True False loadpath modname [".fint",".fcy"] -- Read a FlatCurry file (together with its imported modules if the first -- argument is true). -- The further arguments are the verbosity mode, the loadpath, -- the name of the main module, and the possible suffixes -- of the FlatCurry file (e.g., [".fint",".fcy"]). readFlatCurryFileInPath :: Bool -> Bool -> [String] -> String -> [String] -> IO [Prog] readFlatCurryFileInPath withImp verb loadpath mod sfxs = do when verb $ putStr "Reading FlatCurry files " -- try to read the interface files directly eiMods <- tryReadFlatCurryFile withImp verb loadpath mod sfxs either (\_ -> parseFlatCurryFile withImp verb loadpath mod sfxs) return eiMods -- Parse a FlatCurry file together with its imported modules. -- The argument is the loadpath, the name of the main module, and the -- possible suffixes of the FlatCurry file (e.g., [".fint",".fcy"]). parseFlatCurryFile :: Bool -> Bool -> [String] -> String -> [String] -> IO [Prog] parseFlatCurryFile withImp verb loadpath modname suffixes = do when verb $ putStrLn $ ">>>>> FlatCurry files not up-to-date, parsing module \"" ++ modname ++ "\"..." callFrontendWithParams FCY (setQuiet True (setFullPath loadpath defaultParams)) modname when verb $ putStr "Reading FlatCurry files " eiMods <- tryReadFlatCurryFile withImp verb loadpath modname suffixes return (either (error . notFound) id eiMods) where notFound mods = "FlatCurry file not found for the following module(s): " ++ unwords mods -- Read a FlatCurry file (with all its imports if first argument is true). -- If all files could be read, -- then `Right progs` is returned, otherwise `Left mods` where `mods` is -- the list of modules that could *not* be read. tryReadFlatCurryFile :: Bool -> Bool -> [String] -> String -> [String] -> IO (Either [String] [Prog]) tryReadFlatCurryFile withImp verb loadpath modname suffixes = if withImp then tryReadFlatCurryFileWithImports verb loadpath modname suffixes else do mProg <- tryReadFlatCurry verb loadpath modname suffixes return $ maybe (Left [modname]) (Right . (:[])) mProg -- Read a FlatCurry file with all its imports. If all files could be read, -- then `Right progs` is returned, otherwise `Left mods` where `mods` is -- the list of modules that could *not* be read. tryReadFlatCurryFileWithImports :: Bool -> [String] -> String -> [String] -> IO (Either [String] [Prog]) tryReadFlatCurryFileWithImports verb loadpath modname suffixes = collect [modname] [] where -- Collects all imported modules collect [] _ = when verb (putStrLn "done") >> return (Right []) collect (mod:mods) implist | mod `elem` implist = collect mods implist | otherwise = do mbProg <- tryReadFlatCurry verb loadpath mod suffixes case mbProg of Nothing -> return (Left [mod]) Just prog@(Prog _ is _ _ _) -> do mbresults <- collect (mods ++ is) (mod:implist) return (either Left (Right . (prog :)) mbresults) -- Read a single FlatCurry file for a module if it exists and is up-to-date -- w.r.t. the source program. If no source exists, it is always assumed -- to be up-to-date. If the source is newer then the FlatCurry file or -- there is no FlatCurry file, the function returns `Nothing`. tryReadFlatCurry :: Bool -> [String] -> String -> [String] -> IO (Maybe Prog) tryReadFlatCurry verb loadpath modname suffixes = do mbSrc <- lookupModuleSource loadpath modname case mbSrc of Nothing -> findFileWithSuffix flattakeBaseName suffixes loadpath >>= maybe (return Nothing) (fmap Just . readFlatCurryFile) Just (_,src) -> do mbFcy <- findFileWithSuffix flattakeBaseName suffixes loadpath case mbFcy of Nothing -> return Nothing Just fcy -> do ctime <- getModificationTime src ftime <- getModificationTime fcy if ctime > ftime then return Nothing else do when verb $ putStr (normalise fcy ++ " ") fmap Just (readFlatCurryFile fcy) where flattakeBaseName = dropExtension (flatCurryFileName modname) curry-tools-v3.3.0/cpm/vendor/flatcurry/src/FlatCurry/Show.curry000066400000000000000000000372011377556325500250310ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library contains operations to transform FlatCurry programs --- into string representations, either in a FlatCurry format or --- in a Curry-like syntax. --- --- This library contains --- --- * show functions for a string representation of FlatCurry programs --- (`showFlatProg`, `showFlatType`, `showFlatFunc`) --- * functions for showing FlatCurry (type) expressions in (almost) --- Curry syntax (`showCurryType`, `showCurryExpr`,...). --- --- @author Michael Hanus --- @version December 2020 ------------------------------------------------------------------------------ module FlatCurry.Show (showFlatProg, showFlatType, showFlatFunc , showCurryType, isClassContext , showCurryExpr, showCurryId, showCurryVar ) where import FlatCurry.Types import Data.List import Data.Char --- Shows a FlatCurry program term as a string (with some pretty printing). showFlatProg :: Prog -> String showFlatProg (Prog modname imports types funcs ops) = " (Prog " ++ show modname ++ (if null imports then "\n []" else "\n [" ++ showFlatListElems show imports ++ "]") ++ (if null types then "\n []" else "\n [" ++ showFlatListElems showFlatType types ++ "\n ]") ++ "\n [" ++ showFlatListElems showFlatFunc funcs ++ "\n ]" ++ "\n " ++ showFlatList showFlatOp ops ++ "\n )\n" showFlatVisibility :: Visibility -> String showFlatVisibility Public = " Public " showFlatVisibility Private = " Private " showFlatFixity :: Fixity -> String showFlatFixity InfixOp = " InfixOp " showFlatFixity InfixlOp = " InfixlOp " showFlatFixity InfixrOp = " InfixrOp " showFlatOp :: OpDecl -> String showFlatOp (Op name fix prec) = "(Op " ++ show name ++ showFlatFixity fix ++ show prec ++ ")" showFlatType :: TypeDecl -> String showFlatType (Type name vis tpars consdecls) = "\n (Type " ++ show name ++ showFlatVisibility vis ++ showFlatList show tpars ++ showFlatList showFlatCons consdecls ++ ")" showFlatType (TypeSyn name vis tpars texp) = "\n (TypeSyn " ++ show name ++ showFlatVisibility vis ++ showFlatList show tpars ++ showFlatTypeExpr texp ++ ")" showFlatType (TypeNew name vis tpars consdecl) = "\n (TypeNew " ++ show name ++ showFlatVisibility vis ++ showFlatList show tpars ++ showFlatNewCons consdecl ++ ")" showFlatCons :: ConsDecl -> String showFlatCons (Cons cname arity vis types) = "(Cons " ++ show cname ++ " " ++ show arity ++ showFlatVisibility vis ++ showFlatList showFlatTypeExpr types ++ ")" showFlatNewCons :: NewConsDecl -> String showFlatNewCons (NewCons cname vis texp) = "(NewCons " ++ show cname ++ showFlatVisibility vis ++ showFlatTypeExpr texp ++ ")" showFlatFunc :: FuncDecl -> String showFlatFunc (Func name arity vis ftype rl) = "\n (Func " ++ show name ++ " " ++ show arity ++ " " ++ showFlatVisibility vis ++ "\n " ++ showFlatTypeExpr ftype ++ "\n " ++ showFlatRule rl ++ ")" showFlatRule :: Rule -> String showFlatRule (Rule params expr) = " (Rule " ++ showFlatList show params ++ showFlatExpr expr ++ ")" showFlatRule (External name) = " (External " ++ show name ++ ")" showFlatTypeExpr :: TypeExpr -> String showFlatTypeExpr (FuncType t1 t2) = "(FuncType " ++ showFlatTypeExpr t1 ++ " " ++ showFlatTypeExpr t2 ++ ")" showFlatTypeExpr (TCons tc ts) = "(TCons " ++ show tc ++ showFlatList showFlatTypeExpr ts ++ ")" showFlatTypeExpr (TVar n) = "(TVar " ++ show n ++ ")" showFlatTypeExpr (ForallType tvs te) = "(ForallType " ++ showFlatList show tvs ++ showFlatTypeExpr te ++ ")" showFlatCombType :: CombType -> String showFlatCombType FuncCall = "FuncCall" showFlatCombType ConsCall = "ConsCall" showFlatCombType (FuncPartCall n) = "(FuncPartCall " ++ show n ++ ")" showFlatCombType (ConsPartCall n) = "(ConsPartCall " ++ show n ++ ")" showFlatExpr :: Expr -> String showFlatExpr (Var n) = "(Var " ++ show n ++ ")" showFlatExpr (Lit l) = "(Lit " ++ showFlatLit l ++ ")" showFlatExpr (Comb ctype cf es) = "(Comb " ++ showFlatCombType ctype ++ " " ++ show cf ++ showFlatList showFlatExpr es ++ ")" showFlatExpr (Let bindings exp) = "(Let " ++ showFlatList showFlatBinding bindings ++ showFlatExpr exp ++ ")" where showFlatBinding (x,e) = "("++show x++","++showFlatExpr e++")" showFlatExpr (Free xs e) = "(Free " ++ showFlatList show xs ++ showFlatExpr e ++ ")" showFlatExpr (Or e1 e2) = "(Or " ++ showFlatExpr e1 ++ " " ++ showFlatExpr e2 ++ ")" showFlatExpr (Case Rigid e bs) = "(Case Rigid " ++ showFlatExpr e ++ showFlatList showFlatBranch bs ++ ")" showFlatExpr (Case Flex e bs) = "(Case Flex " ++ showFlatExpr e ++ showFlatList showFlatBranch bs ++ ")" showFlatExpr (Typed e ty) = "(Typed " ++ showFlatExpr e ++ ' ' : showFlatTypeExpr ty ++ ")" showFlatLit :: Literal -> String showFlatLit (Intc i) = "(Intc " ++ show i ++ ")" showFlatLit (Floatc f) = "(Floatc " ++ show f ++ ")" showFlatLit (Charc c) = "(Charc " ++ show c ++ ")" showFlatBranch :: BranchExpr -> String showFlatBranch (Branch p e) = "(Branch " ++ showFlatPattern p ++ showFlatExpr e ++ ")" showFlatPattern :: Pattern -> String showFlatPattern (Pattern qn xs) = "(Pattern " ++ show qn ++ showFlatList show xs ++ ")" showFlatPattern (LPattern lit) = "(LPattern " ++ showFlatLit lit ++ ")" -- format a finite list of elements: showFlatList :: (a->String) -> [a] -> String showFlatList format elems = " [" ++ showFlatListElems format elems ++ "] " showFlatListElems :: (a->String) -> [a] -> String showFlatListElems format elems = intercalate "," (map format elems) ------------------------------------------------------------------------------ --- Shows a FlatCurry type in Curry syntax. --- --- @param trans - a translation function from qualified type names --- to external type names --- @param nested - True iff brackets must be written around complex types --- @param texpr - the FlatCurry type expression to be formatted --- @return the String representation of the formatted type expression showCurryType :: (QName -> String) -> Bool -> TypeExpr -> String showCurryType tf nested = showTypeWithClass [] where showTypeWithClass cls texp = case texp of ForallType _ te -> showTypeWithClass cls te -- strip forall quantifiers FuncType t1 t2 -> maybe (showClassedType cls texp) (\ (cn,cv) -> showTypeWithClass (cls ++ [(cn,cv)]) t2) (isClassContext t1) _ -> showClassedType cls texp showClassedType cls texp | null cls = showCurryType_ tf nested texp | otherwise = showBracketsIf nested $ showBracketsIf (length cls > 1) (intercalate ", " (map (\ (cn,cv) -> cn ++ " " ++ showCurryType_ tf True cv) cls)) ++ " => " ++ showCurryType_ tf False texp --- Tests whether a FlatCurry type is a class context. --- If it is the case, return the class name and the type parameter --- of the context. isClassContext :: TypeExpr -> Maybe (String,TypeExpr) isClassContext texp = case texp of TCons (_,tc) [a] -> checkDictCons tc a -- a class context might be represented as function `() -> Dict`: FuncType (TCons unit []) (TCons (_,tc) [a]) | unit == ("Prelude","()") -> checkDictCons tc a _ -> Nothing where checkDictCons tc a | take 6 tc == "_Dict#" = Just (drop 6 tc, a) | otherwise = Nothing ------------------------------ showCurryType_ :: (QName -> String) -> Bool -> TypeExpr -> String showCurryType_ _ _ (TVar i) = if i<5 then [chr (97+i)] else 't':show i showCurryType_ tf nested (FuncType t1 t2) = showBracketsIf nested (showCurryType_ tf (isFuncType t1) t1 ++ " -> " ++ showCurryType_ tf False t2) showCurryType_ tf nested (TCons tc ts) | null ts = tf tc | tc==("Prelude","[]") && (head ts == TCons ("Prelude","Char") []) = "String" | tc==("Prelude","[]") = "[" ++ showCurryType_ tf False (head ts) ++ "]" -- list type | take 2 (snd tc) == "(," -- tuple type = "(" ++ intercalate "," (map (showCurryType_ tf False) ts) ++ ")" | otherwise = showBracketsIf nested (tf tc ++ concatMap (\t->' ':showCurryType_ tf True t) ts) showCurryType_ tf nested (ForallType tvs te) = showBracketsIf nested (unwords ("forall" : map (showCurryType_ tf False . TVar . fst) tvs) ++ " . " ++ showCurryType_ tf False te) isFuncType :: TypeExpr -> Bool isFuncType (TVar _) = False isFuncType (FuncType _ _) = True isFuncType (TCons _ _) = False isFuncType (ForallType _ te) = isFuncType te ------------------------------------------------------------------------------ --- Shows a FlatCurry expressions in (almost) Curry syntax. --- --- @param trans - a translation function from qualified functions names --- to external function names --- @param nested - True iff brackets must be written around complex terms --- @param indent - the indentation used in case expressions and if-then-else --- @param expr - the FlatCurry expression to be formatted --- @return the String representation of the formatted expression showCurryExpr :: (QName -> String) -> Bool -> Int -> Expr -> String showCurryExpr _ _ _ (Var n) = showCurryVar n showCurryExpr _ _ _ (Lit l) = showCurryLit l showCurryExpr tf _ _ (Comb _ cf []) = showCurryId (tf cf) showCurryExpr tf nested b (Comb _ cf [e]) = showBracketsIf nested (showCurryId (tf cf) ++ " " ++ showCurryExpr tf True b e) showCurryExpr tf nested b (Comb ct cf [e1,e2]) | cf==("Prelude","apply") = showBracketsIf nested (showCurryExpr tf True b e1 ++ " " ++ showCurryExpr tf True b e2) | isAlpha (head (snd cf)) = showBracketsIf nested (tf cf ++" "++ showCurryElems (showCurryExpr tf True b) [e1,e2]) | isFiniteList (Comb ct cf [e1,e2]) = if isStringConstant (Comb ct cf [e1,e2]) then "\"" ++ showCurryStringConstant (Comb ct cf [e1,e2]) ++ "\"" else "[" ++ intercalate "," (showCurryFiniteList tf b (Comb ct cf [e1,e2])) ++ "]" | snd cf == "(,)" -- pair constructor? = "(" ++ showCurryExpr tf False b e1 ++ "," ++ showCurryExpr tf False b e2 ++ ")" | otherwise = showBracketsIf nested (showCurryExpr tf True b e1 ++ " " ++ tf cf ++ " " ++ showCurryExpr tf True b e2 ) showCurryExpr tf nested b (Comb _ cf (e1:e2:e3:es)) | cf==("Prelude","if_then_else") && null es = showBracketsIf nested ("\n" ++ sceBlanks b ++ " if " ++ showCurryExpr tf False (b+2) e1 ++ "\n" ++ sceBlanks b ++ " then " ++ showCurryExpr tf False (b+2) e2 ++ "\n" ++ sceBlanks b ++ " else " ++ showCurryExpr tf False (b+2) e3) | take 2 (snd cf) == "(," -- tuple constructor? = "(" ++ intercalate "," (map (showCurryExpr tf False b) (e1:e2:e3:es)) ++ ")" | otherwise = showBracketsIf nested (showCurryId (tf cf) ++ " " ++ showCurryElems (showCurryExpr tf True b) (e1:e2:e3:es)) showCurryExpr tf nested b (Let bindings exp) = showBracketsIf nested ("\n" ++ sceBlanks b ++ "let " ++ intercalate ("\n " ++ sceBlanks b) (map (\ (x,e) -> showCurryVar x ++ " = " ++ showCurryExpr tf False (b+4) e) bindings) ++ ("\n" ++ sceBlanks b ++ " in ") ++ showCurryExpr tf False (b+4) exp) showCurryExpr tf nested b (Free [] e) = showCurryExpr tf nested b e showCurryExpr tf nested b (Free (x:xs) e) = showBracketsIf nested ("let " ++ intercalate "," (map showCurryVar (x:xs)) ++ " free in " ++ showCurryExpr tf False b e) showCurryExpr tf nested b (Or e1 e2) = showBracketsIf nested (showCurryExpr tf True b e1 ++ " ? " ++ showCurryExpr tf True b e2) showCurryExpr tf nested b (Case ctype e cs) = showBracketsIf nested ((case ctype of Rigid -> "case " Flex -> "fcase ") ++ showCurryExpr tf True b e ++ " of\n " ++ showCurryElems (showCurryCase tf (b+2)) cs ++ sceBlanks b) showCurryExpr tf nested b (Typed e ty) = showBracketsIf nested (showCurryExpr tf True b e ++ " :: " ++ showCurryType tf False ty) showCurryVar :: Show a => a -> String showCurryVar i = "v" ++ show i --- Shows an identifier in Curry form. Thus, operators are enclosed in brackets. showCurryId :: String -> String showCurryId name | isAlpha (head name) = name | name == "[]" = name | otherwise = ('(':name)++")" showCurryLit :: Literal -> String showCurryLit (Intc i) = show i showCurryLit (Floatc f) = show f showCurryLit (Charc c) = show c showCurryCase :: (QName -> String) -> Int -> BranchExpr -> String showCurryCase tf b (Branch (Pattern l vs) e) = sceBlanks b ++ showPattern (tf l) vs ++ " -> " ++ showCurryExpr tf False b e ++ "\n" where showPattern c [] = c showPattern c [x] = c ++ " " ++ showCurryVar x showPattern c [x1,x2] = if isAlpha (head c) then c ++ " " ++ showCurryVar x1 ++ " " ++ showCurryVar x2 else if c=="(,)" -- pair constructor? then "(" ++ showCurryVar x1 ++ "," ++ showCurryVar x2 ++ ")" else showCurryVar x1 ++ " " ++ c ++ " " ++ showCurryVar x2 showPattern c (x1:x2:x3:xs) = if take 2 c == "(," -- tuple constructor? then "(" ++ intercalate "," (map showCurryVar (x1:x2:x3:xs)) ++ ")" else c ++ " " ++ showCurryElems showCurryVar (x1:x2:x3:xs) showCurryCase tf b (Branch (LPattern l) e) = sceBlanks b ++ showCurryLit l ++ " " ++ " -> " ++ showCurryExpr tf False b e ++ "\n" showCurryFiniteList :: (QName -> String) -> Int -> Expr -> [String] showCurryFiniteList _ _ (Comb _ ("Prelude","[]") []) = [] showCurryFiniteList tf b (Comb _ ("Prelude",":") [e1,e2]) = showCurryExpr tf False b e1 : showCurryFiniteList tf b e2 -- show a string constant showCurryStringConstant :: Expr -> String showCurryStringConstant (Comb _ ("Prelude","[]") []) = [] showCurryStringConstant (Comb _ ("Prelude",":") [e1,e2]) = showCharExpr e1 ++ showCurryStringConstant e2 showCharExpr :: Expr -> String showCharExpr (Lit (Charc c)) | c=='"' = "\\\"" | c=='\'' = "\\\'" | c=='\n' = "\\n" | o < 32 || o > 126 = ['\\', chr (o `div` 100 + 48), chr (((o `mod` 100) `div` 10 + 48)), chr(o `mod` 10 + 48)] | otherwise = [c] where o = ord c showCurryElems :: (a -> String) -> [a] -> String showCurryElems format elems = intercalate " " (map format elems) showBracketsIf :: Bool -> String -> String showBracketsIf nested s = if nested then '(' : s ++ ")" else s sceBlanks :: Int -> String sceBlanks b = take b (repeat ' ') -- Is the expression a finite list (with an empty list at the end)? isFiniteList :: Expr -> Bool isFiniteList (Var _) = False isFiniteList (Lit _) = False isFiniteList (Comb _ name args) | name==("Prelude","[]") && null args = True | name==("Prelude",":") && length args == 2 = isFiniteList (args!!1) | otherwise = False isFiniteList (Let _ _) = False isFiniteList (Free _ _) = False isFiniteList (Or _ _) = False isFiniteList (Case _ _ _) = False isFiniteList (Typed e _) = isFiniteList e -- Is the expression a string constant? isStringConstant :: Expr -> Bool isStringConstant e = case e of Comb _ name args -> (name==("Prelude","[]") && null args) || (name==("Prelude",":") && length args == 2 && isCharConstant (head args) && isStringConstant (args!!1)) _ -> False -- Is the expression a character constant? isCharConstant :: Expr -> Bool isCharConstant e = case e of Lit (Charc _) -> True _ -> False ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/flatcurry/src/FlatCurry/Types.curry000066400000000000000000000227561377556325500252260ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library supports meta-programming, i.e., the manipulation of --- Curry programs in Curry. For this purpose, the library contains --- definitions of data types for the representation of --- so-called FlatCurry programs. --- --- @author Michael Hanus --- @version July 2016 --- @category meta ------------------------------------------------------------------------------ module FlatCurry.Types where --- Data type for representing a Curry module in the intermediate form. --- A value of this data type has the form --- --- (Prog modname imports typedecls functions opdecls) --- --- where --- `modname` is the name of this module, --- `imports` is the list of modules names that are imported, and --- `typedecls`, `functions`, and `opdecls` are the list of --- data type, function, and operator declarations --- contained in this module, respectively. data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl] deriving (Eq, Ord, Read, Show) --- The data type for representing qualified names. --- In FlatCurry all names are qualified to avoid name clashes. --- The first component is the module name and the second component the --- unqualified name as it occurs in the source program. type QName = (String, String) --- Data type to specify the visibility of various entities. data Visibility = Public -- public (exported) entity | Private -- private entity deriving (Eq, Ord, Read, Show) --- The data type for representing type variables. --- They are represented by `(TVar i)` where `i` is a type variable index. type TVarIndex = Int --- Kinded type variables are represented by a tuple of type variable --- index and kind. type TVarWithKind = (TVarIndex, Kind) --- Data type for representing definitions of algebraic data types --- and type synonyms. --- --- A data type definition of the form --- --- data t x1...xn = ...| c t1....tkc |... --- --- is represented by the FlatCurry term --- --- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...]) --- --- where each `ij` is the index of the type variable `xj`. --- --- Note: the type variable indices are unique inside each type declaration --- and are usually numbered from 0 --- --- Thus, a data type declaration consists of the name of the data type, --- a list of type parameters and a list of constructor declarations. data TypeDecl = Type QName Visibility [TVarWithKind] [ConsDecl] | TypeSyn QName Visibility [TVarWithKind] TypeExpr | TypeNew QName Visibility [TVarWithKind] NewConsDecl deriving (Eq, Ord, Read, Show) --- A constructor declaration consists of the name and arity of the --- constructor and a list of the argument types of the constructor. data ConsDecl = Cons QName Int Visibility [TypeExpr] deriving (Eq, Ord, Read, Show) --- A constructor declaration for a newtype consists --- of the name of the constructor --- and the argument type of the constructor. data NewConsDecl = NewCons QName Visibility TypeExpr deriving (Eq, Ord, Read, Show) --- Data type for type expressions. --- A type expression is either a type variable, a function type, --- or a type constructor application. --- --- Note: the names of the predefined type constructors are --- "Int", "Float", "Bool", "Char", "IO", --- "()" (unit type), "(,...,)" (tuple types), "[]" (list type) data TypeExpr = TVar TVarIndex -- type variable | FuncType TypeExpr TypeExpr -- function type t1->t2 | TCons QName [TypeExpr] -- type constructor application -- TCons module name typeargs | ForallType [TVarWithKind] TypeExpr -- forall type deriving (Eq, Ord, Read, Show) data Kind = KStar | KArrow Kind Kind deriving (Eq, Ord, Read, Show) --- Data type for operator declarations. --- An operator declaration `fix p n` in Curry corresponds to the --- FlatCurry term `(Op n fix p)`. data OpDecl = Op QName Fixity Int deriving (Eq, Ord, Read, Show) --- Data types for the different choices for the fixity of an operator. data Fixity = InfixOp | InfixlOp | InfixrOp deriving (Eq, Ord, Read, Show) --- Data type for representing object variables. --- Object variables occurring in expressions are represented by `(Var i)` --- where `i` is a variable index. type VarIndex = Int --- Arity of a function. type Arity = Int --- Data type for representing function declarations. --- --- A function declaration in FlatCurry is a term of the form --- --- (Func name k type (Rule [i1,...,ik] e)) --- --- and represents the function `name` with definition --- --- name :: type --- name x1...xk = e --- --- where each `ij` is the index of the variable `xj`. --- --- Note: the variable indices are unique inside each function declaration --- and are usually numbered from 0 --- --- External functions are represented as --- --- (Func name arity type (External s)) --- --- where s is the external name associated to this function. --- --- Thus, a function declaration consists of the name, arity, type, and rule. data FuncDecl = Func QName Arity Visibility TypeExpr Rule deriving (Eq, Ord, Read, Show) --- A rule is either a list of formal parameters together with an expression --- or an "External" tag. data Rule = Rule [VarIndex] Expr | External String deriving (Eq, Ord, Read, Show) --- Data type for classifying case expressions. --- Case expressions can be either flexible or rigid in Curry. data CaseType = Rigid | Flex -- type of a case expression deriving (Eq, Ord, Read, Show) --- Data type for classifying combinations --- (i.e., a function/constructor applied to some arguments). --- @cons FuncCall - a call to a function where all arguments are provided --- @cons ConsCall - a call with a constructor at the top, all arguments are provided --- @cons FuncPartCall - a partial call to a function (i.e., not all arguments --- are provided) where the parameter is the number of --- missing arguments --- @cons ConsPartCall - a partial call to a constructor (i.e., not all arguments --- are provided) where the parameter is the number of --- missing arguments data CombType = FuncCall | ConsCall | FuncPartCall Arity | ConsPartCall Arity deriving (Eq, Ord, Read, Show) --- Data type for representing expressions. --- --- Remarks: --- --- if-then-else expressions are represented as rigid case expressions: --- --- (if e1 then e2 else e3) --- --- is represented as --- --- (case e1 of { True -> e2; False -> e3}) --- --- Higher-order applications are represented as calls to the (external) --- function `apply`. For instance, the rule --- --- app f x = f x --- --- is represented as --- --- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1])) --- --- A conditional rule is represented as a call to an external function --- `cond` where the first argument is the condition (a constraint). --- For instance, the rule --- --- equal2 x | x=:=2 = True --- --- is represented as --- --- (Rule [0] --- (Comb FuncCall ("Prelude","cond") --- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)], --- Comb FuncCall ("Prelude","True") []])) --- --- @cons Var - variable (represented by unique index) --- @cons Lit - literal (Int/Float/Char constant) --- @cons Comb - application `(f e1 ... en)` of function/constructor `f` --- with `n`<=arity(`f`) --- @cons Let - introduction of local variables via (recursive) let declarations --- @cons Free - introduction of free local variables --- @cons Or - disjunction of two expressions (used to translate rules --- with overlapping left-hand sides) --- @cons Case - case distinction (rigid or flex) --- @cons Typed - typed expression to represent an expression with a --- type declaration data Expr = Var VarIndex | Lit Literal | Comb CombType QName [Expr] | Let [(VarIndex, Expr)] Expr | Free [VarIndex] Expr | Or Expr Expr | Case CaseType Expr [BranchExpr] | Typed Expr TypeExpr deriving (Eq, Ord, Read, Show) --- Data type for representing branches in a case expression. --- --- Branches "(m.c x1...xn) -> e" in case expressions are represented as --- --- (Branch (Pattern (m,c) [i1,...,in]) e) --- --- where each `ij` is the index of the pattern variable `xj`, or as --- --- (Branch (LPattern (Intc i)) e) --- --- for integers as branch patterns (similarly for other literals --- like float or character constants). data BranchExpr = Branch Pattern Expr deriving (Eq, Ord, Read, Show) --- Data type for representing patterns in case expressions. data Pattern = Pattern QName [VarIndex] | LPattern Literal deriving (Eq, Ord, Read, Show) --- Data type for representing literals occurring in an expression --- or case branch. It is either an integer, a float, or a character constant. data Literal = Intc Int | Floatc Float | Charc Char deriving (Eq, Ord, Read, Show) ----------------------------------------------------------------------- --- Shows a qualified type name as a name relative to a module --- (first argument). Thus, names not defined in this module (except for names --- defined in the prelude) are prefixed with their module name. showQNameInModule :: String -> QName -> String showQNameInModule mod qn@(qmod, name) | qmod == mod || qmod == "Prelude" = name | otherwise = showQName qn --- Shows a qualified name. showQName :: QName -> String showQName (qmod, name) = qmod ++ '.' : name ----------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/flatcurry/src/FlatCurry/XML.curry000066400000000000000000000111111377556325500245410ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library contains functions to convert FlatCurry programs --- into corresponding XML expressions and vice versa. --- This can be used to store Curry programs in a way independent --- of a Curry system or to use a Curry system, like PAKCS, --- as back end by other functional logic programming systems. --- --- @author Sebastian Fischer --- @version October 2015 ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-} module FlatCurry.XML ( flatCurry2XmlFile, flatCurry2Xml, xmlFile2FlatCurry, xml2FlatCurry ) where import FlatCurry.Types import XML import XmlConv -- URL for the FlatCurry DTD: flatCurryDtd = "http://www.informatik.uni-kiel.de/~curry/flatcurrynew.dtd" --- Transforms a FlatCurry program term into a corresponding XML file. flatCurry2XmlFile :: Prog -> String -> IO () flatCurry2XmlFile flatprog filename = writeFile filename $ showXmlDocWithParams [DtdUrl flatCurryDtd] (flatCurry2Xml flatprog) --- Transforms a FlatCurry program term into a corresponding XML expression. flatCurry2Xml :: Prog -> XmlExp flatCurry2Xml = xmlShow cProg --- Reads an XML file with a FlatCurry program and returns --- the FlatCurry program. xmlFile2FlatCurry :: String -> IO Prog xmlFile2FlatCurry filename = readXmlFile filename >>= return . xml2FlatCurry --- Transforms an XML term into a FlatCurry program. xml2FlatCurry :: XmlExp -> Prog xml2FlatCurry = xmlRead cProg -- FlatCurry XML converter specification: cProg = eSeq5 "prog" Prog cModname cImports cTypes cFuncs cOps cModname = eString "module" cImports = eRep "import" (eString "module") cTypes = eRep "types" cType cType = eSeq4 "type" Type cQName cVis cTParams (rep cConsDecl) ! eSeq4 "typesyn" TypeSyn cQName cVis cTParams cTypeExpr ! eSeq4 "typenew" TypeNew cQName cVis cTParams cNewConsDecl cQName = seq2 (\a b -> (a,b)) (aString "module") (aString "name") cVis = adapt (b2v,v2b) (aBool "visibility" "public" "private") b2v b = if b then Public else Private v2b v = v==Public cTParams = eRep "params" cTVarWithKind cConsDecl = eSeq4 "cons" Cons cQName cArity cVis (rep cTypeExpr) cNewConsDecl = eSeq3 "newcons" NewCons cQName cVis cTypeExpr cArity = aInt "arity" cTypeExpr = eSeq2 "functype" FuncType cTypeExpr cTypeExpr ! eSeq2 "tcons" TCons cQName (rep cTypeExpr) ! eSeq1 "tvar" TVar int ! eSeq2 "forall" ForallType cTParams cTypeExpr cTVarWithKind = eSeq2 "tvarwithkind" (,) int cKind cKind = eEmpty "kstar" KStar ! eSeq2 "karrow" KArrow cKind cKind cFuncs = eRep "functions" cFunc cFunc = eSeq5 "func" Func cQName cArity cVis cTypeExpr cRule cRule = eSeq2 "rule" Rule cLHS cRHS ! eSeq1 "external" External string cLHS = element "lhs" cVars cRHS = element "rhs" cExpr cVars = rep cVar cVar = eInt "var" cExpr = eSeq1 "var" Var int ! eSeq1 "lit" Lit cLit ! eSeq2 "funccall" fc cQName cExps ! eSeq2 "conscall" cc cQName cExps ! eSeq3 "funcpartcall" pfc cQName cMissing cExps ! eSeq3 "conspartcall" pcc cQName cMissing cExps ! eSeq2 "free" Free (element "freevars" cVars) cExpr ! eSeq2 "or" Or cExpr cExpr ! eSeq2 "case" cr cExpr (rep cBranch) ! eSeq2 "fcase" cf cExpr (rep cBranch) ! eSeq2 "letrec" Let (rep cBind) cExpr ! eSeq2 "typed" Typed cExpr cTypeExpr cLit = eSeq1 "intc" Intc int ! eSeq1 "floatc" Floatc float ! eSeq1 "charc" Charc (adapt (chr,ord) int) fc = Comb FuncCall cc = Comb ConsCall pfc n m = Comb (FuncPartCall m) n pcc n m = Comb (ConsPartCall m) n cExps = rep cExpr cMissing = aInt "missing" cr = Case Rigid cf = Case Flex cBranch = eSeq2 "branch" Branch cPat cExpr cPat = eSeq2 "pattern" Pattern cQName cVars ! eSeq1 "lpattern" LPattern cLit cBind = eSeq2 "binding" (\a b -> (a,b)) cVar cExpr cOps = eRep "operators" cOp cOp = eSeq3 "op" Op cQName cFixity (aInt "prec") cFixity = adapt (rf,show) (aString "fixity") rf "InfixOp" = InfixOp rf "InfixlOp" = InfixlOp rf "InfixrOp" = InfixrOp curry-tools-v3.3.0/cpm/vendor/flatcurry/test/000077500000000000000000000000001377556325500212755ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/flatcurry/test/TestFlatCurryGoodies.curry000066400000000000000000000024751377556325500264600ustar00rootroot00000000000000--- Some tests for library FlatCurry.Goodies. --- --- To run all tests automatically by the currycheck tool, use the command: --- `curry-check TestFlatCurryGoodies` --- --- @author Sebastian Fischer import FlatCurry.Types import FlatCurry.Files import FlatCurry.Goodies import Test.Prop testIdentityTransformation = identity `returns` True identity = do prog <- readFlatCurry "TestFlatCurryGoodies" return (prog == idProg prog) idProg = trProg prog where prog name imps types funcs ops = Prog name imps (map idType types) (map idFunc funcs) (map idOp ops) idType = trType typ typesyn typenew where typ name vis params cs = Type name vis params (map idCons cs) typesyn name vis params syn = TypeSyn name vis params (idTypeExpr syn) typenew name vis params ncd = TypeNew name vis params (idNewCons ncd) idCons = trCons cons where cons name arity vis args = Cons name arity vis (map idTypeExpr args) idNewCons = trNewCons cons where cons name vis te = NewCons name vis (idTypeExpr te) idTypeExpr = trTypeExpr TVar TCons FuncType ForallType idFunc = trFunc func where func name arity vis t rule = Func name arity vis (idTypeExpr t) (idRule rule) idRule = trRule rule External where rule args exp = Rule args (idExpr exp) idExpr = trExpr Var Lit Comb Let Free Or Case Branch Typed idOp = trOp Op curry-tools-v3.3.0/cpm/vendor/flatcurry/test/TestFlatCurryXML.curry000066400000000000000000000015641377556325500255250ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some tests for library `FlatCurry.XML`. --- --- @author Michael Hanus ------------------------------------------------------------------------------ import FlatCurry.Types import FlatCurry.Files import FlatCurry.XML import XML import Test.Prop -- Shows a program in XML format: showxml mod = do prog <- readFlatCurry mod putStrLn $ showXmlDoc (flatCurry2Xml prog) -- Store a program in XML format: store mod = do prog <- readFlatCurry mod flatCurry2XmlFile prog (mod++"_fcy.xml") putStrLn (mod++"_fcy.xml"++" written") -- Test for equality after XML encoding/decoding: testEqualFcy prog = prog == xml2FlatCurry (flatCurry2Xml prog) readAndTestEqualFcy mod = do prog <- readFlatCurry mod return $ testEqualFcy prog testXML_test_for_rev = (readAndTestEqualFcy "rev") `returns` True curry-tools-v3.3.0/cpm/vendor/flatcurry/test/rev.curry000066400000000000000000000005341377556325500231610ustar00rootroot00000000000000-- Concatenating two lists: -- (predefined as `++' in the standard prelude) append :: [t] -> [t] -> [t] append [] x = x append (x:xs) ys = x : append xs ys -- Reverse the order of elements in a list: rev :: [t] -> [t] rev [] = [] rev (x:xs) = append (rev xs) [x] goal1 = append [1,2] [3,4] goal2 = rev [1,2,3,4] -- end of program curry-tools-v3.3.0/cpm/vendor/frontend-exec/000077500000000000000000000000001377556325500210445ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/frontend-exec/LICENSE000066400000000000000000000027351377556325500220600ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/frontend-exec/README.md000066400000000000000000000004251377556325500223240ustar00rootroot00000000000000frontend-exec ============= This package provides the library `System.FrontendExec` containing operations to invoke the front end of the Curry system to compile a given Curry program into various output formats (e.g., AbstractCurry, FlatCurry, AST with position information). curry-tools-v3.3.0/cpm/vendor/frontend-exec/package.json000066400000000000000000000015141377556325500233330ustar00rootroot00000000000000{ "name": "frontend-exec", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Operations to execute the front end of the Curry system", "category": [ "System" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "currypath" : ">= 3.0.0, < 4.0.0", "distribution" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0", "process" : ">= 3.0.0, < 4.0.0", "propertyfile" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 3.3.0" }, "exportedModules": [ "System.FrontendExec" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/frontend-exec.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/frontend-exec/src/000077500000000000000000000000001377556325500216335ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/frontend-exec/src/System/000077500000000000000000000000001377556325500231175ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/frontend-exec/src/System/FrontendExec.curry000066400000000000000000000234241377556325500265760ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains operations to execute the front end of the --- Curry system. --- --- @author Bernd Brassel, Michael Hanus, Bjoern Peemoeller, Finn Teegen --- @version December 2020 ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} module System.FrontendExec (FrontendTarget(..) , FrontendParams(..), defaultParams, rcParams , setQuiet, setExtended, setCpp, addDefinition, setDefinitions , setOverlapWarn, setFullPath, setHtmlDir, setLogfile, addTarget, setSpecials , setFrontendPath , callFrontend, callFrontendWithParams ) where import Data.Char ( toUpper ) import Data.List ( intercalate, nub ) import Data.PropertyFile ( getPropertiesFromFile ) import System.FilePath ( FilePath, (), takeDirectory, takeFileName ) import System.Process ( system ) import System.CurryPath ( curryrcFileName, currySubdir, getLoadPathForModule ) import Language.Curry.Distribution ( curryCompiler, curryCompilerMajorVersion , curryCompilerMinorVersion, installDir ) ------------------------------------------------------------------- -- calling the front end ------------------------------------------------------------------- --- Data type for representing the different target files that can be produced --- by the front end of the Curry compiler. --- @cons FCY - FlatCurry file ending with .fcy --- @cons TFCY - Typed FlatCurry file ending with .tfcy --- @cons FINT - FlatCurry interface file ending with .fint --- @cons ACY - AbstractCurry file ending with .acy --- @cons UACY - Untyped (without type checking) AbstractCurry file ending with .uacy --- @cons HTML - colored HTML representation of source program --- @cons CY - source representation employed by the frontend --- @cons TOKS - token stream of source program --- @cons AST - abstract syntax tree ending with .sast --- @cons SAST - shortened abstract syntax tree ending with .sast --- @cons COMMS - comments stream ending with .cycom data FrontendTarget = FCY | TFCY | FINT | ACY | UACY | HTML | CY | TOKS | TAFCY | AST | SAST | COMMS deriving (Eq, Show) --- Abstract data type for representing parameters supported by the front end --- of the Curry compiler. -- The parameters are of the form -- FrontendParams Quiet Extended Cpp NoOverlapWarn FullPath HtmlDir LogFile Specials FrontendPath data FrontendParams = FrontendParams { quiet :: Bool -- work silently , extended :: Bool -- support extended Curry syntax , cpp :: Bool -- enable conditional compiling , definitions :: [(String, Int)] -- definitions for conditional compiling , overlapWarn :: Bool -- warn for overlapping rules , fullPath :: Maybe [String] -- the complete list of directory names for loading modules , htmldir :: Maybe String -- output directory (only relevant for HTML target) , logfile :: Maybe String -- store all output (including errors) of the front end in file , targets :: [FrontendTarget] -- additional targets for the front end , specials :: String -- additional special parameters (use with care!) , frontendPath :: String -- the path to the frontend executable } --- The default parameters of the front end. defaultParams :: FrontendParams defaultParams = FrontendParams { quiet = False , extended = True , cpp = False , definitions = defaultDefs , overlapWarn = True , fullPath = Nothing , htmldir = Nothing , logfile = Nothing , targets = [] , specials = "" , frontendPath = installDir "bin" curryCompiler ++ "-frontend" } where defaultDefs = [("__" ++ map toUpper curryCompiler ++ "__", curryCompilerMajorVersion * 100 + curryCompilerMinorVersion)] --- The default parameters of the front end as configured by the compiler --- specific resource configuration file. rcParams :: IO FrontendParams rcParams = do rcfile <- curryrcFileName [mbExtended,mbOverlapWarn] <- getPropertiesFromFile rcfile ["curryextensions","warnoverlapping"] return $ setExtended (mbExtended /= Just "no") $ setOverlapWarn (mbOverlapWarn /= Just "no") $ defaultParams --- Set quiet mode of the front end. setQuiet :: Bool -> FrontendParams -> FrontendParams setQuiet s ps = ps { quiet = s } --- Set extended mode of the front end. setExtended :: Bool -> FrontendParams -> FrontendParams setExtended s ps = ps { extended = s } --- Set cpp mode of the front end. setCpp :: Bool -> FrontendParams -> FrontendParams setCpp s ps = ps { cpp = s } --- Add cpp definition of the front end. addDefinition :: (String, Int) -> FrontendParams -> FrontendParams addDefinition d ps = ps { definitions = definitions ps ++ [d] } --- Set cpp definitions of the front end. setDefinitions :: [(String, Int)] -> FrontendParams -> FrontendParams setDefinitions s ps = ps { definitions = s } --- Set overlap warn mode of the front end. setOverlapWarn :: Bool -> FrontendParams -> FrontendParams setOverlapWarn s ps = ps { overlapWarn = s } --- Set the full path of the front end. --- If this parameter is set, the front end searches all modules --- in this path (instead of using the default path). setFullPath :: [String] -> FrontendParams -> FrontendParams setFullPath s ps = ps { fullPath = Just s } --- Set the htmldir parameter of the front end. --- Relevant for HTML generation. setHtmlDir :: String -> FrontendParams -> FrontendParams setHtmlDir s ps = ps { htmldir = Just s } --- Set the logfile parameter of the front end. --- If this parameter is set, all messages produced by the front end --- are stored in this file. setLogfile :: String -> FrontendParams -> FrontendParams setLogfile s ps = ps { logfile = Just s } --- Set additional specials parameters of the front end. --- These parameters are specific for the current front end and --- should be used with care, since their form might change in the future. setSpecials :: String -> FrontendParams -> FrontendParams setSpecials s ps = ps { specials = s } --- Add an additional front end target. addTarget :: FrontendTarget -> FrontendParams -> FrontendParams addTarget t ps = ps { targets = t : targets ps } --- Sets the path to the frontend executable. setFrontendPath :: String -> FrontendParams -> FrontendParams setFrontendPath s ps = ps { frontendPath = s } --- In order to make sure that compiler generated files (like .fcy, .fint, .acy) --- are up to date, one can call the front end of the Curry compiler --- with this action. --- If the front end returns with an error, an exception is raised. --- @param target - the kind of target file to be generated --- @param progname - the name of the main module of the application to be compiled callFrontend :: FrontendTarget -> String -> IO () callFrontend target p = do params <- rcParams callFrontendWithParams target params p --- In order to make sure that compiler generated files (like .fcy, .fint, .acy) --- are up to date, one can call the front end of the Curry compiler --- with this action where various parameters can be set. --- If the front end returns with an error, an exception is raised. --- @param target - the kind of target file to be generated --- @param params - parameters for the front end --- @param modpath - the name of the main module possibly prefixed with a --- directory where this module resides callFrontendWithParams :: FrontendTarget -> FrontendParams -> String -> IO () callFrontendWithParams target params modpath = do parsecurry <- callParseCurry let lf = maybe "" id (logfile params) tgts = nub (target : targets params) syscall = unwords $ [parsecurry] ++ map showFrontendTarget tgts ++ [showFrontendParams, cppParams, takeFileName modpath] retcode <- if null lf then system syscall else system (syscall ++ " > " ++ lf ++ " 2>&1") if retcode == 0 then return () else ioError (userError "Illegal source program") where callParseCurry = do path <- maybe (getLoadPathForModule modpath) (\p -> return (nub (takeDirectory modpath : p))) (fullPath params) return (quote (frontendPath params) ++ concatMap ((" -i" ++) . quote) path) quote s = '"' : s ++ "\"" showFrontendTarget FCY = "--flat" showFrontendTarget TFCY = "--typed-flat" showFrontendTarget TAFCY = "--type-annotated-flat" showFrontendTarget FINT = "--flat" showFrontendTarget ACY = "--acy" showFrontendTarget UACY = "--uacy" showFrontendTarget HTML = "--html" showFrontendTarget CY = "--parse-only" showFrontendTarget TOKS = "--tokens" showFrontendTarget AST = "--ast" showFrontendTarget SAST = "--short-ast" showFrontendTarget COMMS = "--comments" showFrontendParams = unwords [ "-o ", currySubdir , if quiet params then runQuiet else "" , if extended params then "--extended" else "" , if cpp params then "--cpp" else "" , if overlapWarn params then "" else "--no-overlap-warn" , maybe "" ("--htmldir="++) (htmldir params) , specials params #ifdef __PAKCS__ , if target `elem` [FCY,TFCY,TAFCY,FINT] then "-Odesugar-newtypes" -- remove when newtypes added to FlatCurry else "" #endif ] runQuiet = "--no-verb --no-warn --no-overlap-warn" cppParams = intercalate " " $ map showDefinition (definitions params) showDefinition (s, v) = "-D" ++ s ++ "=" ++ show v ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/global/000077500000000000000000000000001377556325500175435ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/global/LICENSE000066400000000000000000000027351377556325500205570ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/global/README.md000066400000000000000000000015061377556325500210240ustar00rootroot00000000000000global: Handling global entities in programs ============================================ This package contains a library to handle global entities. A global entity has a name declared in the program. Its value can be accessed and modified by IO actions. Furthermore, global entities can be declared as persistent so that their values are stored across different program executions. Currently, it is still experimental so that its interface might be slightly changed in the future. A global entity `g` with an initial value `v` of type `t` must be declared by: g :: Global t g = global v spec Here, the type `t` must not contain type variables and `spec` specifies the storage mechanism for the global entity (see type `GlobalSpec` in the library). -------------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/global/package.json000066400000000000000000000013131377556325500220270ustar00rootroot00000000000000{ "name": "global", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library for handling global entities in programs", "category": [ "Programming" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "process" : ">= 3.0.0, < 4.0.0" }, "testsuite": { "src-dir": "test", "modules": [ "TestGlobal" ] }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/global.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/global/src/000077500000000000000000000000001377556325500203325ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/global/src/Global.curry000066400000000000000000000053011377556325500226170ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for handling global entities. --- A global entity has a name declared in the program. --- Its value can be accessed and modified by IO actions. --- Furthermore, global entities can be declared as persistent so that --- their values are stored across different program executions. --- --- Currently, it is still experimental so that its interface might --- be slightly changed in the future. --- --- A global entity `g` with an initial value `v` --- of type `t` must be declared by: --- --- g :: Global t --- g = global v spec --- --- Here, the type `t` must not contain type variables and --- `spec` specifies the storage mechanism for the --- global entity (see type `GlobalSpec`). --- --- --- @author Michael Hanus --- @version February 2017 --- @category general ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} module Global ( Global, GlobalSpec(..), global , readGlobal, safeReadGlobal, writeGlobal) where ---------------------------------------------------------------------- --- The abstract type of a global entity. #ifdef __PAKCS__ data Global a = GlobalDef a GlobalSpec #else external data Global _ #endif --- `global` is only used for the declaration of a global value --- and should not be used elsewhere. In the future, it might become a keyword. global :: a -> GlobalSpec -> Global a #ifdef __PAKCS__ global v s = GlobalDef v s #else global external #endif --- The storage mechanism for the global entity. --- @cons Temporary - the global value exists only during a single execution --- of a program --- @cons Persistent f - the global value is stored persisently in file f --- (which is created and initialized if it does not exists) data GlobalSpec = Temporary | Persistent String --- Reads the current value of a global. readGlobal :: Global a -> IO a readGlobal g = prim_readGlobal $# g prim_readGlobal :: Global a -> IO a prim_readGlobal external --- Safely reads the current value of a global. --- If `readGlobal` fails (e.g., due to a corrupted persistent storage), --- the global is re-initialized with the default value given as --- the second argument. safeReadGlobal :: Global a -> a -> IO a safeReadGlobal g dflt = catch (readGlobal g) (\_ -> writeGlobal g dflt >> return dflt) --- Updates the value of a global. --- The value is evaluated to a ground constructor term before it is updated. writeGlobal :: Global a -> a -> IO () writeGlobal g v = (prim_writeGlobal $# g) $## v prim_writeGlobal :: Global a -> a -> IO () prim_writeGlobal external ------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/global/src/Global.kics2000066400000000000000000000147001377556325500224710ustar00rootroot00000000000000import CurryException import Control.Exception as C import Data.IORef import System.IO import System.Directory (doesFileExist) import System.IO.Unsafe import System.Process (system) -- Implementation of Globals in Curry. We use Haskell's IORefs for temporary -- globals where Curry values are stored in the IORefs data C_Global a = Choice_C_Global Cover ID (C_Global a) (C_Global a) | Choices_C_Global Cover ID ([C_Global a]) | Fail_C_Global Cover FailInfo | Guard_C_Global Cover Constraints (C_Global a) | C_Global_Temp (IORef a) -- a temporary global | C_Global_Pers String -- a persistent global with a given (file) name instance Show (C_Global a) where show = error "ERROR: no show for Global" instance Read (C_Global a) where readsPrec = error "ERROR: no read for Global" instance NonDet (C_Global a) where choiceCons = Choice_C_Global choicesCons = Choices_C_Global failCons = Fail_C_Global guardCons = Guard_C_Global try (Choice_C_Global cd i x y) = tryChoice cd i x y try (Choices_C_Global cd i xs) = tryChoices cd i xs try (Fail_C_Global cd info) = Fail cd info try (Guard_C_Global cd c e) = Guard cd c e try x = Val x match choiceF _ _ _ _ _ (Choice_C_Global cd i x y) = choiceF cd i x y match _ narrF _ _ _ _ (Choices_C_Global cd i@(NarrowedID _ _) xs) = narrF cd i xs match _ _ freeF _ _ _ (Choices_C_Global cd i@(FreeID _ _) xs) = freeF cd i xs match _ _ _ failF _ _ (Fail_C_Global cd info) = failF cd info match _ _ _ _ guardF _ (Guard_C_Global cd c e) = guardF cd c e match _ _ _ _ _ valF x = valF x instance Generable (C_Global a) where generate _ _ = error "ERROR: no generator for Global" instance NormalForm (C_Global a) where ($!!) cont g@(C_Global_Temp _) cd cs = cont g cd cs ($!!) cont g@(C_Global_Pers _) cd cs = cont g cd cs ($!!) cont (Choice_C_Global d i g1 g2) cd cs = nfChoice cont d i g1 g2 cd cs ($!!) cont (Choices_C_Global d i gs) cd cs = nfChoices cont d i gs cd cs ($!!) cont (Guard_C_Global d c g) cd cs = guardCons d c ((cont $!! g) cd $! (addCs c cs)) ($!!) _ (Fail_C_Global d info) _ _ = failCons d info ($##) cont g@(C_Global_Temp _) cd cs = cont g cd cs ($##) cont g@(C_Global_Pers _) cd cs = cont g cd cs ($##) cont (Choice_C_Global d i g1 g2) cd cs = gnfChoice cont d i g1 g2 cd cs ($##) cont (Choices_C_Global d i gs) cd cs = gnfChoices cont d i gs cd cs ($##) cont (Guard_C_Global d c g) cd cs = guardCons d c ((cont $## g) cd $! (addCs c cs)) ($##) _ (Fail_C_Global cd info) _ _ = failCons cd info searchNF _ cont g@(C_Global_Temp _) = cont g searchNF _ cont g@(C_Global_Pers _) = cont g instance Unifiable (C_Global a) where (=.=) (C_Global_Temp ref1) (C_Global_Temp ref2) _ _ | ref1 == ref2 = C_True (=.=) (C_Global_Pers f1) (C_Global_Pers f2) _ _ | f1 == f2 = C_True (=.=) _ _ cd _ = Fail_C_Bool cd defFailInfo (=.<=) = (=.=) bind cd i (Choice_C_Global d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))] bind cd i (Choices_C_Global d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs bind cd i (Choices_C_Global d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))] bind _ _ (Fail_C_Global _ info) = [Unsolvable info] bind cd i (Guard_C_Global _ cs e) = (getConstrList cs) ++ (bind cd i e) lazyBind cd i (Choice_C_Global d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))] lazyBind cd i (Choices_C_Global d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs lazyBind cd i (Choices_C_Global d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))] lazyBind _ _ (Fail_C_Global cd info) = [Unsolvable info] lazyBind cd i (Guard_C_Global _ cs e) = (getConstrList cs) ++ [(i :=: (LazyBind (lazyBind cd i e)))] instance Curry_Prelude.Curry a => Curry_Prelude.Curry (C_Global a) external_d_C_global :: Curry_Prelude.Curry a => a -> C_GlobalSpec -> Cover -> ConstStore -> C_Global a external_d_C_global val C_Temporary _ _ = ref `seq` (C_Global_Temp ref) where ref = unsafePerformIO (newIORef val) external_d_C_global val (C_Persistent cname) _ _ = let name = fromCurry cname :: String in unsafePerformIO (initGlobalFile name >> return (C_Global_Pers name)) where initGlobalFile name = do ex <- doesFileExist name if ex then return () else do writeFile name (show val ++ "\n") system ("chmod 600 " ++ name) return () external_d_C_prim_readGlobal :: Curry_Prelude.Curry a => C_Global a -> Cover -> ConstStore -> Curry_Prelude.C_IO a external_d_C_prim_readGlobal (C_Global_Temp ref) _ _ = fromIO (readIORef ref) external_d_C_prim_readGlobal (C_Global_Pers name) _ _ = fromIO $ exclusiveOnFile name $ do s <- catch (do h <- openFile name ReadMode eof <- hIsEOF h s <- if eof then return "" else hGetLine h hClose h return s) (\e -> throw (IOException (show (e :: C.IOException)))) case reads s of [(val,"")] -> return val _ -> throw (IOException $ "Persistent file `" ++ name ++ "' contains malformed contents:\n" ++ s) external_d_C_prim_writeGlobal :: Curry_Prelude.Curry a => C_Global a -> a -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_writeGlobal (C_Global_Temp ref) val _ _ = toCurry (writeIORef ref val) external_d_C_prim_writeGlobal (C_Global_Pers name) val _ _ = toCurry (exclusiveOnFile name $ writeFile name (show val ++ "\n")) --- Forces the exclusive execution of an action via a lock file. exclusiveOnFile :: String -> IO a -> IO a exclusiveOnFile file action = do exlock <- doesFileExist lockfile if exlock then hPutStrLn stderr (">>> Waiting for removing lock file `" ++ lockfile ++ "'...") else return () system ("lockfile-create --lock-name "++lockfile) C.catch (do actionResult <- action deleteLockFile return actionResult ) (\e -> deleteLockFile >> C.throw (e :: CurryException)) where lockfile = file ++ ".LOCK" deleteLockFile = system $ "lockfile-remove --lock-name " ++ lockfile curry-tools-v3.3.0/cpm/vendor/global/src/Global.pakcs.pl000066400000000000000000000074061377556325500231760ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module Global: % % initialize the predicate containing the global value if called for the % first time: initGlobalValue(GlobName,'Global.Temporary',Exp,Val) :- evalToken(Eval), user:nf(Exp,Val,Eval,E1), user:waitUntilGround(Val,E1,_), % groundness required GlobalHead =.. [GlobName,_], user:retractClause(GlobalHead,_), NewGlobalCall =.. [GlobName,Val], % temporary globals directly contain its value: assertz(user:NewGlobalCall), !. initGlobalValue(GlobName,'Global.Persistent'(FExp),Exp,FileName) :- evalToken(Eval), user:nf(FExp,FileString,Eval,E0), user:waitUntilGround(FileString,E0,E1), % groundness required string2Atom(FileString,FileName), user:nf(Exp,Val,E1,E2), user:waitUntilGround(Val,E2,_), % groundness required GlobalHead =.. [GlobName,_], user:retractClause(GlobalHead,_), NewGlobalCall =.. [GlobName,FileName], % persistent globals contain the file name where its value is stored: assertz(user:NewGlobalCall), (existsFile(FileName) -> true ; writeGlobalFile(FileName,Val)), !. % read a global value: 'Global.prim_readGlobal'('Global.GlobalDef'(GlobName,'Global.Temporary'),Val) :- GlobalCall =.. [GlobName,Val], call(user:GlobalCall), !. 'Global.prim_readGlobal'('Global.GlobalDef'(GlobName,'Global.Persistent'), Val) :- GlobalCall =.. [GlobName,FileName], call(user:GlobalCall), readGlobalFile(FileName,Val), !. % update a global value: 'Global.prim_writeGlobal'('Global.GlobalDef'(GlobName,'Global.Temporary'), NewVal,'Prelude.()') :- GlobalCall =.. [GlobName,_], (retract(user:GlobalCall) ; user:retractClause(GlobalCall,_)), NewGlobalCall =.. [GlobName,NewVal], assertz(user:NewGlobalCall), !. 'Global.prim_writeGlobal'('Global.GlobalDef'(GlobName,'Global.Persistent'), NewVal,'Prelude.()') :- GlobalCall =.. [GlobName,FileName], call(user:GlobalCall), writeGlobalFile(FileName,NewVal), !. % read the file with the persistent global value: readGlobalFile(FileName,Val) :- lockFileName(FileName,LockFile), lockWithFile(LockFile), on_exception(ErrorMsg, (open(FileName,read,Stream), readStreamLine(Stream,ValString), close(Stream)), ValString=[]), unlockWithFile(LockFile), readShowTerm:readTerm(ValString,qualified,_Rest,Val). % write the file with the persistent global value: writeGlobalFile(FileName,Val) :- lockFileName(FileName,LockFile), lockWithFile(LockFile), (existsFile(FileName) -> appendAtom(FileName,'.bak',BakFileName), renameFile(FileName,BakFileName) ; true), open(FileName,write,Stream), readShowTerm:show_term(Val,qualified,ValString,[]), writeChars(Stream,ValString), put_code(Stream,10), % the additional characters are necessary due to a bug in % SWI-Prolog when reading short files: put_code(Stream,10), put_code(Stream,10), put_code(Stream,10), close(Stream), % make files for storing globals only accessible for the user: appendAtom('chmod 600 ',FileName,ChmodCmd), % ignore errors (might occur in Windows emulators) since not relevant: on_exception(_,shellCmd(ChmodCmd,_),true), unlockWithFile(LockFile). % lockfile for safe file reading/writing: lockFileName(FName,LockFile) :- appendAtom(FName,'.LOCK',LockFile). lockWithFile(LockFile) :- appendAtom('lockfile-create --lock-name ',LockFile,LockCmd), ((existsFile(LockFile), pakcsrc(dynamicmessages,yes)) -> writeErr('>>> Waiting for removing lock file \''), writeErr(LockFile), writeErr('\'...'), nlErr ; true), shellCmd(LockCmd), !. unlockWithFile(LockFile) :- appendAtom('lockfile-remove --lock-name ',LockFile,LockCmd), shellCmd(LockCmd). curry-tools-v3.3.0/cpm/vendor/global/test/000077500000000000000000000000001377556325500205225ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/global/test/TestGlobal.curry000066400000000000000000000044151377556325500236540ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some tests for library Global --- --- To run all tests automatically by the currycheck tool, use the command: --- "curry-check TestGlobal" --- --- @author Michael Hanus ------------------------------------------------------------------------------ import Global import System.Process ( system ) import Test.Prop ------------------------------------------------------------------------------ -- Testing a simple integer temporary global entity: points :: Global Int points = global (div 1 1) Temporary rwglobal :: IO (Int,Int) rwglobal = do v1 <- readGlobal points writeGlobal points 42 v2 <- readGlobal points return (v1,v2) testSimpleIntReadGlobalWriteGlobal = rwglobal `returns` (1,42) ------------------------------------------------------------------------------ -- Testing a temporary global entity containing a list structure: nats :: Global [Int] nats = global [] Temporary listrwglobal :: IO ([Int],[Int]) listrwglobal = do writeGlobal nats [1..5] v1 <- readGlobal nats writeGlobal nats (v1++v1) v2 <- readGlobal nats return (v1,v2) testSimpleIntlistReadGlobalWriteGlobal = listrwglobal `returns` ([1..5],[1..5]++[1..5]) ------------------------------------------------------------------------------ -- Testing the interaction of two integer temporary global entities: gint1 :: Global Int gint1 = global 0 Temporary gint2 :: Global Int gint2 = global 42 Temporary rwglobals :: IO [Int] rwglobals = do v1 <- readGlobal gint1 v2 <- readGlobal gint2 writeGlobal gint2 99 v3 <- readGlobal gint1 v4 <- readGlobal gint2 writeGlobal gint1 (v4+1) v5 <- readGlobal gint1 v6 <- readGlobal gint2 return [v1,v2,v3,v4,v5,v6] testReadWriteTwoTemporaryGlobals = rwglobals `returns` [0,42,0,99,100,99] ------------------------------------------------------------------------------ -- Testing a simple integer persistent global entity: ppoints :: Global Int ppoints = global (3+4) (Persistent "pointsstore") rwglobalp :: IO (Int,Int) rwglobalp = do v1 <- readGlobal ppoints writeGlobal ppoints 42 v2 <- readGlobal ppoints return (v1,v2) testPersistentIntReadGlobalWriteGlobal = rwglobalp `returns` (7,42) -- finalize: clean testCleanUp = (system "rm -r pointsstore*") `returns` 0 curry-tools-v3.3.0/cpm/vendor/io-extra/000077500000000000000000000000001377556325500200335ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/io-extra/LICENSE000066400000000000000000000027351377556325500210470ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/io-extra/package.json000066400000000000000000000014241377556325500223220ustar00rootroot00000000000000{ "name": "io-extra", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library with some useful extensions to the IO monad.", "category": [ "IO" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base": ">= 3.0.0, < 4.0.0", "process": ">= 3.0.0, < 4.0.0", "directory":">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.IOExts" ], "testsuite": { "src-dir": "test", "modules": [ "TestConnect" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/io-extra.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/io-extra/src/000077500000000000000000000000001377556325500206225ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/io-extra/src/System/000077500000000000000000000000001377556325500221065ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/io-extra/src/System/IOExts.curry000066400000000000000000000136041377556325500243530ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some useful extensions to the IO monad. --- --- @author Michael Hanus --- @version January 2017 ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} module System.IOExts ( -- execution of shell commands execCmd, evalCmd, connectToCommand -- file access , readCompleteFile,updateFile, exclusiveIO -- associations , setAssoc,getAssoc -- IORef , IORef, newIORef, readIORef, writeIORef, modifyIORef ) where #ifdef __PAKCS__ import Data.Char (isAlphaNum) import System.Directory (removeFile) #endif import System.IO import System.Process import Data.IORef import Control.Monad --- Executes a command with a new default shell process. --- The standard I/O streams of the new process (stdin,stdout,stderr) --- are returned as handles so that they can be explicitly manipulated. --- They should be closed with IO.hClose since they are not --- closed automatically when the process terminates. --- @param cmd - the shell command to be executed --- @return the handles of the input/output/error streams of the new process execCmd :: String -> IO (Handle, Handle, Handle) execCmd cmd = prim_execCmd $## cmd prim_execCmd :: String -> IO (Handle, Handle, Handle) prim_execCmd external --- Executes a command with the given arguments as a new default shell process --- and provides the input via the process' stdin input stream. --- The exit code of the process and the contents written to the standard --- I/O streams stdout and stderr are returned. --- @param cmd - the shell command to be executed --- @param args - the command's arguments --- @param input - the input to be written to the command's stdin --- @return the exit code and the contents written to stdout and stderr evalCmd :: String -> [String] -> String -> IO (Int, String, String) #ifdef __PAKCS__ evalCmd cmd args input = do pid <- getPID let tmpfile = "/tmp/PAKCS_evalCMD"++show pid (hi,ho,he) <- execCmd (unwords (map wrapArg (cmd:args)) ++ " ; (echo $? > "++tmpfile++")") unless (null input) (hPutStrLn hi input) hClose hi outs <- hGetEOF ho errs <- hGetEOF he ecodes <- readCompleteFile tmpfile removeFile tmpfile return (read ecodes, outs, errs) where wrapArg str | null str = "''" -- goodChar is a pessimistic predicate, such that if an argument is -- non-empty and only contains goodChars, then there is no need to -- do any quoting or escaping | all goodChar str = str | otherwise = '\'' : foldr escape "'" str where escape c s | c == '\'' = "'\\''" ++ s | otherwise = c : s goodChar c = isAlphaNum c || c `elem` "-_.,/" --- Reads from an input handle until EOF and returns the input. hGetEOF :: Handle -> IO String hGetEOF h = do eof <- hIsEOF h if eof then hClose h >> return "" else do c <- hGetChar h cs <- hGetEOF h return (c:cs) #else evalCmd cmd args input = ((prim_evalCmd $## cmd) $## args) $## input prim_evalCmd :: String -> [String] -> String -> IO (Int, String, String) prim_evalCmd external #endif --- Executes a command with a new default shell process. --- The input and output streams of the new process is returned --- as one handle which is both readable and writable. --- Thus, writing to the handle produces input to the process and --- output from the process can be retrieved by reading from this handle. --- The handle should be closed with IO.hClose since they are not --- closed automatically when the process terminates. --- @param cmd - the shell command to be executed --- @return the handle connected to the input/output streams --- of the new process connectToCommand :: String -> IO Handle connectToCommand cmd = prim_connectToCmd $## cmd prim_connectToCmd :: String -> IO Handle prim_connectToCmd external --- An action that reads the complete contents of a file and returns it. --- This action can be used instead of the (lazy) readFile --- action if the contents of the file might be changed. --- @param file - the name of the file --- @return the complete contents of the file readCompleteFile :: String -> IO String readCompleteFile file = do s <- readFile file f s (return s) where f [] r = r f (_:cs) r = f cs r --- An action that updates the contents of a file. --- @param f - the function to transform the contents --- @param file - the name of the file updateFile :: (String -> String) -> String -> IO () updateFile f file = do s <- readCompleteFile file writeFile file (f s) --- Forces the exclusive execution of an action via a lock file. --- For instance, (exclusiveIO "myaction.lock" act) ensures that --- the action "act" is not executed by two processes on the same --- system at the same time. --- @param lockfile - the name of a global lock file --- @param action - the action to be exclusively executed --- @return the result of the execution of the action exclusiveIO :: String -> IO a -> IO a exclusiveIO lockfile action = do system ("lockfile-create --lock-name "++lockfile) catch (do actionResult <- action deleteLockFile return actionResult ) (\e -> deleteLockFile >> ioError e) where deleteLockFile = system $ "lockfile-remove --lock-name " ++ lockfile --- Defines a global association between two strings. --- Both arguments must be evaluable to ground terms before applying --- this operation. setAssoc :: String -> String -> IO () setAssoc key val = (prim_setAssoc $## key) $## val prim_setAssoc :: String -> String -> IO () prim_setAssoc external --- Gets the value associated to a string. --- Nothing is returned if there does not exist an associated value. getAssoc :: String -> IO (Maybe String) getAssoc key = prim_getAssoc $## key prim_getAssoc :: String -> IO (Maybe String) prim_getAssoc external curry-tools-v3.3.0/cpm/vendor/io-extra/src/System/IOExts.kics2000066400000000000000000000045511377556325500242230ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses #-} import Data.IORef import System.IO.Unsafe (unsafePerformIO) -- for global associations import System.Process (readProcessWithExitCode, runInteractiveCommand) import Control.Concurrent (forkIO) import System.IO external_d_C_prim_execCmd :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple3 Curry_IO.C_Handle Curry_IO.C_Handle Curry_IO.C_Handle) external_d_C_prim_execCmd str _ _ = toCurry (\s -> do (h1,h2,h3,_) <- runInteractiveCommand s return (OneHandle h1, OneHandle h2, OneHandle h3)) str external_d_C_prim_evalCmd :: Curry_Prelude.C_String -> Curry_Prelude.OP_List Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple3 Curry_Prelude.C_Int Curry_Prelude.C_String Curry_Prelude.C_String) external_d_C_prim_evalCmd cmd args input _ _ = toCurry readProcessWithExitCode cmd args input external_d_C_prim_connectToCmd :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_IO.C_Handle external_d_C_prim_connectToCmd str _ _ = toCurry (\s -> do (hin,hout,herr,_) <- runInteractiveCommand s forkIO (forwardError herr) return (InOutHandle hout hin)) str forwardError :: Handle -> IO () forwardError h = do eof <- hIsEOF h if eof then return () else hGetLine h >>= hPutStrLn stderr >> forwardError h ----------------------------------------------------------------------- -- Implementation of global associations as simple association lists -- (could be later improved by a more efficient implementation, e.g., maps) type Assocs = [(String,String)] assocs :: IORef Assocs assocs = unsafePerformIO (newIORef []) external_d_C_prim_setAssoc :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_setAssoc str1 str2 _ _ = toCurry (\key val -> do as <- readIORef assocs writeIORef assocs ((key,val):as)) str1 str2 external_d_C_prim_getAssoc :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_Maybe (Curry_Prelude.C_String)) external_d_C_prim_getAssoc str _ _ = toCurry (\key -> do as <- readIORef assocs return (lookup key as)) str curry-tools-v3.3.0/cpm/vendor/io-extra/src/System/IOExts.pakcs.pl000066400000000000000000000016711377556325500247230ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Prolog implementation of builtins of module System.IOExts: % :- dynamic globalAssoc/2. 'System.IOExts.prim_setAssoc'(Key,Val,'Prelude.()') :- string2Atom(Key,KeyA), (retract(globalAssoc(KeyA,_)) -> true ; true), assertz(globalAssoc(KeyA,Val)), !. 'System.IOExts.prim_getAssoc'(Key,R) :- string2Atom(Key,KeyA), (globalAssoc(KeyA,Val) -> R='Prelude.Just'(Val) ; R='Prelude.Nothing'), !. % shell command execution: 'System.IOExts.prim_execCmd'(CmdString,'Prelude.(,,)'(StdIn,StdOut,StdErr)) :- string2Atom(CmdString,Cmd), execCommand(Cmd,StdIn,StdOut,StdErr). % shell command execution: 'System.IOExts.prim_connectToCmd'(CmdString, '$stream'('$inoutstream'(StdOut,StdIn))) :- string2Atom(CmdString,Cmd), execCommand(Cmd,StdIn,StdOut,std). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% curry-tools-v3.3.0/cpm/vendor/io-extra/test/000077500000000000000000000000001377556325500210125ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/io-extra/test/TestConnect.curry000066400000000000000000000005061377556325500243320ustar00rootroot00000000000000-- Testing operations from library IOExts: import System.IO import System.IOExts import Test.Prop -- Execute shell command show the first output line of its execution: getExec cmd = do hdl <- connectToCommand cmd s <- hGetLine hdl hClose hdl return s testConnectToCommand = (getExec "echo abcde") `returns` "abcde" curry-tools-v3.3.0/cpm/vendor/json/000077500000000000000000000000001377556325500172545ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/json/README.md000066400000000000000000000021541377556325500205350ustar00rootroot00000000000000# JSON This package provides data types, a parser and a pretty printer for [JSON][1]. ## Representing JSON values in Curry A JSON value can be a primitive, i.e. `true`, `false`, `null`, a string or a number, an array of JSON values or an object mapping strings to JSON values. In Curry, a JSON value is represented by the data type `JValue` from the `JSON.Data` module: ```haskell data JValue = JTrue | JFalse | JNull | JString String | JNumber Float | JArray [JValue] | JObject [(String, JValue)] ``` ## Parsing JSON strings `parseJSON` from `JSON.Parser` can be used to parse a JSON string into a `JValue`: ```haskell > parseJSON "{ \"hello\": [\"world\", \"kiel\"] }" Just (JObject [("hello", JArray [JString "world", JString "kiel"])]) ``` ## Printing JSON strings `ppJSON` from `JSON.Pretty` will turn a `JValue` into a pretty printed string. If you want more control over the layout of the resulting string, you can use `ppJValue` from the same value to obtain a `Doc` for Curry's `Pretty` module from a `JValue`. [1]: http://www.json.org curry-tools-v3.3.0/cpm/vendor/json/package.json000066400000000000000000000013141377556325500215410ustar00rootroot00000000000000{ "name": "json", "version": "3.0.0", "author": "Jonas Oberschweiber ", "maintainer": "Michael Hanus ", "synopsis": "A JSON library for Curry", "category": [ "Data", "Web" ], "dependencies": { "det-parse": ">= 3.0.0, < 4.0.0", "wl-pprint": ">= 3.0.0, < 4.0.0", "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": ["JSON.Data", "JSON.Parser", "JSON.Pretty"], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/json.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/json/src/000077500000000000000000000000001377556325500200435ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/json/src/JSON/000077500000000000000000000000001377556325500206145ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/json/src/JSON/Data.curry000066400000000000000000000011441377556325500225530ustar00rootroot00000000000000module JSON.Data (JValue (..)) where --- A JSON value. --- --- @cons JTrue - true --- @cons JFalse - false --- @cons JNull - null, i.e. a missing value --- @cons JString - a JSON string --- @cons JNumber - a JSON number (numbers are always floats in JSON) --- @cons JArray - a JSON array, represented by a list of JValues --- @cons JObject - a JSON object, represented by a map from Strings to JValues data JValue = JTrue | JFalse | JNull | JString String | JNumber Float | JArray [JValue] | JObject [(String, JValue)] deriving (Eq,Show) curry-tools-v3.3.0/cpm/vendor/json/src/JSON/Parser.curry000066400000000000000000000155261377556325500231470ustar00rootroot00000000000000module JSON.Parser (parseJSON) where import JSON.Data import Data.Char import DetParse import Test.Prop import Prelude hiding (some, empty, (<|>), (<$>), (<*>), (<*), (*>)) --- Parses a JSON string into a JValue. Returns Nothing if the string could not --- be parsed. parseJSON :: String -> Maybe JValue parseJSON = parse pJValue --- Parser for a JValue pJValue :: Parser JValue pJValue = pTrue <|> pFalse <|> pNull <|> pJString <|> pJNumber <|> pArray <|> pObject pObject :: Parser JValue pObject = JObject <$> (char '{' *> pWhitespace *> pObject' <* pWhitespace <* char '}' <* pWhitespace) <|> JObject <$> (char '{' *> pWhitespace *> char '}' *> yield []) pObject' :: Parser [(String, JValue)] pObject' = (:) <$> (pWhitespace *> pKeyValuePair) <*> (pWhitespace *> char ',' *> pObject' <|> yield []) pKeyValuePair :: Parser (String, JValue) pKeyValuePair = (,) <$> pString <*> (pWhitespace *> char ':' *> pWhitespace *> pJValue) test_pObject_empty :: Prop test_pObject_empty = parse pObject "{}" -=- Just (JObject []) test_pObject_onlyStringKeys :: Prop test_pObject_onlyStringKeys = parse pObject "{1: 2}" -=- Nothing test_pObject_simple :: Prop test_pObject_simple = parse pObject "{\"test\": 1, \"test2\": false}" -=- Just (JObject [("test", JNumber 1.0), ("test2", JFalse)]) test_pObject_whitespace :: Prop test_pObject_whitespace = parse pObject "{\n \"test\": 1,\n \"test2\": false\n}" -=- Just (JObject [("test", JNumber 1.0), ("test2", JFalse)]) test_pObject_nested :: Prop test_pObject_nested = parse pObject "{\"test\": {\"hello\": \"world\"}}" -=- Just (JObject [("test", JObject [("hello", JString "world")])]) pArray :: Parser JValue pArray = JArray <$> (char '[' *> pWhitespace *> pArray' <* pWhitespace <* char ']') <|> JArray <$> (char '[' *> pWhitespace *> char ']' *> yield []) pArray' :: Parser [JValue] pArray' = (:) <$> (pWhitespace *> pJValue) <*> ((pWhitespace *> char ',' *> pArray') <|> yield []) test_pArray_empty :: Prop test_pArray_empty = parse pArray "[]" -=- Just (JArray []) test_pArray_single :: Prop test_pArray_single = parse pArray "[1]" -=- Just (JArray [JNumber 1.0]) test_pArray_multi :: Prop test_pArray_multi = parse pArray "[true, false, null]" -=- Just (JArray [JTrue, JFalse, JNull]) test_pArray_nested :: Prop test_pArray_nested = parse pArray "[true, [false], [[null]]]" -=- Just (JArray [JTrue, JArray [JFalse], JArray [JArray [JNull]]]) pWhitespace :: Parser () pWhitespace = char ' ' *> pWhitespace <|> char '\n' *> pWhitespace <|> char '\r' *> pWhitespace <|> char '\t' *> pWhitespace <|> empty pTrue :: Parser JValue pTrue = word "true" *> yield JTrue pFalse :: Parser JValue pFalse = word "false" *> yield JFalse pNull :: Parser JValue pNull = word "null" *> yield JNull pJString :: Parser JValue pJString = JString <$> pString pString :: Parser String pString = char '"' *> pCharSequence <* char '"' pCharSequence :: Parser String pCharSequence = (++) <$> (char '\\' *> pEscaped) <*> pCharSequence <|> (:) <$> check (\c -> c /= '"' && c /= '\\') anyChar <*> pCharSequence <|> yield "" pEscaped :: Parser String pEscaped = char '"' *> yield "\"" <|> char '\\' *> yield "\\" <|> char '/' *> yield "/" <|> char 'b' *> yield "\b" <|> char 'f' *> yield "\f" <|> char 'n' *> yield "\n" <|> char 'r' *> yield "\r" <|> char 't' *> yield "\t" <|> ((:[]) . chr) <$> (char 'u' *> pTwoByteHex) pTwoByteHex :: Parser Int pTwoByteHex = hexToInt <$> ((:) <$> pHexDigit <*> ((:) <$> pHexDigit <*> ((:) <$> pHexDigit <*> ((:[]) <$> pHexDigit)))) where pHexDigit = check isHexDigit anyChar hexToInt :: String -> Int hexToInt s = foldl1 ((+).(16*)) (map digitToInt s) test_pCharSequence_simple :: Prop test_pCharSequence_simple = parse pCharSequence "test" -=- Just "test" test_pCharSequence_noDoubleQuote :: Prop test_pCharSequence_noDoubleQuote = parse pCharSequence "te\"st" -=- Nothing test_pCharSequence_noStandaloneBackslash :: Prop test_pCharSequence_noStandaloneBackslash = parse pCharSequence "He\\world" -=- Nothing test_pCharSequence_escapedDoubleQuote :: Prop test_pCharSequence_escapedDoubleQuote = parse pCharSequence "Hello \\\"World\\\"" -=- Just "Hello \"World\"" test_pCharSequence_escapedBackslash :: Prop test_pCharSequence_escapedBackslash = parse pCharSequence "He\\\\world" -=- Just "He\\world" test_pCharSequence_escapedSlash :: Prop test_pCharSequence_escapedSlash = parse pCharSequence "He\\/world" -=- Just "He/world" test_pCharSequence_escapedBackspace :: Prop test_pCharSequence_escapedBackspace = parse pCharSequence "He\\bworld" -=- Just "He\bworld" test_pCharSequence_escapedFormFeed :: Prop test_pCharSequence_escapedFormFeed = parse pCharSequence "He\\fworld" -=- Just "He\fworld" test_pCharSequence_escapedNewline :: Prop test_pCharSequence_escapedNewline = parse pCharSequence "He\\nworld" -=- Just "He\nworld" test_pCharSequence_escapedCarriageReturn :: Prop test_pCharSequence_escapedCarriageReturn = parse pCharSequence "He\\rworld" -=- Just "He\rworld" test_pCharSequence_escapedTab :: Prop test_pCharSequence_escapedTab = parse pCharSequence "He\\tworld" -=- Just "He\tworld" test_pCharSequence_twoEscapes :: Prop test_pCharSequence_twoEscapes = parse pCharSequence "He\\r\\nWorld" -=- Just "He\r\nWorld" test_pCharSequence_escapedUnicodeChar :: Prop test_pCharSequence_escapedUnicodeChar = parse pCharSequence "Hello \\u2603 World" -=- Just "Hello ☃ World" test_pCharSequence_escapedUnicodeRequiresFourDigits :: Prop test_pCharSequence_escapedUnicodeRequiresFourDigits = parse pCharSequence "Hello \\u26 World" -=- Nothing test_pString_simple :: Prop test_pString_simple = parse pString "\"Hello, World\"" -=- Just "Hello, World" test_pString_complex :: Prop test_pString_complex = parse pString "\"Hello \\r\\n \\u2603 World\"" -=- Just "Hello \r\n ☃ World" pJNumber :: Parser JValue pJNumber = JNumber <$> pNumber pNumber :: Parser Float pNumber = (0-) <$> (char '-' *> pPositiveFloat) <|> pPositiveFloat -- number without decimal point, decimal digits, base 10 exponent toFloat :: Int -> Int -> Int -> Float toFloat n d e = (fromInt n) * (10 ^ (d + e)) pPositiveFloat :: Parser Float pPositiveFloat = (uncurry toFloat) <$> pWithDecimalPoint <*> pExponent pExponent :: Parser Int pExponent = (char 'e' <|> char 'E') *> (char '-' *> yield negate <|> char '+' *> yield id <|> yield id) <*> pInt yield 0 pWithDecimalPoint :: Parser (Int, Int) pWithDecimalPoint = combine <$> some pDigit <*> (char '.' *> some pDigit <|> yield "") where s2i cs = foldl1 ((+).(10*)) (map (\c' -> ord c' - ord '0') cs) combine n d = (s2i (n ++ d), negate $ length d) pInt :: Parser Int pInt = (\cs -> foldl1 ((+).(10*)) (map (\c' -> ord c' - ord '0') cs)) <$> some pDigit pDigit :: Parser Char pDigit = check isDigit anyChar curry-tools-v3.3.0/cpm/vendor/json/src/JSON/Pretty.curry000066400000000000000000000014361377556325500231750ustar00rootroot00000000000000module JSON.Pretty (ppJSON, ppJValue) where import JSON.Data import Text.Pretty --- Pretty print a JSON value with the default options of Curry's Pretty module. ppJSON :: JValue -> String ppJSON j = pPrint (ppJValue j) --- Turn a JSON value into a Doc from Curry's Pretty module. ppJValue :: JValue -> Doc ppJValue JTrue = text "true" ppJValue JFalse = text "false" ppJValue JNull = text "null" ppJValue (JNumber f) = float f ppJValue (JString s) = text $ show s ppJValue (JArray vs) = ppJArray vs ppJValue (JObject ps) = ppJObject ps ppJArray :: [JValue] -> Doc ppJArray vs = listSpaced $ map ppJValue vs ppJObject :: [(String, JValue)] -> Doc ppJObject ps = (nest 2 $ lbrace $$ vsep (punctuate comma $ map ppKVP ps)) $$ rbrace where ppKVP (k, v) = (text $ show k) <> colon <+> ppJValue v curry-tools-v3.3.0/cpm/vendor/opt-parse/000077500000000000000000000000001377556325500202155ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/opt-parse/README.md000066400000000000000000000131261377556325500214770ustar00rootroot00000000000000# opt-parse - An Advanced Command Line Parser for Curry opt-parse is an advanced command line parser for Curry. It features support for options with and without values (i.e. flags), positional arguments and commands that can define their own sub-parsers. It borrows heavily from Paolo Capriotti's Haskell package [optparse-applicative](1) and Curry's [GetOpt](2) module. You use opt-parse by declaring a *parser specification* and then running that parser specification on a command line. A parser specification is made up from individual parsers for options, flags, position arguments and commands. Each individual parser results in an arbitrary value, though all parsers in a parser specification must result in values of the same type. ## A Simple Example A simple command line parser example might look like this: ```haskell cmdParser = optParser $ option (\s -> readInt s) ( long "number" <> short "n" <> metavar "NUMBER" <> help "The number." ) <.> arg (\s -> readInt s) ( metavar "NEXT-NUMBER" <> help "The next number." ) main = do args <- getArgs parseResult <- return $ parse (intercalate " " args) cmdParser "test" putStrLn $ case parseResult of Left err -> err Right v -> show v ``` This defines a parser that supports a `number` option and requires a single positional argument. Both values are parsed into an integer. The `parse` function is called with the command line as a single string, the parser specification and the name of the current program. It results in either a `Left` if there was a parse error or a `Right` with the list of parse results. Running `test --help` prints out usage information: ``` test NEXT-NUMBER -n, --number NUMBER The number. NEXT-NUMBER The next number. ``` If we run `test --number=5 2`, we get the list of parse results: ``` [2, 5] ``` `metavar` and `help` are modifiers that can be applied to any argument parser, command, option, flag or positional. The `help` text is what is printed in the detailed usage output, the `metavar` is the placeholder to be printed for the argument's value in the usage output. The `optional` modifier can also be applied to all argument types, although flags and options are already optional by default. The `long` and `short` modifiers are specific to options and flags. Right now, the result of our parser is a list of the individual parse results. Usually, we want our parse result to be a single value, for example a Curry data type such as this: ```haskell data Options = Options { number :: Int , nextNumber :: Int } ``` To parse a command line to an `Options` value, we return functions from our individual parsers instead of integers: ```haskell cmdParser = optParser $ option (\s a -> a { number = readInt s }) ( long "number" <> short "n" <> metavar "NUMBER" <> help "The number." ) <.> arg (\s a -> a { nextNumber = readInt s }) ( metavar "NEXT-NUMBER" <> help "The next number." ) ``` The result of a successful parse will now be a list of functions that change an `Options` value. We can fold this list onto a default `Options`: ```haskell applyParse :: [Options -> Options] -> Options applyParse fs = foldl (flip apply) defaultOpts fs where defaultOpts = Options 0 0 main = do args <- getArgs parseResult <- return $ parse (intercalate " " args) cmdParser "test" putStrLn $ case parseResult of Left err -> err Right v -> show $ applyParse v ``` Executing `test --number=5 1` results in: ``` (Options 5 1) ``` ## Positional Arguments and Flags Positional arguments can be created via `arg` and `rest`. `arg` is a normal positional argument which can be optional or mandatory. `rest` is a positional argument that consumes the rest of the command line as-is. Positional arguments are expected in the order they occur in the parser definition. `flag` can be used to create flag arguments. A flag argument expects no value. ## Commands In addition to options, flags and positional arguments, opt-parse also includes support for commands. A command is a positional argument that dispatches to sub-parsers depending on its value. If we have a calculator program that supports addition and multiplication, we could model its command line interface using commands: ```haskell data Options = Options { operation :: Int -> Int -> Int , operandA :: Int , operandB :: Int } cmdParser = optParser $ commands (metavar "OPERATION") ( command "add" (help "Adds two numbers.") (\a -> a { operation = (+) }) ( arg (\s a -> a { operandA = readInt s } ( metavar "OPERAND-A" <> help "The first operand." ) <.> arg (\s a -> a { operandB = readInt s } ( metavar "OPERAND-B" <> help "The second operand." ) ) <|> command "mult" (help "Multiplies two numbers.") (\a -> a { operation = (*) }) ( arg (\s a -> a { operandA = readInt s } ( metavar "OPERAND-A" <> help "The first operand." ) <.> arg (\s a -> a { operandB = readInt s } ( metavar "OPERAND-B" <> help "The second operand." ) ) ) ``` The corresponding usage output for `test` run with no further arguments is: ``` test OPERATION Options for OPERATION add Adds two numbers. mult Multiplies two numbers. ``` If we choose an operation, e.g. `add`, the output is: ``` test add OPERAND-A OPERAND-B OPERAND-A The first operand. OPERAND-B The second operand. ``` [1]: https://hackage.haskell.org/package/optparse-applicative [2]: https://www-ps.informatik.uni-kiel.de/kics2/lib/GetOpt.html curry-tools-v3.3.0/cpm/vendor/opt-parse/package.json000066400000000000000000000013121377556325500225000ustar00rootroot00000000000000{ "name": "opt-parse", "version": "3.0.0", "author": "Jonas Oberschweiber ", "category": [ "Parsing" ], "synopsis": "An option parser for Curry", "dependencies": { "det-parse": ">= 3.0.0, < 4.0.0", "boxes" : ">= 3.0.0, < 4.0.0", "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "OptParse" ], "documentation": { "src-dir": ".", "main": "README.md" }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/opt-parse.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/opt-parse/src/000077500000000000000000000000001377556325500210045ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/opt-parse/src/OptParse.curry000066400000000000000000000352641377556325500236410ustar00rootroot00000000000000module OptParse ( Arg , Parser , ParseSpec , ArgProps , OptProps , Mod , long , short , optional , metavar , help , (<>) , (<.>) , (<|>) , option , arg , rest , flag , command , commands , optParser , printUsage , renderUsage , parse ) where import Debug.Trace import Data.Char (isAscii) import Data.List (intercalate) import qualified DetParse as P import qualified Boxes as B --- A command line argument. Used to represent a parsed command line. --- --- @cons Flag - a flag, e.g. `-d` or `--enable-debug` --- @cons Val - a simple value --- @cons FlagWithValue - an option, e.g. `-v debug` or `--verbosity=debug` data Arg = Flag String | Val String | FlagWithValue String String --- A partial command line parser. --- --- @cons OptP - parses an option with a value --- @cons FlagP - parses a flag --- @cons ArgP - parses a positional argument --- @cons RestP - a parses that consumes the rest --- @cons CmdP - a parser that branches out to command sub-parsers data Parser a = OptP ArgProps OptProps (String -> a) | FlagP ArgProps OptProps a | ArgP ArgProps (String -> a) | RestP ArgProps (String -> a) | CmdP ArgProps [(String, ArgProps, a, ParseSpec a)] --- A parser specification. A collection of parsers. data ParseSpec a = ParseSpec [Parser a] --- Properties that for all parser types. data ArgProps = ArgProps { metavarName :: String , helpText :: Maybe String , argOptional :: Bool } --- Properties for option/flag parsers. data OptProps = OptProps { longName :: String , shortName :: String } --- Modifiers for argument and option properties. data Mod = Mod { optMod :: OptProps -> OptProps , argMod :: ArgProps -> ArgProps } --- Get argument properties from a parser. argProps :: Parser a -> ArgProps argProps (OptP a _ _) = a argProps (FlagP a _ _) = a argProps (ArgP a _) = a argProps (RestP a _) = a argProps (CmdP a _) = a --- Default argument properties. defaultArgProps :: ArgProps defaultArgProps = ArgProps "" Nothing False --- Default option properties. defaultOptProps :: OptProps defaultOptProps = OptProps "" "" --- Identity modifiers. idm :: Mod idm = Mod id id --- Set the long name of an option. long :: String -> Mod long s = Mod (\o -> o { longName = s }) id --- Set the short name of an option. short :: String -> Mod short s = Mod (\o -> o { shortName = s }) id --- Set the optional flag of an argument. optional :: Mod optional = Mod id (\a -> a { argOptional = True }) --- Set the metavar of an argument. The metavar is used to print usage --- information. metavar :: String -> Mod metavar s = Mod id (\a -> a { metavarName = s }) --- Set the help text of an argument. Used to print usage information. help :: String -> Mod help s = Mod id (\a -> a { helpText = Just s }) --- Combine two modifiers. (<>) :: Mod -> Mod -> Mod (Mod o1 a1) <> (Mod o2 a2) = Mod (o2 . o1) (a2 . a1) --- Create an option. --- --- @param f function that converts the parsed value into a parse result --- @param m modifiers for this argument option :: (String -> a) -> Mod -> [Parser a] option f (Mod o a) = [OptP (a defaultArgProps) (o defaultOptProps) f] --- Create a positional argument. --- --- @param f function that converts the parsed value into a parse result --- @param m modifiers for this argument arg :: (String -> a) -> Mod -> [Parser a] arg f (Mod _ a) = [ArgP (a defaultArgProps) f] --- Create an argument that consumes the rest of the command line. --- --- @param f function that converts the parsed value into a parse result --- @param m modifiers for this argument rest :: (String -> a) -> Mod -> [Parser a] rest f (Mod _ a) = [RestP (a defaultArgProps) f] --- Create a flag. --- --- @param a result of the parser --- @param m modifiers for this argument flag :: a -> Mod -> [Parser a] flag f (Mod o a) = [FlagP (a defaultArgProps) (o defaultOptProps) f] infixl 4 <.> infixl 5 <|> --- Combine two arguments. (<.>) :: [a] -> [a] -> [a] (<.>) = (++) --- Combine command sub parsers. (<|>) :: [a] -> [a] -> [a] (<|>) = (++) --- Create a sub-parser for a command. Must be used with `commands`. --- --- @param n the name of the command --- @param m modifiers for this command --- @param a the result of this parse --- @param ps parsers for the rest of the command line for this command command :: String -> Mod -> a -> [Parser a] -> [(String, ArgProps, a, ParseSpec a)] command n (Mod _ a) d ps = [(n, a defaultArgProps, d, ParseSpec ps)] --- Create a parse spec from a list of parsers. optParser :: [Parser a] -> ParseSpec a optParser = ParseSpec --- Create a command parser. --- --- @param m modifiers for this command --- @param cs command sub-parsers, created by `command` commands :: Mod -> [(String, ArgProps, a, ParseSpec a)] -> [Parser a] commands (Mod _ a) cmds = [CmdP (a defaultArgProps) cmds] margin :: Int margin = 5 --- Print usage information for a command line parser specification. --- --- @param p the name of the current program --- @param c the maximum number of columns to use --- @param p the parser specification printUsage :: String -> Int -> ParseSpec a -> IO () printUsage prog w spec = B.printBox $ usageBox prog w spec --- Render usage information to a string. --- --- @param p the name of the current program --- @param c the maximum number of columns to use --- @param p the parser specification renderUsage :: String -> Int -> ParseSpec a -> String renderUsage prog w spec = B.render $ usageBox prog w spec --- Create a box for usage information. --- --- @param p the name of the current program --- @param c the maximum number of columns to use --- @param p the parser specification usageBox :: String -> Int -> ParseSpec a -> B.Box usageBox prog w (ParseSpec ps) = usageLine B./+/ optBox B./+/ argBox B./+/ cmdsBox where opts = filter isOpt ps args = filter isArg ps cmds = filter isCmd ps formattedArgs = map formatArgForUsage $ filter (not . isOpt) ps usageLine = B.text prog B.<+> (B.text $ intercalate " " $ formattedArgs) maxOptLen = foldl max 0 $ map optLen opts optBox = B.table (map optRow opts) [ maxOptLen + margin, w - maxOptLen - margin] maxArgLen = foldl max 0 $ map posnLen args argBox = B.table (map argRow args) [ maxArgLen + margin, w - maxArgLen - margin] maxCmdsLen = foldl max 0 $ map cmdsLen cmds cmdsBox = B.vcat B.left $ (map (cmdsRows maxCmdsLen w) cmds) --- Render an argument for the usage line. formatArgForUsage :: Parser a -> String formatArgForUsage p = wrap $ argMetavar p where wrap s = if isOptional p then "[" ++ s ++ "]" else s --- Render detailed help for an option/flag. optRow :: Parser a -> [String] optRow (OptP a o _) = [sh ++ " " ++ lo ++ " " ++ metavarName a, hlp] where sh = "-" ++ (shortName o) ++ (if longName o /= "" then "," else "") lo = "--" ++ (longName o) hlp = case helpText a of Nothing -> "" Just h -> h optRow (FlagP a o _) = [sh ++ " " ++ lo ++ " " ++ metavarName a, hlp] where sh = "-" ++ (shortName o) ++ (if longName o /= "" then "," else "") lo = "--" ++ (longName o) hlp = case helpText a of Nothing -> "" Just h -> h optRow (ArgP _ _) = error "OptParse.optRow: called on ArgP" optRow (RestP _ _) = error "OptParse.optRow: called on RestP" optRow (CmdP _ _) = error "OptParse.optRow: called on CmdP" --- Render detailed help for a positional argument. argRow :: Parser a -> [String] argRow (ArgP a _) = [metavarName a, hlp] where hlp = case helpText a of Nothing -> "" Just h -> h argRow (RestP a _) = [metavarName a, hlp] where hlp = case helpText a of Nothing -> "" Just h -> h argRow (OptP _ _ _) = error "OptParse.argRow: called on OptP" argRow (FlagP _ _ _) = error "OptParse.argRow: called on FlagP" argRow (CmdP _ _) = error "OptParse.argRow: called on CmdP" --- Render detailed help for a command parser. cmdsRows :: Int -> Int -> Parser a -> B.Box cmdsRows max w (CmdP a cmds) = hdr B.// tbl where hdr = B.text $ "Options for " ++ (metavarName a) tbl = B.table (map cmdRow cmds) [max + margin, w - max - margin] cmdRow (n, x, _, _) = [n, getHelp x] getHelp x = case helpText x of Nothing -> "" Just h -> h cmdsRows _ _ (OptP _ _ _) = error "OptParse.cmdsRows: called on OptP" cmdsRows _ _ (FlagP _ _ _) = error "OptParse.cmdsRows: called on FlagP" cmdsRows _ _ (ArgP _ _) = error "OptParse.cmdsRows: called on ArgP" cmdsRows _ _ (RestP _ _) = error "OptParse.cmdsRows: called on RestP" --- Calculate maximum command length for a command parser. cmdsLen :: Parser a -> Int cmdsLen (CmdP _ cmds) = foldl max 0 $ map cmdsLen' cmds where cmdsLen' (n, _, _, _) = length n cmdsLen (ArgP _ _) = 0 cmdsLen (OptP _ _ _) = 0 cmdsLen (FlagP _ _ _) = 0 cmdsLen (RestP _ _) = 0 --- Length of a positional argument name. posnLen :: Parser a -> Int posnLen (ArgP a _) = length (metavarName a) posnLen (CmdP _ _) = 0 posnLen (OptP _ _ _) = 0 posnLen (FlagP _ _ _) = 0 posnLen (RestP _ _) = 0 optLen' :: ArgProps -> OptProps -> Int optLen' a o = length (shortName o) + 2 + length (longName o) + 3 + length (metavarName a) + 2 --- Length needed to represent a option/flag detailed help. optLen :: Parser a -> Int optLen (OptP a o _) = optLen' a o optLen (FlagP a o _) = optLen' a o optLen (ArgP _ _) = 0 optLen (CmdP _ _) = 0 optLen (RestP _ _) = 0 --- Parses a command line via a parser spec. --- --- @param l the command line --- @param s the parser spec --- @param p the name of the current program parse :: String -> ParseSpec a -> String -> Either String [a] parse argv spec prog = case P.parse pArgs argv of Nothing -> Left $ parseError prog spec "Couldn't parse command line!" Just as -> parseArgs as spec prog --- Renders parsed parts of a command line back to a string. renderCommandLine :: [Arg] -> String renderCommandLine [] = [] renderCommandLine ((Val s):as) = s ++ " " ++ (renderCommandLine as) renderCommandLine ((FlagWithValue n v):as) = "--" ++ n ++ "=" ++ v ++ " " ++ (renderCommandLine as) renderCommandLine ((Flag n):as) = "--" ++ n ++ " " ++ (renderCommandLine as) --- Further parses a parsed command line using a parser spec. --- --- @param as parsed command line --- @param s parser spec --- @param p name of the current program parseArgs :: [Arg] -> ParseSpec a -> String -> Either String [a] parseArgs args sp@(ParseSpec specs) prog = parse' args rst [] where opts = filter isOpt specs rst = filter (not . isOpt) specs parse' ((Val s):as) (p:ps) xs = case p of ArgP _ f -> parse' as ps ((f s):xs) RestP _ f -> parse' [] (p:ps) ((f $ renderCommandLine ((Val s):as)):xs) CmdP _ cmds -> case findCommand s cmds of Nothing -> Left $ parseError prog sp $ "Unknown command '" ++ s ++ "'." Just (cmd, _, d, spec) -> case parseArgs as spec (prog ++ " " ++ cmd) of Left e -> Left e Right xs' -> Right $ xs ++ [d] ++ xs' OptP _ _ _ -> error "OptP in list of positional candidates" FlagP _ _ _ -> error "FlagP in list of positional candidates" parse' ((FlagWithValue n v):as) ps xs = case filter (optMatches n) opts of [] -> Left $ parseError prog sp $ "Unknown option '" ++ n ++ "'." ((OptP _ _ f):_) -> parse' as ps ((f v):xs) ((ArgP _ _):_) -> error $ "OptParse.parseArgs: ArgP matches opt " ++ n ((FlagP _ _ _):_) -> error $ "OptParse.parseArgs: FlagP matches opt " ++ n ((RestP _ _):_) -> error $ "OptParse.parseArgs: RestP matches opt " ++ n ((CmdP _ _):_) -> error $ "OptParse.parseArgs: CmdP matches opt " ++ n parse' ((Flag n):as) ps xs = if n == "h" || n == "help" then Left $ parseError prog sp "" else case filter (optMatches n) opts of [] -> Left $ parseError prog sp $ "Unknown option '" ++ n ++ "'." ((OptP _ _ f):_) -> case as of ((Val v):as') -> parse' as' ps ((f v):xs) _ -> Left $ parseError prog sp $ "Option '" ++ n ++ "' expects a value." ((FlagP _ _ f):_) -> parse' as ps (f:xs) ((ArgP _ _):_) -> error $ "OptParse.parseArgs: ArgP matches flag " ++ n ((RestP _ _):_) -> error $ "OptParse.parseArgs: RestP matches flag " ++ n ((CmdP _ _):_) -> error $ "OptParse.parseArgs: CmdP matches flag " ++ n parse' ((Val _):as) [] xs = parse' as [] xs parse' [] (p:ps) xs = if isOptional p then parse' [] ps xs else Left $ parseError prog sp $ "Expected " ++ (argMetavar p) ++ ", but there are no arguments left." parse' [] [] xs = Right xs --- Renders a parse error. --- --- @param p name of the current program --- @param s parser spec --- @param e error that occured parseError :: String -> ParseSpec a -> String -> String parseError prog spec err = renderUsage prog 80 spec ++ "\n" ++ err --- Gets the metavar from a parser. argMetavar :: Parser a -> String argMetavar = metavarName . argProps --- Does an option/flag match a name? optMatches :: String -> Parser a -> Bool optMatches _ (ArgP _ _) = False optMatches _ (CmdP _ _) = False optMatches _ (RestP _ _) = False optMatches n (OptP _ o _) = n == (longName o) || n == (shortName o) optMatches n (FlagP _ o _) = n == (longName o) || n == (shortName o) --- Is the argument optional? isOptional :: Parser a -> Bool isOptional = argOptional . argProps --- Finds a command in a list of command specs. findCommand :: String -> [(String, ArgProps, a, ParseSpec a)] -> Maybe (String, ArgProps, a, ParseSpec a) findCommand s cmds = case cmd of [] -> Nothing (c:_) -> Just c where cmd = filter ((== s) . fst3) cmds fst3 (a, _, _, _) = a isOpt :: Parser a -> Bool isOpt (OptP _ _ _) = True isOpt (ArgP _ _) = False isOpt (RestP _ _) = False isOpt (CmdP _ _) = False isOpt (FlagP _ _ _) = True isArg :: Parser a -> Bool isArg (OptP _ _ _) = False isArg (ArgP _ _) = True isArg (RestP _ _) = True isArg (CmdP _ _) = False isArg (FlagP _ _ _) = False isCmd :: Parser a -> Bool isCmd (OptP _ _ _) = False isCmd (ArgP _ _) = False isCmd (RestP _ _) = False isCmd (CmdP _ _) = True isCmd (FlagP _ _ _) = False pArgs :: P.Parser [Arg] pArgs = (:) P.<$> pArg P.<*> (pWhitespace P.*> pArgs P.<|> P.yield []) pWhitespace :: P.Parser Char pWhitespace = P.check (== ' ') P.anyChar pArg :: P.Parser Arg pArg = Flag P.<$> pFlagNoValue P.<|> pFlagValue P.<|> Val P.<$> P.some pNonWhitespace pFlagValue :: P.Parser Arg pFlagValue = FlagWithValue P.<$> (P.char '-' P.*> P.char '-' P.*> P.some pNonWhitespace) P.<*> (P.char '=' P.*> P.some pNonWhitespace) pFlagNoValue :: P.Parser String pFlagNoValue = P.char '-' P.*> ((P.char '-' P.*> P.some pNonWhiteEqual) P.<|> pAsciiNonWhitespace) pNonWhiteEqual :: P.Parser Char pNonWhiteEqual = P.check f P.anyChar where f c = c /= ' ' && c /= '=' pNonWhitespace :: P.Parser Char pNonWhitespace = P.check (/= ' ') P.anyChar pAsciiNonWhitespace :: P.Parser String pAsciiNonWhitespace = (:[]) P.<$> P.check f P.anyChar where f c = isAscii c && c /= ' ' pAscii :: P.Parser Char pAscii = P.check isAscii P.anyChar curry-tools-v3.3.0/cpm/vendor/process/000077500000000000000000000000001377556325500177615ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/process/LICENSE000066400000000000000000000027351377556325500207750ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/process/package.json000066400000000000000000000011461377556325500222510ustar00rootroot00000000000000{ "name": "process", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "A library for process manipulation and information.", "category": [ "System" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.Process" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/process.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/process/src/000077500000000000000000000000001377556325500205505ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/process/src/System/000077500000000000000000000000001377556325500220345ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/process/src/System/Process.curry000066400000000000000000000021621377556325500245410ustar00rootroot00000000000000module System.Process ( getPID, system, exitWith, sleep ) where import System.Environment --- Returns the process identifier of the current Curry process. getPID :: IO Int getPID external --- Executes a shell command and return with the exit code of the command. --- An exit status of zero means successful execution. system :: String -> IO Int system cmd = prim_system $## escapedCmd where win = isWindows -- This is a work around for GHC ticket #5376 -- (http://hackage.haskell.org/trac/ghc/ticket/5376) escapedCmd = if win then '\"' : cmd ++ "\"" else cmd prim_system :: String -> IO Int prim_system external --- Terminates the execution of the current Curry program --- and returns the exit code given by the argument. --- An exit code of zero means successful execution. exitWith :: Int -> IO _ exitWith exitcode = prim_exitWith $# exitcode prim_exitWith :: Int -> IO _ prim_exitWith external --- The evaluation of the action (sleep n) puts the Curry process --- asleep for n seconds. sleep :: Int -> IO () sleep n = prim_sleep $# n prim_sleep :: Int -> IO () prim_sleep external curry-tools-v3.3.0/cpm/vendor/process/src/System/Process.kics2000066400000000000000000000035141377556325500244120ustar00rootroot00000000000000{-# LANGUAGE CPP, ForeignFunctionInterface, MultiParamTypeClasses #-} import Control.Exception as C (IOException, handle) import System.Exit (ExitCode (..), exitWith) import System.Process (system) #if defined(mingw32_HOST_OS) || defined(__MINGW32__) import System.Win32.Process #else import System.Posix.Process (getProcessID) #endif -- #endimport - do not remove this line! #if defined(mingw32_HOST_OS) || defined(__MINGW32__) foreign import stdcall unsafe "windows.h GetCurrentProcessId" getProcessID :: IO ProcessId #endif external_d_C_getPID :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_getPID _ _ = toCurry $ do pid <- getProcessID return (fromIntegral pid :: Int) external_d_C_prim_system :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_prim_system str _ _ = toCurry system str instance ConvertCurryHaskell Curry_Prelude.C_Int ExitCode where toCurry ExitSuccess = toCurry (0 :: Int) toCurry (ExitFailure i) = toCurry i fromCurry j = let i = fromCurry j :: Int in if i == 0 then ExitSuccess else ExitFailure i external_d_C_prim_exitWith :: Curry_Prelude.Curry a => Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO a external_d_C_prim_exitWith c _ _ = fromIO (exitWith (fromCurry c)) external_d_C_prim_sleep :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_sleep x _ _ = toCurry (\i -> system ("sleep " ++ show (i :: Int)) >> return ()) x -- TODO external_d_C_isWindows :: Cover -> ConstStore -> Curry_Prelude.C_Bool #if defined(mingw32_HOST_OS) || defined(__MINGW32__) external_d_C_isWindows _ _ = Curry_Prelude.C_True #else external_d_C_isWindows _ _ = Curry_Prelude.C_False #endif curry-tools-v3.3.0/cpm/vendor/process/src/System/Process.pakcs.pl000066400000000000000000000006021377556325500251050ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module System.Process: % 'System.Process.getPID'(Pid) :- currentPID(Pid). 'System.Process.prim_system'(S,Status) :- string2Atom(S,Cmd), shellCmd(Cmd,Status). 'System.Process.prim_exitWith'(Code,_) :- halt(Code). 'System.Process.prim_sleep'(S,'Prelude.()') :- sleepSeconds(S). curry-tools-v3.3.0/cpm/vendor/profiling/000077500000000000000000000000001377556325500202745ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/profiling/LICENSE000066400000000000000000000027351377556325500213100ustar00rootroot00000000000000Copyright (c) 2019, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/profiling/README.md000066400000000000000000000003751377556325500215600ustar00rootroot00000000000000profiling: Support for simple profiling ======================================= This package contains a simple profiling library containing operations to access run-time data. -------------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/profiling/examples/000077500000000000000000000000001377556325500221125ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/profiling/examples/benchmark_curry.curry000066400000000000000000000040071377556325500263570ustar00rootroot00000000000000-- Benchmarks for Curry systems import Debug.Profile -- Standard Prolog benchmark: naive reverse: append :: [a] -> [a] -> [a] append [] ys = ys append (x:xs) ys = x : append xs ys rev :: [a] -> [a] rev [] = [] rev (x:xs) = append (rev xs) [x] -- start naive reverse benchmark with a list of n elements and report -- space usage: nrev :: Int -> IO () nrev n = do let xs = [1 .. n] const (return ()) $!! xs profileSpaceNF (rev xs) -- LIPS = (n+1)*(n+2)/2/exec.time -- compute LIPS with naive reverse benchmark: nrevLIPS :: Int -> IO () nrevLIPS n = do let xs = [1 .. n] const (return ()) $!! xs garbageCollect garbageCollectorOff pi1 <- getProcessInfos const (return ()) $!! (rev xs) pi2 <- getProcessInfos garbageCollectorOn let rtime = maybe 0 id (lookup RunTime pi2) - maybe 0 id (lookup RunTime pi1) -- LIPS = (n+1)*(n+2)/2/exec.time putStrLn $ "LIPS: " ++ show ((n+1)*(n+2)*1000 `div` (2*rtime)) main :: IO () main = nrevLIPS 4000 -- Result on a Sun Ultra-10 (chevalblanc, with Sicstus/Fast code): -- 2.5 MLIPS for (nrev 1000) -- Result on a Linux-PC PIII/650Mhz (with Sicstus/Emulated code): -- 0.94 MLIPS for (nrev 1000) -- Result on a Linux-PC AMD Athlon/900Mhz (with Sicstus/Emulated code): -- 1.12 MLIPS for (nrev 1000) -- Result on a Linux-PC AMD Athlon/1.300Mhz (with Sicstus/Emulated code): -- 1.43 MLIPS for (nrev 1000) -- Result on a Linux-PC AMD Athlon XP 2600+/2.000Mhz (petrus, Sicstus/Emulated): -- 2.95 MLIPS for (nrev 1000) -- Result on a Linux-PC Intel Core i7-4790 / 3.6Ghz (belair, Sicstus 4.3/JIT): -- 13.45 MLIPS for (nrev 4000) -- Result on a Linux-PC Intel Core i7-7700 / 4.2Ghz (lascombes, Sicstus 4.4): -- 16.14 MLIPS for (nrev 4000) -- as nrev but double evaluation nrev2 :: Int -> IO () nrev2 n = do let xs = [1 .. n] const (return ()) $!! xs profileSpaceNF (rev xs, rev xs) -- as nrev2 but with test equality instead of unification: nrev3 :: Int -> IO () nrev3 n = do let xs = [1 .. n] const (return ()) $!! xs profileSpaceNF (rev xs == rev xs) curry-tools-v3.3.0/cpm/vendor/profiling/package.json000066400000000000000000000012061377556325500225610ustar00rootroot00000000000000{ "name": "profiling", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Simple profiling library with operations to access run-time data", "category": [ "Debugging" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Debug.Profile" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/profiling.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/profiling/src/000077500000000000000000000000001377556325500210635ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/profiling/src/Debug/000077500000000000000000000000001377556325500221115ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/profiling/src/Debug/Profile.curry000066400000000000000000000130421377556325500245770ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Simple profiling library with operations to access run-time data. --- --- @author Michael Hanus --- @version January 2019 ------------------------------------------------------------------------------ module Debug.Profile ( ProcessInfo(..), getProcessInfos, showMemInfo, printMemInfo , garbageCollectorOff, garbageCollectorOn, garbageCollect , profileTime, profileTimeNF, profileSpace, profileSpaceNF , getTimings, getTimingsNF ) where import Data.List (intersperse) --- The data type for representing information about the state --- of a Curry process. --- @cons RunTime - the run time in milliseconds --- @cons ElapsedTime - the elapsed time in milliseconds --- @cons Memory - the total memory in bytes --- @cons Code - the size of the code area in bytes --- @cons Stack - the size of the local stack for recursive functions in bytes --- @cons Heap - the size of the heap to store term structures in bytes --- @cons Choices - the size of the choicepoint stack --- @cons GarbageCollections - the number of garbage collections performed data ProcessInfo = RunTime | ElapsedTime | Memory | Code | Stack | Heap | Choices | GarbageCollections deriving (Eq,Show) --- Returns various informations about the current state of the Curry process. --- Note that the returned values are implementation dependent --- so that one should interpret them with care! --- --- Note for KiCS2 users: --- Since GHC version 7.x, one has to set the run-time option `-T` --- when this operation is used. This can be done by the kics2 command --- --- :set rts -T --- getProcessInfos :: IO [(ProcessInfo,Int)] getProcessInfos external --- Turns off the garbage collector of the run-time system (if possible). --- This could be useful to get more precise data of memory usage. garbageCollectorOff :: IO () garbageCollectorOff external --- Turns on the garbage collector of the run-time system (if possible). garbageCollectorOn :: IO () garbageCollectorOn external --- Invoke the garbage collector (if possible). --- This could be useful before run-time critical operations. garbageCollect :: IO () garbageCollect external --- Get a human readable version of the memory situation from the --- process infos. showMemInfo :: [(ProcessInfo,Int)] -> String showMemInfo infos = concat $ intersperse ", " $ formatItem Memory "Memory: " ++ formatItem Code "Code: " ++ formatItem Stack "Stack: " ++ formatItem Choices"Choices: " ++ formatItem Heap "Heap: " where formatItem i s = maybe [] (\v -> [s ++ showBytes v]) (lookup i infos) showBytes b = if b<10000 then show b else show (b `div` 1000) ++ " kb" --- Print a human readable version of the current memory situation --- of the Curry process. printMemInfo :: IO () printMemInfo = getProcessInfos >>= putStrLn . showMemInfo --- Print the time needed to execute a given IO action. profileTime :: IO a -> IO a profileTime action = do (result,rt,et,gc) <- getTimings action putStrLn $ "Run time: " ++ show rt ++ " msec." putStrLn $ "Elapsed time: " ++ show et ++ " msec." putStrLn $ "Garbage collections: " ++ show gc return result --- Returns the run time, elapsed time, and number of garbage collections --- needed to execute a given IO action. getTimings :: IO a -> IO (a,Int,Int,Int) getTimings action = do garbageCollect pi1 <- getProcessInfos result <- action pi2 <- getProcessInfos return (result, infoDiff pi1 pi2 RunTime, infoDiff pi1 pi2 ElapsedTime, infoDiff pi1 pi2 GarbageCollections) --- Evaluates the argument to normal form --- and print the time needed for this evaluation. profileTimeNF :: a -> IO () profileTimeNF exp = profileTime (seq (id $!! exp) (return ())) --- Evaluates the argument to normal form --- and returns the run time, elapsed time, and number of garbage collections --- needed for this evaluation. getTimingsNF :: a -> IO (Int,Int,Int) getTimingsNF exp = do (_,rt,et,gc) <- getTimings (seq (id $!! exp) (return ())) return (rt,et,gc) --- Print the time and space needed to execute a given IO action. --- During the executation, the garbage collector is turned off to get the --- total space usage. profileSpace :: IO a -> IO a profileSpace action = do garbageCollect garbageCollectorOff pi1 <- getProcessInfos result <- action pi2 <- getProcessInfos garbageCollectorOn putStrLn $ "Run time: " ++ (showInfoDiff pi1 pi2 RunTime) ++ " msec." putStrLn $ "Elapsed time: " ++ (showInfoDiff pi1 pi2 ElapsedTime) ++ " msec." putStrLn $ "Garbage collections: " ++ (showInfoDiff pi1 pi2 GarbageCollections) putStrLn $ "Heap usage: " ++ (showInfoDiff pi1 pi2 Heap) ++ " bytes" putStrLn $ "Stack usage: " ++ (showInfoDiff pi1 pi2 Stack) ++ " bytes" return result --- Evaluates the argument to normal form --- and print the time and space needed for this evaluation. --- During the evaluation, the garbage collector is turned off to get the --- total space usage. profileSpaceNF :: a -> IO () profileSpaceNF exp = profileSpace (seq (id $!! exp) (return ())) showInfoDiff :: [(ProcessInfo, Int)] -> [(ProcessInfo, Int)] -> ProcessInfo -> String showInfoDiff infos1 infos2 item = show (maybe 0 id (lookup item infos2) - maybe 0 id (lookup item infos1)) infoDiff :: [(ProcessInfo, Int)] -> [(ProcessInfo, Int)] -> ProcessInfo -> Int infoDiff infos1 infos2 item = maybe 0 id (lookup item infos2) - maybe 0 id (lookup item infos1) curry-tools-v3.3.0/cpm/vendor/profiling/src/Debug/Profile.kics2000066400000000000000000000040531377556325500244500ustar00rootroot00000000000000{-# LANGUAGE CPP, MultiParamTypeClasses #-} import System.CPUTime import System.Mem (performGC) #if __GLASGOW_HASKELL__ > 702 import GHC.Stats #endif -- #endimport - do not remove this line! instance ConvertCurryHaskell C_ProcessInfo C_ProcessInfo where toCurry = id fromCurry = id getProcessInfos :: IO [(C_ProcessInfo, Int)] #if __GLASGOW_HASKELL__ > 802 getProcessInfos = do stats <- getRTSStats return [ (C_RunTime , fromIntegral (mutator_cpu_ns stats * 1000)) , (C_ElapsedTime , fromIntegral (mutator_elapsed_ns stats * 1000)) , (C_Heap , fromIntegral (max_live_bytes stats)) , (C_Memory , fromIntegral (max_live_bytes stats)) , (C_GarbageCollections, fromIntegral (gcs stats)) ] #elif __GLASGOW_HASKELL__ > 702 getProcessInfos = do stats <- getGCStats return [ (C_RunTime , floor (mutatorCpuSeconds stats * 1000)) , (C_ElapsedTime , floor (mutatorWallSeconds stats * 1000)) , (C_Heap , fromIntegral (maxBytesUsed stats)) , (C_Memory , fromIntegral (maxBytesUsed stats)) , (C_GarbageCollections, fromIntegral (numGcs stats)) ] #else getProcessInfos = do t <- getCPUTime return [(C_RunTime, t `div` (10^9)] #endif external_d_C_getProcessInfos :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 C_ProcessInfo Curry_Prelude.C_Int)) external_d_C_getProcessInfos _ _ = toCurry getProcessInfos external_d_C_garbageCollectorOff :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_garbageCollectorOff _ _ = toCurry (return () :: IO ()) -- not supported external_d_C_garbageCollectorOn :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_garbageCollectorOn _ _ = toCurry (return () :: IO ()) -- not supported external_d_C_garbageCollect :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_garbageCollect _ _ = toCurry performGC curry-tools-v3.3.0/cpm/vendor/profiling/src/Debug/Profile.pakcs.pl000066400000000000000000000024711377556325500251520ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module Debug.Profile: % % return statistics about the PAKCS process: 'Debug.Profile.getProcessInfos'(Infos) :- (getCurrentGCs(GCs) -> I1=['Prelude.(,)'('Debug.Profile.GarbageCollections',GCs)] ; I1=[]), (getCurrentChoiceSize(Choice) -> I2=['Prelude.(,)'('Debug.Profile.Choices',Choice)|I1] ; I2=I1), (getCurrentHeapSize(Heap) -> I3=['Prelude.(,)'('Debug.Profile.Heap',Heap)|I2] ; I3=I2), (getCurrentStackSize(Stack) -> I4=['Prelude.(,)'('Debug.Profile.Stack',Stack)|I3] ; I4=I3), (getCurrentCodeSize(Code) -> I5=['Prelude.(,)'('Debug.Profile.Code',Code)|I4] ; I5=I4), (getCurrentMemorySize(Mem) -> I6=['Prelude.(,)'('Debug.Profile.Memory',Mem)|I5] ; I6=I5), (getElapsedTime(ETime) -> I7=['Prelude.(,)'('Debug.Profile.ElapsedTime',ETime)|I6] ; I7=I6), (getRunTime(RTime) -> I8=['Prelude.(,)'('Debug.Profile.RunTime',RTime)|I7] ; I8=I7), Infos = I8. % turn on garbage collector: 'Debug.Profile.garbageCollectorOn'('Prelude.()') :- garbageCollectorOn. % turn off garbage collector: 'Debug.Profile.garbageCollectorOff'('Prelude.()') :- garbageCollectorOff. % turn off garbage collector: 'Debug.Profile.garbageCollect'('Prelude.()') :- garbageCollect. curry-tools-v3.3.0/cpm/vendor/propertyfile/000077500000000000000000000000001377556325500210275ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/propertyfile/LICENSE000066400000000000000000000027351377556325500220430ustar00rootroot00000000000000Copyright (c) 2018, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/propertyfile/README.md000066400000000000000000000005551377556325500223130ustar00rootroot00000000000000propertyfile ============ This package provides a library to read and update files containing properties or configurations in the usual equational syntax. A property is defined by a line of the form prop=value where `prop` starts with a letter. All other lines (e.g., blank lines or lines starting with `#` are considered as comment lines and are ignored. curry-tools-v3.3.0/cpm/vendor/propertyfile/package.json000066400000000000000000000013371377556325500233210ustar00rootroot00000000000000{ "name": "propertyfile", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Read and update files containing properties in equational syntax", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base": ">= 3.0.0, < 4.0.0", "directory": ">= 3.0.0, < 4.0.0", "io-extra": ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Data.PropertyFile" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/propertyfile.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/propertyfile/src/000077500000000000000000000000001377556325500216165ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/propertyfile/src/Data/000077500000000000000000000000001377556325500224675ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/propertyfile/src/Data/PropertyFile.curry000066400000000000000000000063001377556325500262000ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A library to read and update files containing properties in the usual --- equational syntax, i.e., a property is defined by a line of the form --- `prop=value` where `prop` starts with a letter. --- All other lines (e.g., blank lines or lines starting with `#` are --- considered as comment lines and are ignored. --- --- @author Michael Hanus --- @version August 2006 --- @category general ------------------------------------------------------------------------------ module Data.PropertyFile ( readPropertyFile, updatePropertyFile , getPropertyFromFile, getPropertiesFromFile ) where import Data.Char import System.Directory import System.IOExts ------------------------------------------------------------------------------ --- Reads a property file and returns the list of properties. --- Returns empty list if the property file does not exist. readPropertyFile :: String -> IO [(String,String)] readPropertyFile file = do pfexists <- doesFileExist file if pfexists then do rcs <- readCompleteFile file -- to avoid open file handles return $ splitEqs . filter (\l->not (null l) && isAlpha (head l)) . lines $ rcs else return [] where splitEqs [] = [] splitEqs (eq:eqs) = case break (=='=') eq of (prop,_:val) -> (prop,val) : splitEqs eqs _ -> splitEqs eqs --- Update a property in a property file or add it, if it is not already --- there. --- @param file - the name of the property file --- @param pname - the name of the property --- @param pvalue - the new value of the property updatePropertyFile :: String -> String -> String -> IO () updatePropertyFile file pname pval = do props <- readPropertyFile file if lookup pname props == Nothing then appendFile file (pname++"="++pval++"\n") else changePropertyInFile file pname pval --- Change a property in a property file. changePropertyInFile :: String -> String -> String -> IO () changePropertyInFile file pname pval = do updateFile (\rcs -> unlines . map changeProp . lines $ rcs) file where changeProp l = let (s1,s2) = break (=='=') l in if null l || not (isAlpha (head l)) || null s2 then l else if s1==pname then s1++"="++pval else l ------------------------------------------------------------------------------ --- Looks up the value of a property stored in a property file. --- Uppercase/lowercase is ignored for the property names. getPropertyFromFile :: String -> String -> IO (Maybe String) getPropertyFromFile propfile propname = do props <- readPropertyFile propfile return $ lookup (map toLower propname) (map (\ (a, b) -> (map toLower a, b)) props) --- Looks up the values of properties stored in a property file. --- Uppercase/lowercase is ignored for the variable names. getPropertiesFromFile :: String -> [String] -> IO [Maybe String] getPropertiesFromFile propfile propnames = do props <- readPropertyFile propfile return (map (flip lookup (map (\ (a, b) -> (map toLower a, b)) props)) (map (map toLower) propnames)) ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/queue/000077500000000000000000000000001377556325500174275ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/queue/LICENSE000066400000000000000000000027351377556325500204430ustar00rootroot00000000000000Copyright (c) 2018, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/queue/README.md000066400000000000000000000002111377556325500207000ustar00rootroot00000000000000queue ===== This package contains a library implementing double-ended queues supporting access at both ends in constant amortized time. curry-tools-v3.3.0/cpm/vendor/queue/package.json000066400000000000000000000014201377556325500217120ustar00rootroot00000000000000{ "name": "queue", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library with double-ended queues supporting access at both ends in constant amortized time", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "random" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Data.Queue" ], "testsuite": { "src-dir": "test", "modules": [ "TestQueue" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/queue.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/queue/src/000077500000000000000000000000001377556325500202165ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/queue/src/Data/000077500000000000000000000000001377556325500210675ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/queue/src/Data/Queue.curry000066400000000000000000000073361377556325500232520ustar00rootroot00000000000000------------------------------------------------------------------------------ --- An implementation of double-ended queues supporting access at both --- ends in constant amortized time. --- --- @author Bernd Brassel, Olaf Chitil, Michael Hanus, Sebastian Fischer, --- Bjoern Peemoeller --- @version December 2018 ------------------------------------------------------------------------------ module Data.Queue ( -- Abstract data type, constructors and queries Queue, empty, cons, snoc, isEmpty, deqLength -- Selectors , deqHead, deqTail, deqLast, deqInit, deqReverse, rotate, matchHead, matchLast -- conversion from and to lists , listToDeq, deqToList ) where --- The datatype of a queue. data Queue a = S Int [a] Int [a] --- The empty queue. empty :: Queue _ empty = S 0 [] 0 [] --- Inserts an element at the front of the queue. cons :: a -> Queue a -> Queue a cons x (S lenf f lenr r) = check (lenf + 1) (x : f) lenr r --- Inserts an element at the end of the queue. snoc :: a -> Queue a -> Queue a snoc x (S lenf f lenr r) = deqReverse (check (lenr + 1) (x : r) lenf f) --- Is the queue empty? isEmpty :: Queue _ -> Bool isEmpty (S lenf _ lenr _) = lenf + lenr == 0 --- Returns the number of elements in the queue. deqLength :: Queue _ -> Int deqLength (S lenf _ lenr _) = lenf + lenr --- The first element of the queue. deqHead :: Queue a -> a deqHead (S lenf f _ r) = head (if lenf == 0 then r else f) --- Removes an element at the front of the queue. deqTail :: Queue a -> Queue a deqTail (S _ [] _ _) = empty deqTail (S lenf (_:fs) lenr r) = deqReverse (check lenr r (lenf - 1) fs) --- The last element of the queue. deqLast :: Queue a -> a deqLast (S _ f lenr r) = head (if lenr == 0 then f else r) --- Removes an element at the end of the queue. deqInit :: Queue a -> Queue a deqInit (S _ _ _ [] ) = empty deqInit (S lenf f lenr (_:rs)) = check lenf f (lenr - 1) rs --- Reverses a double ended queue. deqReverse :: Queue a -> Queue a deqReverse (S lenf f lenr r) = S lenr r lenf f --- Moves the first element to the end of the queue. rotate :: Queue a -> Queue a rotate q = snoc (deqHead q) (deqTail q) --- Matches the front of a queue. --- `matchHead q` is equivalent to --- `if isEmpty q then Nothing else Just (deqHead q, deqTail q)` --- but more efficient. matchHead :: Queue a -> Maybe (a, Queue a) matchHead (S _ [] _ [] ) = Nothing matchHead (S _ [] _ [x] ) = Just (x, empty) matchHead (S _ [] _ (_:_:_)) = error $ "Data.Queue.matchHead: illegal queue" matchHead (S lenf (x:xs) lenr r ) = Just (x, deqReverse (check lenr r (lenf - 1) xs)) --- Matches the end of a queue. --- `matchLast q` is equivalent to --- `if isEmpty q then Nothing else Just (deqLast q,deqInit q)` --- but more efficient. matchLast :: Queue a -> Maybe (a,Queue a) matchLast (S _ [] _ [] ) = Nothing matchLast (S _ [x] _ [] ) = Just (x, empty) matchLast (S _ (_:_:_) _ [] ) = error $ "Data.Queue.matchLast: illegal queue" matchLast (S lenf f lenr (x:xs)) = Just (x, check lenf f (lenr - 1) xs) --- Transforms a list to a double ended queue. listToDeq :: [a] -> Queue a listToDeq xs = check (length xs) xs 0 [] --- Transforms a double ended queue to a list. deqToList :: Queue a -> [a] deqToList (S _ xs _ ys) = xs ++ reverse ys --- Check for invariant: The length of the first list is smaller than --- three times the length of the second plus 1. check :: Int -> [a] -> Int -> [a] -> Queue a check lenf f lenr r | lenf <= 3 * lenr + 1 = S lenf f lenr r | otherwise = S lenf' f' lenr' r' where len = lenf + lenr lenf' = len `div` 2 lenr' = len - lenf' (f', rf') = splitAt lenf' f r' = r ++ reverse rf' curry-tools-v3.3.0/cpm/vendor/queue/test/000077500000000000000000000000001377556325500204065ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/queue/test/TestQueue.curry000066400000000000000000000031161377556325500234210ustar00rootroot00000000000000import Data.List import Test.Prop import System.Random import Data.Queue deq f = f . listToDeq deqs f = deqToList . f . listToDeq testHead = eq (deq deqHead) head testLast = eq (deq deqLast) last testCons = eq (deqs (cons 73)) (73:) testTail = eq (deqs (deqTail)) tail testSnoc = eq (deqs (snoc 73)) (++[73]) testInit = eq (deqs deqInit) init where init [x] = [] init (x:y:ys) = x : init (y:ys) testReverse = eq (deqs deqReverse) reverse testLength = eq (deq deqLength) length testRotate = eq (deqs rotate) (\ (x:xs) -> xs ++ [x]) ------------------------------------------------------------------------------ -- Random test: --- Tests a given predicate on a list of distinct random numbers. --- In case of a failure, the list of random numbers is returned --- in order to see the test cases in the CurryTest tool. test :: ([Int] -> Bool) -> PropIO test f = (rndList lenRnds >>= \xs -> return (if f xs then Nothing else Just xs)) `returns` Nothing --- Tests whether two operations return equal results --- on a list of distinct random numbers. --- In case of a failure, the list of random numbers is returned --- in order to see the test cases in the CurryTest tool. eq :: Eq a => ([Int] -> a) -> ([Int] -> a) -> PropIO eq f g = test (\x -> (f x)==(g x)) --- generate a list of at most n random numbers (without duplicated elements) rndList :: Int -> IO [Int] rndList n = getRandomSeed >>= return . nub . take n . (flip nextIntRange 100000) --- maximal length of test lists lenRnds :: Int lenRnds = 1000 ------------------------------------------------------------------------------ curry-tools-v3.3.0/cpm/vendor/random/000077500000000000000000000000001377556325500175635ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/random/LICENSE000066400000000000000000000027351377556325500205770ustar00rootroot00000000000000Copyright (c) 2018, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/random/README.md000066400000000000000000000001571377556325500210450ustar00rootroot00000000000000random ====== This package contains the library `System.Random` for pseudo-random number generation in Curry. curry-tools-v3.3.0/cpm/vendor/random/package.json000066400000000000000000000013151377556325500220510ustar00rootroot00000000000000{ "name": "random", "version": "3.0.0", "author": "Sergio Antoy ", "maintainer": "Michael Hanus ", "synopsis": "Library for pseudo-random number generation", "category": [ "Programming", "Numeric" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base": ">= 3.0.0, < 4.0.0", "time": ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.Random" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/random.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/random/src/000077500000000000000000000000001377556325500203525ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/random/src/System/000077500000000000000000000000001377556325500216365ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/random/src/System/Random.curry000066400000000000000000000153521377556325500241520ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for pseudo-random number generation in Curry. --- --- This library provides operations for generating pseudo-random --- number sequences. --- For any given seed, the sequences generated by the operations --- in this module should be **identical** to the sequences --- generated by the `java.util.Random package`. --- ------------------------------------------------------------------------------ --- The KiCS2 implementation is based on an algorithm taken from --- . --- There is an assumption that all operations are implicitly --- executed mod 2^32 (unsigned 32-bit integers) !!! --- GHC computes between -2^29 and 2^29-1, thus the sequence --- is NOT as random as one would like. --- --- m_w = ; /* must not be zero */ --- m_z = ; /* must not be zero */ --- --- uint get_random() --- { --- m_z = 36969 * (m_z & 65535) + (m_z >> 16); --- m_w = 18000 * (m_w & 65535) + (m_w >> 16); --- return (m_z << 16) + m_w; /* 32-bit result */ --- } --- ------------------------------------------------------------------------------ --- The PAKCS implementation is a linear congruential pseudo-random number --- generator described in --- Donald E. Knuth, _The Art of Computer Programming_, --- Volume 2: _Seminumerical Algorithms_, section 3.2.1. --- ------------------------------------------------------------------------------ --- @author Sergio Antoy (with extensions by Michael Hanus) --- @version June 2017 ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} module System.Random ( nextInt, nextIntRange, nextBoolean, getRandomSeed , shuffle ) where import System.CPUTime ( getCPUTime ) import Data.Time ( CalendarTime(..), getClockTime, toUTCTime ) #ifdef __PAKCS__ ------------------------------------------------------------------ -- Private Operations ------------------------------------------------------------------ -- a few constants multiplier :: Int multiplier = 25214903917 addend :: Int addend = 11 powermask :: Int powermask = 48 mask :: Int mask = 281474976710656 -- 2^powermask intsize :: Int intsize = 32 intspan :: Int intspan = 4294967296 -- 2^intsize intlimit :: Int intlimit = 2147483648 -- 2^(intsize-1) -- the basic sequence of random values sequence :: Int -> [Int] sequence seed = next : sequence next where next = nextseed seed -- auxiliary private operations nextseed :: Int -> Int nextseed seed = (seed * multiplier + addend) `rem` mask xor :: Int -> Int -> Int xor x y = if (x==0) && (y==0) then 0 else lastBit + 2 * restBits where lastBit = if (x `rem` 2) == (y `rem` 2) then 0 else 1 restBits = xor (x `quot` 2) (y `quot` 2) power :: Int -> Int -> Int power base exp = binary 1 base exp where binary x b e = if (e == 0) then x else binary (x * if (e `rem` 2 == 1) then b else 1) (b * b) (e `quot` 2) nextIntBits :: Int -> Int -> [Int] nextIntBits seed bits = map adjust list where init = (xor seed multiplier) `rem` mask list = sequence init shift = power 2 (powermask - bits) adjust x = if arg > intlimit then arg - intspan else arg where arg = (x `quot` shift) `rem` intspan #else zfact :: Int zfact = 36969 wfact :: Int wfact = 18000 two16 :: Int two16 = 65536 large :: Int large = 536870911 -- 2^29 - 1 #endif ------------------------------------------------------------------ -- Public Operations ------------------------------------------------------------------ --- Returns a sequence of pseudorandom, integer values. --- --- @param seed - The seed of the random sequence. nextInt :: Int -> [Int] #ifdef __PAKCS__ nextInt seed = nextIntBits seed intsize #else nextInt seed = let ns = if seed == 0 then 1 else seed next2 mw mz = let mza = zfact * (mz `mod` two16) + (mz * two16) mwa = wfact * (mw `mod` two16) + (mw * two16) tmp = (mza `div` two16 + mwa) res = if tmp < 0 then tmp+large else tmp in res : next2 mwa mza in next2 ns ns #endif --- Returns a pseudorandom sequence of values --- between 0 (inclusive) and the specified value (exclusive). --- --- @param seed - The seed of the random sequence. --- @param n - The bound on the random number to be returned. --- Must be positive. nextIntRange :: Int -> Int -> [Int] #ifdef __PAKCS__ nextIntRange seed n | n>0 = if power_of_2 n then map adjust_a seq else map adjust_b (filter adjust_c seq) where seq = nextIntBits seed (intsize - 1) adjust_a x = (n * x) `quot` intlimit adjust_b x = x `rem` n adjust_c x = x - (x `rem` n) + (n - 1) >= 0 power_of_2 k = k == 2 || k > 2 && k `rem` 2 == 0 && power_of_2 (k `quot` 2) #else nextIntRange seed n | n>0 = map (`mod` n) (nextInt seed) #endif --- Returns a pseudorandom sequence of boolean values. --- --- @param seed - The seed of the random sequence. nextBoolean :: Int -> [Bool] #ifdef __PAKCS__ nextBoolean seed = map (/= 0) (nextIntBits seed 1) #else nextBoolean seed = map (/= 0) (nextInt seed) #endif --- Returns a time-dependent integer number as a seed for really random numbers. --- Should only be used as a seed for pseudorandom number sequence --- and not as a random number since the precision is limited to milliseconds getRandomSeed :: IO Int getRandomSeed = getClockTime >>= \time -> getCPUTime >>= \msecs -> let (CalendarTime y mo d h m s _) = toUTCTime time #ifdef __PAKCS__ in return ((y+mo+d+h+(m+1)*(s+1)*(msecs+1)) `rem` mask) #else in return ((y+mo+d+h+(m+1)*(s+1)*(msecs+1)) `mod` two16) #endif --- Computes a random permutation of the given list. --- --- @param rnd random seed --- @param l lists to shuffle --- @return shuffled list --- shuffle :: Int -> [a] -> [a] shuffle rnd xs = shuffleWithLen (nextInt rnd) (length xs) xs shuffleWithLen :: [Int] -> Int -> [a] -> [a] shuffleWithLen [] _ _ = error "Internal error in Random.shuffleWithLen" shuffleWithLen (r:rs) len xs | len == 0 = [] | otherwise = z : shuffleWithLen rs (len-1) (ys++zs) where #ifdef __PAKCS__ (ys,z:zs) = splitAt (abs r `rem` len) xs #else (ys,z:zs) = splitAt (abs r `mod` len) xs #endif {- Simple tests and examples testInt = take 20 (nextInt 0) testIntRange = take 120 (nextIntRange 0 6) testBoolean = take 20 (nextBoolean 0) reallyRandom = do seed <- getRandomSeed putStrLn (show (take 20 (nextIntRange seed 100))) -} curry-tools-v3.3.0/cpm/vendor/read-legacy/000077500000000000000000000000001377556325500204605ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/read-legacy/LICENSE000066400000000000000000000027351377556325500214740ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/read-legacy/package.json000066400000000000000000000011541377556325500227470ustar00rootroot00000000000000{ "name": "read-legacy", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "A library for reading and writing from or to strings.", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "ReadShowTerm" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/read-legacy.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/read-legacy/src/000077500000000000000000000000001377556325500212475ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/read-legacy/src/ReadShowTerm.curry000066400000000000000000000144231377556325500247050ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for converting ground terms to strings and vice versa. --- --- @author Michael Hanus --- @version April 2005 ------------------------------------------------------------------------------ module ReadShowTerm(showTerm,showQTerm,readQTerm,readsQTerm, readsUnqualifiedTerm,readUnqualifiedTerm,readsTerm,readTerm, readQTermFile,readQTermListFile, writeQTermFile,writeQTermListFile) where import Data.Char(isSpace) --- Transforms a ground(!) term into a string representation --- in standard prefix notation. --- Thus, showTerm suspends until its argument is ground. --- This function is similar to the prelude function show --- but can read the string back with readUnqualifiedTerm --- (provided that the constructor names are unique without the module --- qualifier). showTerm :: _ -> String showTerm x = prim_showTerm $## x prim_showTerm :: _ -> String prim_showTerm external --- Transforms a ground(!) term into a string representation --- in standard prefix notation. --- Thus, showTerm suspends until its argument is ground. --- Note that this function differs from the prelude function show --- since it prefixes constructors with their module name --- in order to read them back with readQTerm. showQTerm :: _ -> String showQTerm x = prim_showQTerm $## x prim_showQTerm :: _ -> String prim_showQTerm external --- Transform a string containing a term in standard prefix notation --- without module qualifiers into the corresponding data term. --- The first argument is a non-empty list of module qualifiers that are tried to --- prefix the constructor in the string in order to get the qualified constructors --- (that must be defined in the current program!). --- In case of a successful parse, the result is a one element list --- containing a pair of the data term and the remaining unparsed string. readsUnqualifiedTerm :: [String] -> String -> [(_,String)] readsUnqualifiedTerm [] _ = error "ReadShowTerm.readsUnqualifiedTerm: list of module prefixes is empty" readsUnqualifiedTerm (prefix:prefixes) s = readsUnqualifiedTermWithPrefixes (prefix:prefixes) s readsUnqualifiedTermWithPrefixes :: [String] -> String -> [(_,String)] readsUnqualifiedTermWithPrefixes prefixes s = (prim_readsUnqualifiedTerm $## prefixes) $## s prim_readsUnqualifiedTerm :: [String] -> String -> [(_,String)] prim_readsUnqualifiedTerm external --- Transforms a string containing a term in standard prefix notation --- without module qualifiers into the corresponding data term. --- The first argument is a non-empty list of module qualifiers that are tried to --- prefix the constructor in the string in order to get the qualified constructors --- (that must be defined in the current program!). --- --- Example: readUnqualifiedTerm ["Prelude"] "Just 3" --- evaluates to (Just 3) readUnqualifiedTerm :: [String] -> String -> _ readUnqualifiedTerm prefixes s = case result of [(term,tail)] -> if all isSpace tail then term else error ("ReadShowTerm.readUnqualifiedTerm: no parse, unmatched string after term: "++tail) [] -> error "ReadShowTerm.readUnqualifiedTerm: no parse" _ -> error "ReadShowTerm.readUnqualifiedTerm: ambiguous parse" where result = readsUnqualifiedTerm prefixes s --- For backward compatibility. Should not be used since their use can be problematic --- in case of constructors with identical names in different modules. readsTerm :: String -> [(_,String)] readsTerm s = prim_readsUnqualifiedTerm [] $## s --- For backward compatibility. Should not be used since their use can be problematic --- in case of constructors with identical names in different modules. readTerm :: String -> _ readTerm s = case result of [(term,tail)] -> if all isSpace tail then term else error ("ReadShowTerm.readTerm: no parse, unmatched string after term: "++tail) [] -> error "ReadShowTerm.readTerm: no parse" _ -> error "ReadShowTerm.readTerm: ambiguous parse" where result = prim_readsUnqualifiedTerm [] $## s --- Transforms a string containing a term in standard prefix notation --- with qualified constructor names into the corresponding data term. --- In case of a successful parse, the result is a one element list --- containing a pair of the data term and the remaining unparsed string. readsQTerm :: String -> [(_,String)] readsQTerm s = prim_readsQTerm $## s prim_readsQTerm :: String -> [(_,String)] prim_readsQTerm external --- Transforms a string containing a term in standard prefix notation --- with qualified constructor names into the corresponding data term. readQTerm :: String -> _ readQTerm s = case result of [(term,tail)] -> if all isSpace tail then term else error "ReadShowTerm.readQTerm: no parse" [] -> error "ReadShowTerm.readQTerm: no parse" _ -> error "ReadShowTerm.readQTerm: ambiguous parse" where result = readsQTerm s --- Reads a file containing a string representation of a term --- in standard prefix notation and returns the corresponding data term. readQTermFile :: String -> IO _ readQTermFile file = readFile file >>= return . readQTerm --- Reads a file containing lines with string representations of terms --- of the same type and returns the corresponding list of data terms. readQTermListFile :: String -> IO [_] readQTermListFile file = readFile file >>= return . map readQTerm . lines --- Writes a ground term into a file in standard prefix notation. --- @param filename - The name of the file to be written. --- @param term - The term to be written to the file as a string. writeQTermFile :: String -> _ -> IO () writeQTermFile filename term = writeFile filename (showQTerm term) --- Writes a list of ground terms into a file. --- Each term is written into a separate line which might be useful --- to modify the file with a standard text editor. --- @param filename - The name of the file to be written. --- @param terms - The list of terms to be written to the file. writeQTermListFile :: String -> [_] -> IO () writeQTermListFile filename terms = writeFile filename (unlines (map showQTerm terms)) curry-tools-v3.3.0/cpm/vendor/read-legacy/src/ReadShowTerm.kics2000066400000000000000000000020401377556325500245440ustar00rootroot00000000000000external_d_C_prim_showTerm :: Show a => a -> Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_prim_showTerm t _ _ = toCurry (show t) external_d_C_prim_showQTerm :: Show a => a -> Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_prim_showQTerm t _ _ = toCurry (show t) external_d_C_prim_readsUnqualifiedTerm :: Read a => Curry_Prelude.OP_List Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 a Curry_Prelude.C_String) external_d_C_prim_readsUnqualifiedTerm _ = external_d_C_prim_readsQTerm external_d_C_prim_readsQTerm :: Read a => Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 a Curry_Prelude.C_String) external_d_C_prim_readsQTerm s _ _ = toCurryPairs (reads (fromCurry s)) where toCurryPairs [] = Curry_Prelude.OP_List toCurryPairs ((v,s):xs) = Curry_Prelude.OP_Cons (Curry_Prelude.OP_Tuple2 v (toCurry s)) (toCurryPairs xs) curry-tools-v3.3.0/cpm/vendor/read-legacy/src/ReadShowTerm.pakcs.pl000066400000000000000000000010651377556325500252520ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Prolog implementation of builtins of module ReadShowTerm: % 'ReadShowTerm.prim_showQTerm'(Term,String) :- readShowTerm:prim_showQTerm(Term,String). 'ReadShowTerm.prim_showTerm'(Term,String) :- readShowTerm:prim_showTerm(Term,String). 'ReadShowTerm.prim_readsQTerm'(String,Term) :- readShowTerm:prim_readsQTerm(String,Term). 'ReadShowTerm.prim_readsUnqualifiedTerm'(Prefixes,String,Term) :- readShowTerm:prim_readsUnqualifiedTerm(Prefixes,String,Term). curry-tools-v3.3.0/cpm/vendor/redblacktree/000077500000000000000000000000001377556325500207325ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/redblacktree/LICENSE000066400000000000000000000027351377556325500217460ustar00rootroot00000000000000Copyright (c) 2018, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/redblacktree/README.md000066400000000000000000000002461377556325500222130ustar00rootroot00000000000000redblacktree ============ This package contains libraries implementing red-black trees and efficient access structures, like tables and sets, using red-black trees. curry-tools-v3.3.0/cpm/vendor/redblacktree/package.json000066400000000000000000000014641377556325500232250ustar00rootroot00000000000000{ "name": "redblacktree", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Libraries implementing red-black trees for tables and sets", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "random" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Data.RedBlackTree", "Data.Set.RBTree", "Data.Table.RBTree" ], "testsuite": { "src-dir": "test", "modules": [ "TestRedBlackTree" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/redblacktree.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/redblacktree/src/000077500000000000000000000000001377556325500215215ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/redblacktree/src/Data/000077500000000000000000000000001377556325500223725ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/redblacktree/src/Data/RedBlackTree.curry000066400000000000000000000221711377556325500257520ustar00rootroot00000000000000--------------------------------------------------------------------------- --- Library with an implementation of red-black trees: --- --- Serves as the base for both TableRBT and SetRBT --- All the operations on trees are generic, i.e., one has to provide --- order predicates on elements. --- --- @author Johannes Koj, Michael Hanus, Bernd Brassel --- @version December 2018 ---------------------------------------------------------------------------- module Data.RedBlackTree ( RedBlackTree, empty, isEmpty, lookup, update , toList, sortBy, newTreeLike, setInsertEquivalence, delete ) where ---------------------------------------------------------------------------- -- the main interface: --- A red-black tree consists of a tree structure and three order predicates. --- These predicates generalize the red black tree. They define --- 1) equality when inserting into the tree
--- eg for a set eqInsert is (==), --- for a multiset it is (\ _ _ -> False) --- for a lookUp-table it is ((==) . fst) --- 2) equality for looking up values --- eg for a set eqLookUp is (==), --- for a multiset it is (==) --- for a lookUp-table it is ((==) . fst) --- 3) the (less than) relation for the binary search tree data RedBlackTree a = RedBlackTree (a -> a -> Bool) -- equality for insertion (a -> a -> Bool) -- equality for lookup (a -> a -> Bool) -- lessThan for search (Tree a) -- contents --- The three relations are inserted into the structure by function empty. --- Returns an empty tree, i.e., an empty red-black tree --- augmented with the order predicates. empty :: (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> RedBlackTree a empty eqInsert eqLookUp lessThan = RedBlackTree eqInsert eqLookUp lessThan Empty --- Test on emptyness isEmpty :: RedBlackTree _ -> Bool isEmpty (RedBlackTree _ _ _ Empty) = True isEmpty (RedBlackTree _ _ _ (Tree _ _ _ _)) = False --- Creates a new empty red black tree from with the same ordering as a give one. newTreeLike :: RedBlackTree a -> RedBlackTree a newTreeLike (RedBlackTree eqIns eqLk lt _) = RedBlackTree eqIns eqLk lt Empty --- Returns an element if it is contained in a red-black tree. --- @param p - a pattern for an element to look up in the tree --- @param t - a red-black tree --- @return the contained True if p matches in t lookup :: a -> RedBlackTree a -> Maybe a lookup p (RedBlackTree _ eqLk lt t) = lookupTree eqLk lt p t lookupTree :: (a -> a -> Bool) -> (a -> a -> Bool) -> a -> Tree a -> Maybe a lookupTree _ _ _ Empty = Nothing lookupTree eq lt p (Tree _ e l r) | eq p e = Just e | lt p e = lookupTree eq lt p l | otherwise = lookupTree eq lt p r --- Updates/inserts an element into a RedBlackTree. update :: a -> RedBlackTree a -> RedBlackTree a update e (RedBlackTree eqIns eqLk lt t) = RedBlackTree eqIns eqLk lt (updateTree eqIns lt e t) updateTree :: (a -> a -> Bool) -> (a -> a -> Bool) -> a -> Tree a -> Tree a updateTree eq lt e t = let (Tree _ e2 l r) = upd t in Tree Black e2 l r where upd Empty = Tree Red e Empty Empty upd (Tree c e2 l r) | eq e e2 = Tree c e l r | lt e e2 = balanceL (Tree c e2 (upd l) r) | otherwise = balanceR (Tree c e2 l (upd r)) --- Deletes entry from red black tree. delete :: a -> RedBlackTree a -> RedBlackTree a delete e (RedBlackTree eqIns eqLk lt t) = RedBlackTree eqIns eqLk lt (blackenRoot (deleteTree eqLk lt e t)) where blackenRoot Empty = Empty blackenRoot (Tree _ x l r) = Tree Black x l r deleteTree :: (a -> a -> Prelude.Bool) -> (a -> a -> Prelude.Bool) -> a -> Tree a -> Tree a deleteTree _ _ _ Empty = Empty -- no error for non existence deleteTree eq lt e (Tree c e2 l r) | eq e e2 = if isEmptyTree l then addColor c r else if isEmptyTree r then addColor c l else let el = rightMost l in delBalanceL (Tree c el (deleteTree eq lt el l) r) | lt e e2 = delBalanceL (Tree c e2 (deleteTree eq lt e l) r) | otherwise = delBalanceR (Tree c e2 l (deleteTree eq lt e r)) where addColor DoublyBlack tree = tree -- should not occur addColor Red tree = tree addColor Black Empty = Empty addColor Black (Tree Red x lx rx) = Tree Black x lx rx addColor Black (Tree Black x lx rx) = Tree DoublyBlack x lx rx addColor Black (Tree DoublyBlack x lx rx) = Tree DoublyBlack x lx rx rightMost Empty = error "RedBlackTree.rightMost" rightMost (Tree _ x _ rx) = if isEmptyTree rx then x else rightMost rx --- Transforms a red-black tree into an ordered list of its elements. toList :: RedBlackTree a -> [a] toList (RedBlackTree _ _ _ t) = tree2listTree t tree2listTree :: Tree a -> [a] tree2listTree tree = t2l tree [] where t2l Empty es = es t2l (Tree _ e l r) es = t2l l (e : t2l r es) --- Generic sort based on insertion into red-black trees. --- The first argument is the order for the elements. sortBy :: Eq a => (a -> a -> Bool) -> [a] -> [a] sortBy cmp xs = toList (foldr update (empty (\_ _->False) (==) cmp) xs) --- For compatibility with old version only setInsertEquivalence :: (a -> a -> Bool) -> RedBlackTree a -> RedBlackTree a setInsertEquivalence eqIns (RedBlackTree _ eqLk lt t) = RedBlackTree eqIns eqLk lt t ---------------------------------------------------------------------------- -- implementation of red-black trees: rbt :: RedBlackTree a -> Tree a rbt (RedBlackTree _ _ _ t) = t --- The colors of a node in a red-black tree. data Color = Red | Black | DoublyBlack deriving Eq --- The structure of red-black trees. data Tree a = Tree Color a (Tree a) (Tree a) | Empty isEmptyTree :: Tree _ -> Bool isEmptyTree Empty = True isEmptyTree (Tree _ _ _ _) = False isBlack :: Tree _ -> Bool isBlack Empty = True isBlack (Tree c _ _ _) = c == Black isRed :: Tree _ -> Bool isRed Empty = False isRed (Tree c _ _ _) = c == Red isDoublyBlack :: Tree _ -> Bool isDoublyBlack Empty = True isDoublyBlack (Tree c _ _ _) = c == DoublyBlack left :: Tree a -> Tree a left Empty = error "RedBlackTree.left" left (Tree _ _ l _) = l right :: Tree a -> Tree a right Empty = error "RedBlackTree.right" right (Tree _ _ _ r) = r singleBlack :: Tree a -> Tree a singleBlack Empty = Empty singleBlack (Tree Red x l r) = Tree Red x l r singleBlack (Tree Black x l r) = Tree Black x l r singleBlack (Tree DoublyBlack x l r) = Tree Black x l r --- for the implementation of balanceL and balanceR refer to picture 3.5, page 27, --- Okasaki "Purely Functional Data Structures" balanceL :: Tree a -> Tree a balanceL tree | isRed leftTree && isRed (left leftTree) = let Tree _ z (Tree _ y (Tree _ x a b) c) d = tree in Tree Red y (Tree Black x a b) (Tree Black z c d) | isRed leftTree && isRed (right leftTree) = let Tree _ z (Tree _ x a (Tree _ y b c)) d = tree in Tree Red y (Tree Black x a b) (Tree Black z c d) | otherwise = tree where leftTree = left tree balanceR :: Tree a -> Tree a balanceR tree | isRed rightTree && isRed (right rightTree) = let Tree _ x a (Tree _ y b (Tree _ z c d)) = tree in Tree Red y (Tree Black x a b) (Tree Black z c d) | isRed rightTree && isRed (left rightTree) = let Tree _ x a (Tree _ z (Tree _ y b c) d) = tree in Tree Red y (Tree Black x a b) (Tree Black z c d) | otherwise = tree where rightTree = right tree --- balancing after deletion delBalanceL :: Tree a -> Tree a delBalanceL tree = if isDoublyBlack (left tree) then reviseLeft tree else tree reviseLeft :: Tree a -> Tree a reviseLeft tree | isEmptyTree r = tree | blackr && isRed (left r) = let Tree col x a (Tree _ z (Tree _ y b c) d) = tree in Tree col y (Tree Black x (singleBlack a) b) (Tree Black z c d) | blackr && isRed (right r) = let Tree col x a (Tree _ y b (Tree _ z c d)) = tree in Tree col y (Tree Black x (singleBlack a) b) (Tree Black z c d) | blackr = let Tree col x a (Tree _ y b c) = tree in Tree (if col==Red then Black else DoublyBlack) x (singleBlack a) (Tree Red y b c) | otherwise = let Tree _ x a (Tree _ y b c) = tree in Tree Black y (reviseLeft (Tree Red x a b)) c where r = right tree blackr = isBlack r delBalanceR :: Tree a -> Tree a delBalanceR tree = if isDoublyBlack (right tree) then reviseRight tree else tree reviseRight :: Tree a -> Tree a reviseRight tree | isEmptyTree l = tree | blackl && isRed (left l) = let Tree col x (Tree _ y (Tree _ z d c) b) a = tree in Tree col y (Tree Black z d c) (Tree Black x b (singleBlack a)) | blackl && isRed (right l) = let Tree col x (Tree _ z d (Tree _ y c b)) a = tree in Tree col y (Tree Black z d c) (Tree Black x b (singleBlack a)) | blackl = let Tree col x (Tree _ y c b) a = tree in Tree (if col==Red then Black else DoublyBlack) x (Tree Red y c b) (singleBlack a) | otherwise = let Tree _ x (Tree _ y c b) a = tree in Tree Black y c (reviseRight (Tree Red x b a)) where l = left tree blackl = isBlack l curry-tools-v3.3.0/cpm/vendor/redblacktree/src/Data/Set/000077500000000000000000000000001377556325500231255ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/redblacktree/src/Data/Set/RBTree.curry000066400000000000000000000053061377556325500253420ustar00rootroot00000000000000---------------------------------------------------------------------------- --- Library with an implementation of sets as red-black trees. --- --- All the operations on sets are generic, i.e., one has to provide --- an explicit order predicate `(<)` (less-than) on elements. --- --- @author Johannes Koj, Michael Hanus, Bernd Brassel --- @version December 2018 ---------------------------------------------------------------------------- module Data.Set.RBTree where import qualified Data.RedBlackTree as RBT import Data.Maybe (isJust) import Prelude hiding (empty) type SetRBT a = RBT.RedBlackTree a --- Returns an empty set, i.e., an empty red-black tree --- augmented with an order predicate. empty :: Eq a => (a -> a -> Bool) -> SetRBT a empty = RBT.empty (==) (==) --- Returns an empty set that uses the Ord's ordering predicate. emptyOrd :: Ord a => SetRBT a emptyOrd = empty (<) --- Test for an empty set. null :: SetRBT _ -> Bool null = RBT.isEmpty --- Returns true if an element is contained in a (red-black tree) set. --- @param e - an element to be checked for containment --- @param s - a set (represented as a red-black tree) --- @return True if e is contained in s member :: a -> SetRBT a -> Bool member e = isJust . (RBT.lookup e) --- Inserts an element into a set if it is not already there. insert :: a -> SetRBT a -> SetRBT a insert = RBT.update --- Inserts an element into a multiset. --- Thus, the same element can have several occurrences in the multiset. insertMulti :: Eq a => a -> SetRBT a -> SetRBT a insertMulti e = RBT.setInsertEquivalence (==) . RBT.update e . RBT.setInsertEquivalence (\ _ _ -> False) --- delete an element from a set. --- Deletes only a single element from a multi set delete :: a -> SetRBT a -> SetRBT a delete = RBT.delete --- Transforms a (red-black tree) set into an ordered list of its elements. toList :: SetRBT a -> [a] toList = RBT.toList --- Computes the union of two (red-black tree) sets. --- This is done by inserting all elements of the first set into the --- second set. union :: SetRBT a -> SetRBT a -> SetRBT a union s1 s2 = foldr insert s2 (toList s1) --- Computes the intersection of two (red-black tree) sets. --- This is done by inserting all elements of the first set --- contained in the second set into a new set, which order --- is taken from the first set. intersection :: SetRBT a -> SetRBT a -> SetRBT a intersection s1 s2 = foldr insert (RBT.newTreeLike s1) (filter (`member` s2) (toList s1)) --- Generic sort based on insertion into red-black trees. --- The first argument is the order for the elements. sortBy :: Eq a => (a -> a -> Bool) -> [a] -> [a] sortBy = RBT.sortBy curry-tools-v3.3.0/cpm/vendor/redblacktree/src/Data/Table/000077500000000000000000000000001377556325500234215ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/redblacktree/src/Data/Table/RBTree.curry000066400000000000000000000035421377556325500256360ustar00rootroot00000000000000--------------------------------------------------------------------------- --- Library with an implementation of tables as red-black trees: --- --- A table is a finite mapping from keys to values. --- All the operations on tables are generic, i.e., one has to provide --- an explicit order predicate on elements. --- Each inner node in the red-black tree contains a key-value association. --- --- @author Johannes Koj, Michael Hanus, Bernd Brassel --- @version December 2018 ---------------------------------------------------------------------------- module Data.Table.RBTree where import qualified Data.RedBlackTree as RBT import Prelude hiding (empty) ---------------------------------------------------------------------------- -- the main interface: type TableRBT key a = RBT.RedBlackTree (key,a) --- Returns an empty table, i.e., an empty red-black tree. empty :: Eq key => (key -> key -> Bool) -> TableRBT key _ empty lt = RBT.empty (\ x y -> fst x == fst y) (\ x y -> fst x == fst y) (\ x y -> lt (fst x) (fst y)) --- tests whether a given table is empty isEmpty :: TableRBT _ _ -> Bool isEmpty = RBT.isEmpty --- Looks up an entry in a table. --- @param k - a key under which a value is stored --- @param t - a table (represented as a red-black tree) --- @return (Just v) if v is the value stored with key k, --- otherwise Nothing is returned. lookup :: key -> TableRBT key a -> Maybe a lookup k = maybe Nothing (Just . snd) . RBT.lookup (k,failed) --- Inserts or updates an element in a table. update :: key -> a -> TableRBT key a -> TableRBT key a update k e = RBT.update (k,e) --- Transforms the nodes of red-black tree into a list. toList :: TableRBT key a -> [(key,a)] toList = RBT.toList delete :: key -> TableRBT key a -> TableRBT key a delete key = RBT.delete (key,failed) -- end of TableRBT curry-tools-v3.3.0/cpm/vendor/redblacktree/test/000077500000000000000000000000001377556325500217115ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/redblacktree/test/TestRedBlackTree.curry000066400000000000000000000023641377556325500261330ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some tests for library RedBlackTree. --- --- To run all tests automatically by the currycheck tool, use the command: --- "curry check TestRedBlackTree" --- --- @author Bernd Brassel, Michael Hanus --- @version December 2018 ------------------------------------------------------------------------------ import Data.List (nub) import Test.Prop import System.Random import Data.RedBlackTree as RBT intList2Tree = foldr update (RBT.empty (\ _ _ -> False) (==) (<)) rndTree n = getRandomSeed >>= return . nub . take n . (flip nextIntRange 100000) >>= \is -> return (intList2Tree is,is) sorted [] = True sorted [_] = True sorted (x:y:xs) = x < y && sorted (y:xs) rndDels n x = getRandomSeed >>= return . take n . (flip nextIntRange x) deleteTest t _ [] = t deleteTest t is (x:xs) = deleteTest (delete (is !! x) t) is xs testIO m n = rndTree m >>= \ (t,is) -> rndDels n (length is) >>= \ ds -> let newt = deleteTest t is ds in return (sorted (toList newt)) -- Create tree with 1000 random entries, then randomly delete 100. -- Test, if result is sorted. testCreateRBTreeAndDeleteAndCheckSorted = (testIO 1000 100) `returns` True curry-tools-v3.3.0/cpm/vendor/scc/000077500000000000000000000000001377556325500170535ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/scc/LICENSE000066400000000000000000000026771377556325500200740ustar00rootroot00000000000000Copyright (c) 1998-2007, Wolfgang Lux All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. None of the names of the copyright holders and 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 THE COPYRIGHT OWNER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/scc/README.md000066400000000000000000000001361377556325500203320ustar00rootroot00000000000000scc === This package provides a library `Data.SCC` to compute strongly connected components. curry-tools-v3.3.0/cpm/vendor/scc/package.json000066400000000000000000000013021377556325500213350ustar00rootroot00000000000000{ "name": "scc", "version": "3.0.0", "author": "Wolfgang Lux ", "maintainer": "Michael Hanus ", "synopsis": "Computing strongly connected components", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "redblacktree" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Data.SCC" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/scc.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/scc/src/000077500000000000000000000000001377556325500176425ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/scc/src/Data/000077500000000000000000000000001377556325500205135ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/scc/src/Data/SCC.curry000066400000000000000000000060251377556325500222140ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- Computing strongly connected components --- --- Copyright (c) 2000 - 2003, Wolfgang Lux --- See LICENSE for the full license. --- --- The function `scc` computes the strongly connected components of a list --- of entities in two steps. First, the list is topologically sorted --- "downwards" using the *defines* relation. --- Then the resulting list is sorted "upwards" using the *uses* relation --- and partitioned into the connected components. Both relations --- are computed within this module using the bound and free names of each --- declaration. --- --- In order to avoid useless recomputations, the code in the module first --- decorates the declarations with their bound and free names and a --- unique number. The latter is only used to provide a trivial ordering --- so that the declarations can be used as set elements. --- --- @author Wolfgang Lux --- ---------------------------------------------------------------------------- module Data.SCC (scc) where import Data.Set.RBTree (empty, member, insert) import Prelude hiding (empty) data Node a b = Node Int [b] [b] a deriving Eq cmpNode :: Node a b -> Node a b -> Bool cmpNode n1 n2 = key n1 < key n2 key :: Node a b -> Int key (Node k _ _ _) = k bvs :: Node a b -> [b] bvs (Node _ bs _ _) = bs fvs :: Node a b -> [b] fvs (Node _ _ fs _) = fs node :: Node a b -> a node (Node _ _ _ n) = n --- Computes the strongly connected components of a list --- of entities. To be flexible, we distinguish the nodes and --- the entities defined in this node. --- --- @param defines - maps each node to the entities defined in this node --- @param uses - maps each node to the entities used in this node --- @param nodes - the list of nodes which should be sorted into --- strongly connected components --- @return the strongly connected components of the list of nodes scc :: (Eq a, Eq b) => (a -> [b]) -- ^ entities defined by node -> (a -> [b]) -- ^ entities used by node -> [a] -- ^ list of nodes -> [[a]] -- ^ strongly connected components scc bvs' fvs' = map (map node) . tsort' . tsort . zipWith wrap [0 ..] where wrap i n = Node i (bvs' n) (fvs' n) n tsort :: (Eq a, Eq b) => [Node a b] -> [Node a b] tsort xs = snd (dfs xs (empty cmpNode) []) where dfs [] marks stack = (marks, stack) dfs (x : xs') marks stack | x `member` marks = dfs xs' marks stack | otherwise = dfs xs' marks' (x : stack') where (marks', stack') = dfs (defs x) (x `insert` marks) stack defs x1 = filter (any (`elem` fvs x1) . bvs) xs tsort' :: (Eq a, Eq b) => [Node a b] -> [[Node a b]] tsort' xs = snd (dfs xs (empty cmpNode) []) where dfs [] marks stack = (marks, stack) dfs (x : xs') marks stack | x `member` marks = dfs xs' marks stack | otherwise = dfs xs' marks' ((x : concat stack') : stack) where (marks', stack') = dfs (uses x) (x `insert` marks) [] uses x1 = filter (any (`elem` bvs x1) . fvs) xs curry-tools-v3.3.0/cpm/vendor/socket/000077500000000000000000000000001377556325500175735ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/socket/LICENSE000066400000000000000000000027351377556325500206070ustar00rootroot00000000000000Copyright (c) 2018, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/socket/README.md000066400000000000000000000001571377556325500210550ustar00rootroot00000000000000socket ====== This package contains the library `Network.Socket` to support network programming with sockets. curry-tools-v3.3.0/cpm/vendor/socket/examples/000077500000000000000000000000001377556325500214115ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/socket/examples/addserver.curry000066400000000000000000000025161377556325500244620ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A simple "addition" server to test the Socket library. --- --- @author Michael Hanus --- @version November 2020 ------------------------------------------------------------------------------ import Network.Socket import System.IO -- Choose a free port number: portnr :: Int portnr = 32145 sendTo host msg = do h <- connectToSocket host portnr hPutStr h msg hClose h stopServer host = sendTo host "TERMINATE\n" -- An "addition" server: addServer = do socket <- listenOn portnr putStrLn $ "Serving port: " ++ show portnr addServeSocket socket addServeSocket socket = do (chost,stream) <- accept socket putStrLn $ "Connection from "++chost serverLoop stream where serverLoop h = do l1 <- hGetLine h if l1=="TERMINATE" then do hClose h close socket else do l2 <- hGetLine h hPutStrLn h (show ((read l1 :: Int) + (read l2 :: Int))) hClose h addServeSocket socket addClient :: String -> Int -> Int -> IO () addClient host x y = do h <- connectToSocket host portnr hPutStr h (unlines (map show [x,y])) hFlush h answer <- hGetLine h putStrLn $ "Answer: "++answer hClose h {- Test with PAKCS: :fork addServer addClient "localhost" 3 4 stopServer "localhost" -} curry-tools-v3.3.0/cpm/vendor/socket/examples/addtimeoutserver.curry000066400000000000000000000027641377556325500260760ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A simple "addition" server to test the Socket library with time limits --- on socket connections. --- --- @author Michael Hanus --- @version November 2020 ------------------------------------------------------------------------------ import System.IO import Network.Socket -- Choose a free port number: portnr = 32145 sendTo host msg = do h <- connectToSocket host portnr hPutStr h msg hClose h stopServer host = sendTo host "TERMINATE\n" -- An "addition" server: addServer = do socket <- listenOn portnr putStrLn $ "Serving port: " ++ show portnr addServeSocket socket addServeSocket socket = do conn <- waitForSocketAccept socket 1000 addServeSocketTest socket conn addServeSocketTest socket Nothing = do putStrLn "Timeout" addServeSocket socket addServeSocketTest socket (Just (chost,stream)) = do putStrLn $ "Connection from "++chost serverLoop stream where serverLoop h = do l1 <- hGetLine h if l1=="TERMINATE" then do hClose h close socket else do l2 <- hGetLine h hPutStrLn h (show ((read l1 :: Int) + (read l2 :: Int))) hClose h addServeSocket socket addClient host x y = do h <- connectToSocket host portnr hPutStr h (unlines (map show [x,y])) hFlush h answer <- hGetLine h putStrLn $ "Answer: "++answer hClose h {- Test with PAKCS: :fork addServer addClient "localhost" 3 4 stopServer "localhost" -} curry-tools-v3.3.0/cpm/vendor/socket/examples/httpget.curry000066400000000000000000000013611377556325500241570ustar00rootroot00000000000000-- A simple example showing the direct connection to Unix sockets -- by using the `Network.Socket` library. import System.IO import Network.Socket(connectToSocket) -- An I/O action that shows the answer of a web server to the -- request of a document: httpGet :: String -> String -> IO () httpGet host doc = do str <- connectToSocket host 80 hPutStr str ("GET " ++ doc ++ " HTTP/1.0\n\n") hFlush str showStreamContents str -- Show the complete contents of an output stream: showStreamContents :: Handle -> IO () showStreamContents str = do b <- hIsEOF str if b then return () else do l <- hGetLine str putStrLn l showStreamContents str -- A test: main :: IO () main = httpGet "www.google.com" "/index.html" curry-tools-v3.3.0/cpm/vendor/socket/package.json000066400000000000000000000011421377556325500220570ustar00rootroot00000000000000{ "name": "socket", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library for programming with sockets", "category": [ "Network" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Network.Socket" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/socket.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/socket/src/000077500000000000000000000000001377556325500203625ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/socket/src/Network/000077500000000000000000000000001377556325500220135ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/socket/src/Network/Socket.curry000066400000000000000000000061721377556325500243370ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to support network programming with sockets. --- In standard applications, the server side uses the operations --- `listenOn` and `socketAccept` to provide some service --- on a socket, and the client side uses the operation --- `connectToSocket` to request a service. --- --- @author Michael Hanus --- @version December 2018 ------------------------------------------------------------------------------ module Network.Socket (Socket, listenOn, listenOnFresh, accept, waitForSocketAccept, close, connectToSocket) where import System.IO (Handle) --- The abstract type of sockets. external data Socket --------------------------------------------------------------------- -- Server side operations: --- Creates a server side socket bound to a given port number. listenOn :: Int -> IO Socket listenOn port = prim_listenOn $# port prim_listenOn :: Int -> IO Socket prim_listenOn external --- Creates a server side socket bound to a free port. --- The port number and the socket is returned. listenOnFresh :: IO (Int,Socket) listenOnFresh external --- Returns a connection of a client to a socket. --- The connection is returned as a pair consisting of a string identifying --- the client (the format of this string is implementation-dependent) --- and a handle to a stream communication with the client. --- The handle is both readable and writable. --- Only IPv4 connections are currently possible. accept :: Socket -> IO (String,Handle) accept s = prim_socketAccept $## s prim_socketAccept :: Socket -> IO (String,Handle) prim_socketAccept external --- Waits until a connection of a client to a socket is available. --- If no connection is available within the time limit, it returns Nothing, --- otherwise the connection is returned as a pair consisting --- of a string identifying the client --- (the format of this string is implementation-dependent) --- and a handle to a stream communication with the client. --- @param socket - a socket --- @param timeout - milliseconds to wait for input (< 0 : no time out) waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle)) waitForSocketAccept s timeout = (prim_waitForSocketAccept $## s) $# timeout prim_waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle)) prim_waitForSocketAccept external --- Closes a server socket. close :: Socket -> IO () close s = prim_sClose $## s prim_sClose :: Socket -> IO () prim_sClose external --------------------------------------------------------------------- -- Client side operations: --- Creates a new connection to a Unix socket. --- Only IPv4 connections are currently possible. --- @param host - the host name of the connection --- @param port - the port number of the connection --- @return the handle of the stream (connected to the port port@host) --- which is both readable and writable connectToSocket :: String -> Int -> IO Handle connectToSocket host port = (prim_connectToSocket $## host) $# port prim_connectToSocket :: String -> Int -> IO Handle prim_connectToSocket external --------------------------------------------------------------------- curry-tools-v3.3.0/cpm/vendor/socket/src/Network/Socket.kics2000066400000000000000000000114411377556325500242010ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses, CPP #-} import Control.Concurrent import Control.Monad (when) import System.IO #if __GLASGOW_HASKELL__ < 780 import Network #endif import Network.Socket hiding (sClose) type C_Socket = PrimData Socket ------------------------------------------------- #if __GLASGOW_HASKELL__ < 780 acceptOld :: Socket -> IO (Handle, HostName, PortNumber) acceptOld = Network.accept instance ConvertCurryHaskell Curry_Prelude.C_Int PortID where toCurry (PortNumber i) = toCurry (toInteger i) fromCurry i = PortNumber (fromInteger (fromCurry i)) external_d_C_listenOnFresh :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_Int C_Socket) external_d_C_listenOnFresh _ _ = toCurry listenOnFreshPort where listenOnFreshPort :: IO (PortID,Socket) listenOnFreshPort = do s <- listenOn (PortNumber aNY_PORT) p <- socketPort s return (p,s) ------------------------------------------------- #else ------------------------------------------------- acceptOld :: Socket -> IO (Handle, HostName, PortNumber) acceptOld sock = do (s, peer) <- Network.Socket.accept sock p <- socketPort s h <- socketToHandle s ReadWriteMode -- s is invalid after this point. return (h, show peer, p) listenOn :: PortNumber -> IO Socket listenOn pn = do -- AI_PASSIVE is needed when the address should be used for bind/listenOn -- AF_INET forces IPv4. This is crucial, because some -- systems crashed with the old Implementation that allowed IPv6 -- As soon as IPv6 is needed, someone has to look into this issue again. let hints = defaultHints { addrFlags = [AI_PASSIVE], addrFamily = AF_INET } addr:_ <- getAddrInfo (Just hints) Nothing (Just (show pn)) sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) setSocketOption sock ReuseAddr 1 fd <- fdSocket sock setCloseOnExecIfNeeded fd Network.Socket.bind sock (addrAddress addr) listen sock maxListenQueue return sock sClose :: Socket -> IO () sClose = close connectTo :: HostName -> PortNumber -> IO Handle connectTo s a = do -- for AF_INET see above let hints = defaultHints { addrFamily = AF_INET } addr:_ <- getAddrInfo (Just hints) (Just s) (Just (show a)) sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) connect sock (addrAddress addr) socketToHandle sock ReadWriteMode instance ConvertCurryHaskell Curry_Prelude.C_Int PortNumber where toCurry i = toCurry (toInteger i) fromCurry i = fromInteger (fromCurry i) external_d_C_listenOnFresh :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_Int C_Socket) external_d_C_listenOnFresh _ _ = toCurry listenOnFreshPort where listenOnFreshPort :: IO (PortNumber,Socket) listenOnFreshPort = do s <- listenOn defaultPort p <- socketPort s return (p,s) #endif ------------------------------------------------- external_d_C_prim_listenOn :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO C_Socket external_d_C_prim_listenOn i _ _ = toCurry listenOn i external_d_C_prim_socketAccept :: C_Socket -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_String Curry_IO.C_Handle) external_d_C_prim_socketAccept socket _ _ = toCurry (\s -> acceptOld s >>= \ (h,s,_) -> return (s,OneHandle h)) socket external_d_C_prim_waitForSocketAccept :: C_Socket -> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_Maybe (Curry_Prelude.OP_Tuple2 (Curry_Prelude.OP_List Curry_Prelude.C_Char) Curry_IO.C_Handle)) external_d_C_prim_waitForSocketAccept s i _ _ = toCurry wait s i wait :: Socket -> Int -> IO (Maybe (String, CurryHandle)) wait s t = if t < 0 then acceptOld s >>= \ (h, s, _) -> return (Just (s, OneHandle h)) else do mv <- newEmptyMVar tacc <- forkIO (acceptOld s >>= \ (h, s, _) -> putMVar mv (Just (s, OneHandle h))) ttim <- forkIO (delay ((fromIntegral t :: Integer) * 1000) >> putMVar mv Nothing) res <- takeMVar mv maybe (killThread tacc) (\_ -> killThread ttim) res return res -- Like 'threadDelay', but not bounded by an 'Int' delay :: Integer -> IO () delay time = do let maxWait = min time $ toInteger (maxBound :: Int) threadDelay $ fromInteger maxWait when (maxWait /= time) $ delay (time - maxWait) external_d_C_prim_sClose :: C_Socket -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_sClose s _ _ = toCurry sClose s external_d_C_prim_connectToSocket :: Curry_Prelude.C_String -> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_IO.C_Handle external_d_C_prim_connectToSocket str i _ _ = toCurry (\ s i -> connectTo s i >>= return . OneHandle) str i curry-tools-v3.3.0/cpm/vendor/socket/src/Network/Socket.pakcs.pl000066400000000000000000000027061377556325500247050ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Prolog implementation of builtins of module Network.Socket: % % create a server side socket bound to a port number. 'Network.Socket.prim_listenOn'(Port,Socket) :- listenOnNewSocket(Port,_,Socket). % create a server side socket with a fresh port. 'Network.Socket.prim_listenOnFresh'('Prelude.(,)'(Port,Socket)) :- listenOnNewSocket(Port,_,Socket). % return the first connection to a socket as a read/write stream: 'Network.Socket.prim_socketAccept'(Socket, 'Prelude.(,)'(ClientS,'$stream'('$inoutstream'(InStream,OutStream)))) :- socketAccept(Socket,Client,InStream,OutStream), atom2String(Client,ClientS), !. % return a connection to a socket within a time limit as a read/write stream, % otherwise Nothing: 'Network.Socket.prim_waitForSocketAccept'(Socket,TimeOut,Result) :- (waitForSocketClientStream(Socket,TimeOut,Client,InStream,OutStream) -> atom2String(Client,ClientS), Result = 'Prelude.Just'('Prelude.(,)'(ClientS, '$stream'('$inoutstream'(InStream,OutStream)))) ; Result = 'Prelude.Nothing'). % Closes a server socket. 'Network.Socket.prim_sClose'(Socket,'Prelude.()') :- socketClose(Socket). % open a connection to a Unix socket: 'Network.Socket.prim_connectToSocket'(SHst,SNr, '$stream'('$inoutstream'(InStream,OutStream))) :- string2Atom(SHst,Host), !, connect2socket(Host,SNr,InStream,OutStream). curry-tools-v3.3.0/cpm/vendor/time/000077500000000000000000000000001377556325500172415ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/time/LICENSE000066400000000000000000000027351377556325500202550ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/time/package.json000066400000000000000000000012251377556325500215270ustar00rootroot00000000000000{ "name": "time", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library for handling date and time information.", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Data.Time" ], "testsuite": { "src-dir": "test", "modules": [ "TestTime" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/time.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/time/src/000077500000000000000000000000001377556325500200305ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/time/src/Data/000077500000000000000000000000001377556325500207015ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/time/src/Data/Time.curry000066400000000000000000000143251377556325500226720ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for handling date and time information. --- --- @author Michael Hanus --- @version January 2018 ------------------------------------------------------------------------------ module Data.Time ( ClockTime, CalendarTime(..) , ctYear, ctMonth, ctDay, ctHour, ctMin, ctSec, ctTZ , getClockTime, getLocalTime, toUTCTime, toClockTime, toCalendarTime , clockTimeToInt, calendarTimeToString, toDayString, toTimeString , addSeconds, addMinutes, addHours, addDays, addMonths, addYears , daysOfMonth, validDate, compareCalendarTime, compareClockTime ) where --- ClockTime represents a clock time in some internal representation. data ClockTime = CTime Int deriving (Eq, Ord, Show, Read) --- A calendar time is presented in the following form: --- (CalendarTime year month day hour minute second timezone) --- where timezone is an integer representing the timezone as a difference --- to UTC time in seconds. data CalendarTime = CalendarTime Int Int Int Int Int Int Int deriving (Eq, Ord, Show, Read) --- The year of a calendar time. ctYear :: CalendarTime -> Int ctYear (CalendarTime y _ _ _ _ _ _) = y --- The month of a calendar time. ctMonth :: CalendarTime -> Int ctMonth (CalendarTime _ m _ _ _ _ _) = m --- The day of a calendar time. ctDay :: CalendarTime -> Int ctDay (CalendarTime _ _ d _ _ _ _) = d --- The hour of a calendar time. ctHour :: CalendarTime -> Int ctHour (CalendarTime _ _ _ h _ _ _) = h --- The minute of a calendar time. ctMin :: CalendarTime -> Int ctMin (CalendarTime _ _ _ _ m _ _) = m --- The second of a calendar time. ctSec :: CalendarTime -> Int ctSec (CalendarTime _ _ _ _ _ s _) = s --- The time zone of a calendar time. The value of the --- time zone is the difference to UTC time in seconds. ctTZ :: CalendarTime -> Int ctTZ (CalendarTime _ _ _ _ _ _ tz) = tz --- Returns the current clock time. getClockTime :: IO ClockTime getClockTime external --- Returns the local calendar time. getLocalTime :: IO CalendarTime getLocalTime = do ctime <- getClockTime toCalendarTime ctime --- Transforms a clock time into a unique integer. --- It is ensured that clock times that differs in at least one second --- are mapped into different integers. clockTimeToInt :: ClockTime -> Int clockTimeToInt (CTime i) = i --- Transforms a clock time into a calendar time according to the local time --- (if possible). Since the result depends on the local environment, --- it is an I/O operation. toCalendarTime :: ClockTime -> IO CalendarTime toCalendarTime ctime = prim_toCalendarTime $## ctime prim_toCalendarTime :: ClockTime -> IO CalendarTime prim_toCalendarTime external --- Transforms a clock time into a standard UTC calendar time. --- Thus, this operation is independent on the local time. toUTCTime :: ClockTime -> CalendarTime toUTCTime ctime = prim_toUTCTime $## ctime prim_toUTCTime :: ClockTime -> CalendarTime prim_toUTCTime external --- Transforms a calendar time (interpreted as UTC time) into a clock time. toClockTime :: CalendarTime -> ClockTime toClockTime d = prim_toClockTime $## d prim_toClockTime :: CalendarTime -> ClockTime prim_toClockTime external --- Transforms a calendar time into a readable form. calendarTimeToString :: CalendarTime -> String calendarTimeToString ctime@(CalendarTime y mo d _ _ _ _) = shortMonths!!(mo-1) ++ " " ++ show d ++ " " ++ toTimeString ctime ++ " " ++ show y where shortMonths = ["Jan","Feb","Mar","Apr","May","Jun", "Jul","Aug","Sep","Oct","Nov","Dec"] --- Transforms a calendar time into a string containing the day, e.g., --- "September 23, 2006". toDayString :: CalendarTime -> String toDayString (CalendarTime y mo d _ _ _ _) = longMonths!!(mo-1) ++ " " ++ show d ++ ", " ++ show y where longMonths = ["January","February","March","April","May","June","July", "August","September","October","November","December"] --- Transforms a calendar time into a string containing the time. toTimeString :: CalendarTime -> String toTimeString (CalendarTime _ _ _ h mi s _) = digit2 h ++":"++ digit2 mi ++":"++ digit2 s where digit2 n = if n<10 then ['0',chr(ord '0' + n)] else show n --- Adds seconds to a given time. addSeconds :: Int -> ClockTime -> ClockTime addSeconds n (CTime ctime) = CTime (ctime + n) --- Adds minutes to a given time. addMinutes :: Int -> ClockTime -> ClockTime addMinutes n (CTime ctime) = CTime (ctime + (n*60)) --- Adds hours to a given time. addHours :: Int -> ClockTime -> ClockTime addHours n (CTime ctime) = CTime (ctime + (n*3600)) --- Adds days to a given time. addDays :: Int -> ClockTime -> ClockTime addDays n (CTime ctime) = CTime (ctime + (n*86400)) --- Adds months to a given time. addMonths :: Int -> ClockTime -> ClockTime addMonths n ctime = let CalendarTime y mo d h mi s tz = toUTCTime ctime nmo = (mo-1+n) `mod` 12 + 1 in if nmo>0 then addYears ((mo-1+n) `div` 12) (toClockTime (CalendarTime y nmo d h mi s tz)) else addYears ((mo-1+n) `div` 12 - 1) (toClockTime (CalendarTime y (nmo+12) d h mi s tz)) --- Adds years to a given time. addYears :: Int -> ClockTime -> ClockTime addYears n ctime = if n==0 then ctime else let CalendarTime y mo d h mi s tz = toUTCTime ctime in toClockTime (CalendarTime (y+n) mo d h mi s tz) --- Gets the days of a month in a year. daysOfMonth :: Int -> Int -> Int daysOfMonth mo yr = if mo/=2 then [31,28,31,30,31,30,31,31,30,31,30,31] !! (mo-1) else if yr `mod` 4 == 0 && (yr `mod` 100 /= 0 || yr `mod` 400 == 0) then 29 else 28 --- Is a date consisting of year/month/day valid? validDate :: Int -> Int -> Int -> Bool validDate y m d = m > 0 && m < 13 && d > 0 && d <= daysOfMonth m y --- Compares two dates (don't use it, just for backward compatibility!). compareDate :: CalendarTime -> CalendarTime -> Ordering compareDate = compareCalendarTime --- Compares two calendar times. compareCalendarTime :: CalendarTime -> CalendarTime -> Ordering compareCalendarTime ct1 ct2 = compareClockTime (toClockTime ct1) (toClockTime ct2) --- Compares two clock times. compareClockTime :: ClockTime -> ClockTime -> Ordering compareClockTime (CTime time1) (CTime time2) | time1time2 = GT | otherwise = EQ curry-tools-v3.3.0/cpm/vendor/time/src/Data/Time.kics2000066400000000000000000000050431377556325500225360ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses #-} import qualified System.Time as T import qualified Data.Time.Clock as Clock import qualified Data.Time.Calendar as Cal instance ConvertCurryHaskell C_ClockTime T.ClockTime where fromCurry (C_CTime i) = T.TOD (fromCurry i) 0 toCurry (T.TOD i _) = C_CTime (toCurry i) instance ConvertCurryHaskell C_CalendarTime T.CalendarTime where fromCurry (C_CalendarTime y m d h min s tz) = T.CalendarTime (fromCurry y) (toEnum (fromCurry m - 1)) (fromCurry d) (fromCurry h) (fromCurry min) (fromCurry s) 0 undefined undefined undefined (fromCurry tz) undefined toCurry (T.CalendarTime y m d h min s _ _ _ _ tz _) = C_CalendarTime (toCurry y) (toCurry (fromEnum m + 1)) (toCurry d) (toCurry h) (toCurry min) (toCurry s) (toCurry tz) instance ConvertCurryHaskell C_ClockTime Clock.UTCTime where fromCurry ct = let (T.CalendarTime y m d h min s _ _ _ _ tz _) = T.toUTCTime (fromCurry ct) in fromIntegral tz `Clock.addUTCTime` Clock.UTCTime (Cal.fromGregorian (toInteger y) (fromEnum m + 1) d) (Clock.secondsToDiffTime (toInteger ((h * 60 + min) * 60 + s))) toCurry (Clock.UTCTime day diff) = let (y,m,d) = Cal.toGregorian day in toCurry (T.addToClockTime (T.TimeDiff 0 0 0 0 0 (round (toRational diff)) 0) (T.toClockTime (T.CalendarTime (fromIntegral y) (toEnum (m - 1)) d 0 0 0 0 undefined undefined undefined 0 undefined))) external_d_C_getClockTime :: Cover -> ConstStore -> Curry_Prelude.C_IO C_ClockTime external_d_C_getClockTime _ _ = toCurry T.getClockTime external_d_C_prim_toCalendarTime :: C_ClockTime -> Cover -> ConstStore -> Curry_Prelude.C_IO C_CalendarTime external_d_C_prim_toCalendarTime ct _ _ = toCurry T.toCalendarTime ct external_d_C_prim_toUTCTime :: C_ClockTime -> Cover -> ConstStore -> C_CalendarTime external_d_C_prim_toUTCTime ct _ _ = toCurry T.toUTCTime ct external_d_C_prim_toClockTime :: C_CalendarTime -> Cover -> ConstStore -> C_ClockTime external_d_C_prim_toClockTime ct _ _ = toCurry T.toClockTime ct curry-tools-v3.3.0/cpm/vendor/time/src/Data/Time.pakcs.pl000066400000000000000000000014771377556325500232450ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module Data.Time: % 'Data.Time.getClockTime'('Data.Time.CTime'(CTime)) :- currentClockTime(CTime). 'Data.Time.prim_toCalendarTime'('Data.Time.CTime'(ClockTime), 'Data.Time.CalendarTime'(Year,Month,Day,Hour,Min,Sec,TZ)) :- clocktime2localtime(ClockTime,Year,Month,Day,Hour,Min,Sec,TZ). 'Data.Time.prim_toUTCTime'('Data.Time.CTime'(ClockTime), 'Data.Time.CalendarTime'(Year,Month,Day,Hour,Min,Sec,0)) :- clocktime2utctime(ClockTime,Year,Month,Day,Hour,Min,Sec). 'Data.Time.prim_toClockTime'('Data.Time.CalendarTime'(Year,Month,Day,Hour, Min,Sec,TZ), 'Data.Time.CTime'(CTime)) :- date2clocktime(Year,Month,Day,Hour,Min,Sec,TZ,CTime). curry-tools-v3.3.0/cpm/vendor/time/test/000077500000000000000000000000001377556325500202205ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/time/test/TestTime.curry000066400000000000000000000012551377556325500230470ustar00rootroot00000000000000----------------------------------------------------------------------------- -- A few tests for module Data.Time ----------------------------------------------------------------------------- module TestTime where import Test.Prop import Data.Time aTime :: CalendarTime aTime = CalendarTime 2020 2 5 13 51 4 3600 testDayString :: Prop testDayString = toDayString aTime -=- "February 5, 2020" testTimeString :: Prop testTimeString = toTimeString aTime -=- "13:51:04" testDaysOfMonth1 :: Prop testDaysOfMonth1 = daysOfMonth 2 2020 -=- 29 testDaysOfMonth2 :: Prop testDaysOfMonth2 = daysOfMonth 2 1900 -=- 28 testDaysOfMonth3 :: Prop testDaysOfMonth3 = daysOfMonth 2 2000 -=- 29 curry-tools-v3.3.0/cpm/vendor/wl-pprint/000077500000000000000000000000001377556325500202375ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/wl-pprint/LICENSE000066400000000000000000000027351377556325500212530ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/wl-pprint/README.md000066400000000000000000000011561377556325500215210ustar00rootroot00000000000000wl-pprint ========= This package provides pretty printing combinators for Curry. It uses the interface of Daan Leijen's library for Haskell (http://www.cs.uu.nl/~daan/download/pprint/pprint.html). The linear-time bounded implementation is based on an approach by Olaf Chitil (http://www.cs.kent.ac.uk/pubs/2006/2381/index.html). Note that the implementation of `fill` and `fillBreak` is not linear-time bounded Besides well-known pretty printing combinators, this library also supports ANSI escape codes for formatting and colorisation of documents in text terminals (see https://en.wikipedia.org/wiki/ANSI_escape_code). curry-tools-v3.3.0/cpm/vendor/wl-pprint/package.json000066400000000000000000000020141377556325500225220ustar00rootroot00000000000000{ "name": "wl-pprint", "version": "3.0.0", "author": "Sebastian Fischer , Bjoern Peemoeller , Jan Rasmus Tikovsky ", "synopsis": "Pretty printing combinators for Curry (inspired by Leijen's library for Haskell)", "category": [ "Printing" ], "description": "This package includes a library providing general combinators for pretty printing. The interface is inspired by Daan Leijen's pretty printing library for Haskell and the linear-time bounded implementation is based on an approach by Olaf Chitil.", "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "queue": ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Text.Pretty" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/wl-pprint.git", "tag": "$version" } } curry-tools-v3.3.0/cpm/vendor/wl-pprint/src/000077500000000000000000000000001377556325500210265ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/wl-pprint/src/Text/000077500000000000000000000000001377556325500217525ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/wl-pprint/src/Text/Pretty.curry000066400000000000000000001154231377556325500243350ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library provides pretty printing combinators. --- The interface is that of --- [Daan Leijen's library](), (<+>), ($$), (<$+$>), (), (<$$>), (), (<$!$>), -- list combinators compose, hsep, vsep, vsepBlank, fillSep, sep, hcat, vcat, fillCat, cat, punctuate, encloseSep, encloseSepSpaced, hEncloseSep, fillEncloseSep, fillEncloseSepSpaced, list, listSpaced, set, setSpaced, tupled, tupledSpaced, semiBraces, semiBracesSpaced, -- bracketing combinators enclose, squotes, dquotes, bquotes, parens, parensIf, angles, braces, brackets, -- fillers fill, fillBreak, -- primitive type documents bool, char, string, int, float, -- character documents lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket, squote, dquote, semi, colon, comma, space, dot, backslash, equals, larrow, rarrow, doubleArrow, doubleColon, bar, at, tilde, -- formatting combinators bold, faint, blinkSlow, blinkRapid, italic, underline, crossout, inverse, -- colorisation combinators black, red, green, yellow, blue, magenta, cyan, white, bgBlack, bgRed, bgGreen, bgYellow, bgBlue, bgMagenta, bgCyan, bgWhite, -- Pretty class Pretty (..) ) where import Text.PrettyImpl infixl 5 $$, <$$>, , , <$!$>, <$+$> infixl 6 <>, <+> --- Standard printing with a column length of 80. pPrint :: Doc -> String pPrint = showWidth 80 --- The empty document --- @return an empty document empty :: Doc empty = Doc Empty --- Is the document empty? isEmpty :: Doc -> Bool isEmpty (Doc d) = isEmptyText (d EOD) where isEmptyText t = case t of Empty EOD -> True _ -> False --- The document `(text s)` contains the literal string `s`. --- The string shouldn't contain any newline ('\n') characters. --- If the string contains newline characters, --- the function `string` should be used. --- @param s - a string without newline (`'\n'`) characters --- @return a document which contains the literal string text :: String -> Doc text s = Doc (Text s) --- The document `(linesep s)` advances to the next line and indents --- to the current nesting level. Document `(linesep s)` --- behaves like `(text s)` if the line break is undone by `group`. --- @param s - a string --- @return a document which advances to the next line or behaves --- like `(text s)` linesep :: String -> Doc linesep = Doc . LineBreak . Just --- The document `hardline` advances to the next line and indents --- to the current nesting level. `hardline` cannot be undone by `group`. --- @return a document which advances to the next line hardline :: Doc hardline = Doc (LineBreak Nothing) --- The document `line` advances to the next line and indents to the current --- nesting level. Document `line` behaves like `(text " ")` if the line break --- is undone by `group`. --- @return a document which advances to the next line or behaves --- like `(text " ")` line :: Doc line = linesep " " --- The document `linebreak` advances to the next line and indents to --- the current nesting level. Document `linebreak` behaves like `(text "")` --- if the line break is undone by `group`. --- @return a document which advances to the next line or behaves like --- `(text "")` linebreak :: Doc linebreak = linesep "" --- The document `softline` behaves like `space` if the resulting output --- fits the page, otherwise it behaves like `line`. --- `softline = group line` --- @return a document which behaves like `space` or `line` softline :: Doc softline = group line --- The document `softbreak` behaves like `(text "")` if the resulting output --- fits the page, otherwise it behaves like `line`. --- `softbreak = group linebreak` --- @return a document which behaves like `(text "")` or `line` softbreak :: Doc softbreak = group linebreak --- The combinator `group` is used to specify alternative layouts. --- The document `(group x)` undoes all line breaks in document `x`. --- The resulting line is added to the current line if that fits the page. --- Otherwise, the document `x` is rendered without any changes. --- @param d - a document --- @return document d without line breaks if that fits the page. group :: Doc -> Doc group d = Doc (OpenGroup . deDoc d . CloseGroup) --- The document `(nest i d)` renders document `d` with the current --- indentation level increased by `i` (See also `hang`, --- `align` and `indent`). --- --- nest 2 (text "hello" $$ text "world") $$ text "!" --- --- outputs as: --- --- hello --- world --- ! --- --- @param i - an integer which increases the indentation level --- @param d - a document --- @return document d with an indentation level increased by i nest :: Int -> Doc -> Doc nest i d = Doc (OpenNest (Inc i) . deDoc d . CloseNest) --- The combinator `hang` implements hanging indentation. --- The document `(hang i d)` renders document `d` with a nesting level set --- to the current column plus `i`. The following example uses hanging --- indentation for some text: --- --- test = hang 4 --- (fillSep --- (map text --- (words "the hang combinator indents these words !"))) --- --- Which lays out on a page with a width of 20 characters as: --- --- the hang combinator --- indents these --- words ! --- --- The hang combinator is implemented as: --- --- hang i x = align (nest i x) --- --- @param i - an integer which increases the indentation level --- @param d - a document --- @return document d with an indentation level set to the current column plus i hang :: Int -> Doc -> Doc hang i x = align (nest i x) --- The document `(align d)` renders document `d with the nesting level --- set to the current column. It is used for example to implement `hang`. --- --- As an example, we will put a document right above another one, --- regardless of the current nesting level: --- --- x $$ y = align (x $$ y) --- test = text "hi" <+> (text "nice" $$ text "world") --- --- which will be layed out as: --- --- hi nice --- world --- --- @param d - a document --- @return document d with the nesting level set to the current column align :: Doc -> Doc align d = Doc (OpenNest Align . deDoc d . CloseNest) --- The document `(indent i d)` indents document `d` with `i` spaces. --- --- test = indent 4 (fillSep (map text --- (words "the indent combinator indents these words !"))) --- --- Which lays out with a page width of 20 as: --- --- the indent --- combinator --- indents these --- words ! --- --- @param i - an integer which increases the indentation level --- @param d - a document --- @return document d with an indentation level set to the current column --- plus i indent :: Int -> Doc -> Doc indent i d = hang i (spaces i <> d) --- The document `(combine c d1 d2)` combines document `d1` and `d2` with --- document `c` in between using `(<>)` with identity `empty`. --- Thus, the following equations hold. --- --- combine c d1 empty == d1 --- combine c empty d2 == d2 --- combine c d1 d2 == d1 <> c <> d2 if neither d1 nor d2 are empty --- --- @param c - the middle document --- @param d1 - the left document --- @param d2 - the right document --- @return concatenation of d1 and d2 with c in between unless one --- of the documents is empty combine :: Doc -> Doc -> Doc -> Doc combine c d1 d2 | isEmpty d1 = d2 | isEmpty d2 = d1 | otherwise = enclose d1 d2 c --- The document `(x <> y)` concatenates document `x` and document `y`. --- It is an associative operation having `empty` as a left and right unit. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y without seperator with identity empty (<>) :: Doc -> Doc -> Doc d1 <> d2 | isEmpty d1 = d2 | isEmpty d2 = d1 | otherwise = Doc (deDoc d1 . deDoc d2) --- The document `(x <+> y)` concatenates document `x` and `y` with a --- `space` in between with identity `empty`. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a space in between (<+>) :: Doc -> Doc -> Doc (<+>) = combine space --- The document `(x $$ y)` concatenates document x and y with a --- `line` in between with identity `empty`. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a line in between ($$) :: Doc -> Doc -> Doc ($$) = combine line --- The document `(x <$+$> y)` concatenates document `x` and `y` with a --- blank line in between with identity `empty`. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a blank line in between (<$+$>) :: Doc -> Doc -> Doc (<$+$>) = combine (line <> linebreak) --- The document `(x y)` concatenates document `x` and `y` with --- a `softline` in between with identity `empty`. --- This effectively puts `x` and `y` either next to each other --- (with a `space` in between) or underneath each other. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a softline in between () :: Doc -> Doc -> Doc () = combine softline --- The document `(x <$$> y)` concatenates document `x` and `y` with a --- `linebreak` in between with identity `empty`. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a linebreak in between (<$$>) :: Doc -> Doc -> Doc (<$$>) = combine linebreak --- The document `(x y)` concatenates document `x` and `y` with a --- `softbreak` in between with identity `empty`. --- This effectively puts `x` and `y` either right next to each other --- or underneath each other. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a softbreak in between () :: Doc -> Doc -> Doc () = combine softbreak --- The document `(x <$!$> y)` concatenates document `x` and `y` with a --- `hardline` in between with identity `empty`. --- This effectively puts `x` and `y` underneath each other. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a hardline in between (<$!$>) :: Doc -> Doc -> Doc (<$!$>) = combine hardline --- The document `(compose f xs)` concatenates all documents `xs` --- with function `f`. --- Function `f` should be like `(<+>)`, `($$)` and so on. --- @param f - a combiner function --- @param xs - a list of documents --- @return concatenation of documents compose :: (Doc -> Doc -> Doc) -> [Doc] -> Doc compose _ [] = empty compose op ds@(_:_) = foldr1 op ds -- no seperator at the end --- The document `(hsep xs)` concatenates all documents `xs` --- horizontally with `(<+>)`. --- @param xs - a list of documents --- @return horizontal concatenation of documents hsep :: [Doc] -> Doc hsep = compose (<+>) --- The document `(vsep xs)` concatenates all documents `xs` vertically with --- `($$)`. If a group undoes the line breaks inserted by `vsep`, --- all documents are separated with a `space`. --- --- someText = map text (words ("text to lay out")) --- test = text "some" <+> vsep someText --- --- This is layed out as: --- --- some text --- to --- lay --- out --- --- The `align` combinator can be used to align the documents --- under their first element: --- --- test = text "some" <+> align (vsep someText) --- --- This is printed as: --- --- some text --- to --- lay --- out --- --- @param xs - a list of documents --- @return vertical concatenation of documents vsep :: [Doc] -> Doc vsep = compose ($$) --- The document `vsep xs` concatenates all documents `xs` vertically with --- `(<$+$>)`. If a group undoes the line breaks inserted by `vsepBlank`, --- all documents are separated with a `space`. --- @param xs - a list of documents --- @return vertical concatenation of documents vsepBlank :: [Doc] -> Doc vsepBlank = compose (<$+$>) --- The document `(fillSep xs)` concatenates documents `xs` horizontally with --- `()` as long as its fits the page, than inserts a --- `line` and continues doing that for all documents in `xs`. --- `fillSep xs = foldr () empty xs` --- @param xs - a list of documents --- @return horizontal concatenation of documents fillSep :: [Doc] -> Doc fillSep = compose () --- The document `(sep xs)` concatenates all documents `xs` either horizontally --- with `(<+>)`, if it fits the page, or vertically --- with `($$)`. --- `sep xs = group (vsep xs)` --- @param xs - a list of documents --- @return horizontal concatenation of documents, if it fits the page, --- or vertical concatenation else sep :: [Doc] -> Doc sep = group . vsep --- The document `(hcat xs)` concatenates all documents `xs` horizontally --- with `(<>)`. --- @param xs - a list of documents --- @return horizontal concatenation of documents hcat :: [Doc] -> Doc hcat = compose (<>) --- The document `(vcat xs)` concatenates all documents `xs` vertically --- with `(<$$>)`. If a `group` undoes the line breaks inserted by `vcat`, --- all documents are directly concatenated. --- @param xs - a list of documents --- @return vertical concatenation of documents vcat :: [Doc] -> Doc vcat = compose (<$$>) --- The document `(fillCat xs)` concatenates documents `xs` horizontally --- with `()` as long as its fits the page, than inserts a `linebreak` --- and continues doing that for all documents in `xs`. --- `fillCat xs = foldr () empty xs` --- @param xs - a list of documents --- @return horizontal concatenation of documents fillCat :: [Doc] -> Doc fillCat = compose () --- The document `(cat xs)` concatenates all documents `xs` either horizontally --- with `(<>)`, if it fits the page, or vertically with --- `(<$$>)`. --- `cat xs = group (vcat xs)` --- @param xs - a list of documents --- @return horizontal concatenation of documents cat :: [Doc] -> Doc cat = group . vcat --- `(punctuate p xs)` concatenates all documents `xs` with document `p` except --- for the last document. --- --- someText = map text ["words","in","a","tuple"] --- test = parens (align (cat (punctuate comma someText))) --- --- This is layed out on a page width of 20 as: --- --- (words,in,a,tuple) --- --- But when the page width is 15, it is layed out as: --- --- (words, --- in, --- a, --- tuple) --- --- (If you want put the commas in front of their elements instead of at the --- end, you should use `tupled` or, in general, `encloseSep`.) --- @param p - a document as seperator --- @param xs - a list of documents --- @return concatenation of documents with p in between punctuate :: Doc -> [Doc] -> [Doc] punctuate d ds = go ds where go [] = [] go [x] = [x] go (x:xs@(_:_)) = (x <> d) : go xs --- The document `(encloseSep l r s xs)` concatenates the documents `xs` --- seperated by `s` and encloses the resulting document by `l` and `r`. --- The documents are rendered horizontally if that fits the page. Otherwise --- they are aligned vertically. All seperators are put in front of the --- elements. --- --- For example, the combinator `list` can be defined with `encloseSep`: --- --- list xs = encloseSep lbracket rbracket comma xs --- test = text "list" <+> (list (map int [10,200,3000])) --- --- Which is layed out with a page width of 20 as: --- --- list [10,200,3000] --- --- But when the page width is 15, it is layed out as: --- --- list [10 --- ,200 --- ,3000] --- --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseSep l r _ [] = l <> r encloseSep l r s (d:ds) = align (enclose l r (cat (d : map (s <>) ds))) --- The document `(encloseSepSpaced l r s xs)` concatenates the documents `xs` --- seperated by `s` and encloses the resulting document by `l` and `r`. --- In addition, after each occurrence of `s`, after `l`, and before `r`, --- a `space` is inserted. --- The documents are rendered horizontally if that fits the page. Otherwise --- they are aligned vertically. All seperators are put in front of the --- elements. --- --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r encloseSepSpaced :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseSepSpaced l r s = encloseSep (l <> space) (space <> r) (s <> space) --- The document `(hEncloseSep l r s xs)` concatenates the documents `xs` --- seperated by `s` and encloses the resulting document by `l` and `r`. --- --- The documents are rendered horizontally. --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r hEncloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc hEncloseSep l r _ [] = l <> r hEncloseSep l r s (d:ds) = align (enclose l r (hcat (d : map (s <>) ds))) --- The document `(fillEncloseSep l r s xs)` concatenates the documents `xs` --- seperated by `s` and encloses the resulting document by `l` and `r`. --- --- The documents are rendered horizontally if that fits the page. --- Otherwise they are aligned vertically. --- All seperators are put in front of the elements. --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r fillEncloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc fillEncloseSep l r _ [] = l <> r fillEncloseSep l r s (d:ds) = align (enclose l r (fillCat (d : map (s <>) ds))) --- The document `(fillEncloseSepSpaced l r s xs)` concatenates the documents --- `xs` seperated by `s` and encloses the resulting document by `l` and `r`. --- In addition, after each occurrence of `s`, after `l`, and before `r`, --- a `space` is inserted. --- --- The documents are rendered horizontally if that fits the page. --- Otherwise, they are aligned vertically. --- All seperators are put in front of the elements. --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r fillEncloseSepSpaced :: Doc -> Doc -> Doc -> [Doc] -> Doc fillEncloseSepSpaced l r s = fillEncloseSep (l <> space) (space <> r) (s <> space) --- The document `(list xs)` comma seperates the documents `xs` and encloses --- them in square brackets. The documents are rendered horizontally if --- that fits the page. Otherwise they are aligned vertically. --- All comma seperators are put in front of the elements. --- @param xs - a list of documents --- @return comma seperated documents xs and enclosed in square brackets list :: [Doc] -> Doc list = encloseSep lbracket rbracket comma --- Spaced version of `list` listSpaced :: [Doc] -> Doc listSpaced = encloseSepSpaced lbracket rbracket comma --- The document `(set xs)` comma seperates the documents `xs` and encloses --- them in braces. The documents are rendered horizontally if --- that fits the page. Otherwise they are aligned vertically. --- All comma seperators are put in front of the elements. --- @param xs - a list of documents --- @return comma seperated documents xs and enclosed in braces set :: [Doc] -> Doc set = encloseSep lbrace rbrace comma --- Spaced version of `set` setSpaced :: [Doc] -> Doc setSpaced = encloseSepSpaced lbrace rbrace comma --- The document `(tupled xs)` comma seperates the documents `xs` and encloses --- them in parenthesis. The documents are rendered horizontally if that fits --- the page. Otherwise they are aligned vertically. --- All comma seperators are put in front of the elements. --- @param xs - a list of documents --- @return comma seperated documents xs and enclosed in parenthesis tupled :: [Doc] -> Doc tupled = encloseSep lparen rparen comma --- Spaced version of `tupled` tupledSpaced :: [Doc] -> Doc tupledSpaced = encloseSepSpaced lparen rparen comma --- The document `(semiBraces xs)` seperates the documents `xs` with semi colons --- and encloses them in braces. The documents are rendered horizontally --- if that fits the page. Otherwise they are aligned vertically. --- All semi colons are put in front of the elements. --- @param xs - a list of documents --- @return documents xs seperated with semi colons and enclosed in braces semiBraces :: [Doc] -> Doc semiBraces = encloseSep lbrace rbrace semi --- Spaced version of `semiBraces` semiBracesSpaced :: [Doc] -> Doc semiBracesSpaced = encloseSepSpaced lbrace rbrace semi --- The document `(enclose l r x)` encloses document `x` between --- documents `l` and `r` using `(<>)`. --- `enclose l r x = l <> x <> r` --- @param l - the left document --- @param r - the right document --- @param x - the middle document --- @return concatenation of l, x and r enclose :: Doc -> Doc -> Doc -> Doc enclose l r d = l <> d <> r --- Document `(squotes x)` encloses document `x` with single quotes `"'"`. --- @param x - a document --- @return document x enclosed by single quotes squotes :: Doc -> Doc squotes = enclose squote squote --- Document `(dquotes x)` encloses document `x` with double quotes. --- @param x - a document --- @return document x enclosed by double quotes dquotes :: Doc -> Doc dquotes = enclose dquote dquote --- Document `(bquotes x)` encloses document `x` with back quotes `"\`"`. --- @param x - a document --- @return document x enclosed by `\`` quotes bquotes :: Doc -> Doc bquotes = enclose bquote bquote --- Document `(parens x)` encloses document `x` in parenthesis, --- `"("` and `")"`. --- @param x - a document --- @return document x enclosed in parenthesis parens :: Doc -> Doc parens = enclose lparen rparen --- Document `(parensIf x)` encloses document `x` in parenthesis,`"("` and `")"`, --- iff the condition is true. --- @param x - a document --- @return document x enclosed in parenthesis iff the condition is true parensIf :: Bool -> Doc -> Doc parensIf b s = if b then parens s else s --- Document `(angles x)` encloses document `x` in angles, `"<"` and `">"`. --- @param x - a document --- @return document x enclosed in angles angles :: Doc -> Doc angles = enclose langle rangle --- Document `(braces x)` encloses document `x` in braces, `"{"` and `"}"`. --- @param x - a document --- @return document x enclosed in braces braces :: Doc -> Doc braces = enclose lbrace rbrace --- Document `(brackets x)` encloses document `x` in square brackets, --- `"["` and `"]"`. --- @param x - a document --- @return document x enclosed in square brackets brackets :: Doc -> Doc brackets = enclose lbracket rbracket --- The document `(bool b)` shows the boolean `b` using `text`. --- @param b - a boolean --- @return a document which contains the boolean b bool :: Bool -> Doc bool b = text (show b) --- The document `(char c)` contains the literal character `c`. --- The character should not be a newline (`\n`), --- the function `line` should be used for line breaks. --- @param c - a character (not `\n`) --- @return a document which contains the literal character c char :: Char -> Doc char c = text [c] --- The document `(string s)` concatenates all characters in `s` using --- `line` for newline characters and `char` for all other characters. --- It is used instead of `text` whenever the text contains newline characters. --- @param s - a string --- @return a document which contains the string s string :: String -> Doc string = hcat . map (\c -> if elem c ['\n','\r'] then line else char c) --- The document `(int i)` shows the literal integer `i` using `text`. --- @param i - an integer --- @return a document which contains the integer i int :: Int -> Doc int n = text (show n) --- The document `(float f)` shows the literal float `f` using `text`. --- @param f - a float --- @return a document which contains the float f float :: Float -> Doc float x = text (show x) --- The document `lparen` contains a left parenthesis, `"("`. --- @return a document which contains a left parenthesis lparen :: Doc lparen = char '(' --- The document `rparen` contains a right parenthesis, `")"`. --- @return a document which contains a right parenthesis rparen :: Doc rparen = char ')' --- The document `langle` contains a left angle, `"<"`. --- @return a document which contains a left angle langle :: Doc langle = char '<' --- The document `rangle` contains a right angle, `">"`. --- @return a document which contains a right angle rangle :: Doc rangle = char '>' --- The document `lbrace` contains a left brace, `"{"`. --- @return a document which contains a left brace lbrace :: Doc lbrace = char '{' --- The document `rbrace` contains a right brace, `"}"`. --- @return a document which contains a right brace rbrace :: Doc rbrace = char '}' --- The document `lbracket` contains a left square bracket, `"["`. --- @return a document which contains a left square bracket lbracket :: Doc lbracket = char '[' --- The document `rbracket` contains a right square bracket, `"]"`. --- @return a document which contains a right square bracket rbracket :: Doc rbracket = char ']' --- The document `squote` contains a single quote, `"'"`. --- @return a document which contains a single quote squote :: Doc squote = char '\'' --- The document `dquote` contains a double quote. --- @return a document which contains a double quote dquote :: Doc dquote = char '"' --- The document `dquote` contains a `'`'` quote. --- @return a document which contains a `'`'` quote bquote :: Doc bquote = char '`' --- The document `semi` contains a semi colon, `";"`. --- @return a document which contains a semi colon semi :: Doc semi = char ';' --- The document `colon` contains a colon, `":"`. --- @return a document which contains a colon colon :: Doc colon = char ':' --- The document `comma` contains a comma, `","`. --- @return a document which contains a comma comma :: Doc comma = char ',' --- The document `space` contains a single space, `" "`. --- --- x <+> y = x <> space <> y --- --- @return a document which contains a single space space :: Doc space = char ' ' --- The document `(spaces n)` contains `n` spaces, when `n` is greater than 0. --- Otherwise the document is empty. --- --- @return a document which contains n spaces or the empty document, --- if n <= 0 spaces :: Int -> Doc spaces n | n <= 0 = empty | otherwise = text $ replicate n ' ' --- The document `dot` contains a single dot, `"."`. --- @return a document which contains a single dot dot :: Doc dot = char '.' --- The document `backslash` contains a back slash, `"\\"`. --- @return a document which contains a back slash backslash :: Doc backslash = char '\\' --- The document `equals` contains an equal sign, `"="`. --- @return a document which contains an equal equals :: Doc equals = char '=' --- The document `larrow` contains a left arrow sign, `"<-"`. --- @return a document which contains a left arrow sign larrow :: Doc larrow = text "<-" --- The document `rarrow` contains a right arrow sign, `"->"`. --- @return a document which contains a right arrow sign rarrow :: Doc rarrow = text "->" --- The document `doubleArrow` contains an double arrow sign, `"=>"`. --- @return a document which contains an double arrow sign doubleArrow :: Doc doubleArrow = text "=>" --- The document `doubleColon` contains a double colon sign, `"::"`. --- @return a document which contains a double colon sign doubleColon :: Doc doubleColon = text "::" --- The document `bar` contains a vertical bar sign, `"|"`. --- @return a document which contains a vertical bar sign bar :: Doc bar = char '|' --- The document `at` contains an at sign, `"@"`. --- @return a document which contains an at sign at :: Doc at = char '@' --- The document `tilde` contains a tilde sign, `"~"`. --- @return a document which contains a tilde sign tilde :: Doc tilde = char '~' --- The document `(fill i d)` renders document `d`. It than appends --- `space`s until the width is equal to `i`. If the width of `d` is --- already larger, nothing is appended. This combinator is quite --- useful in practice to output a list of bindings. The following --- example demonstrates this. --- --- types = [("empty","Doc") --- ,("nest","Int -> Doc -> Doc") --- ,("linebreak","Doc")] --- --- ptype (name,tp) --- = fill 6 (text name) <+> text "::" <+> text tp --- --- test = text "let" <+> align (vcat (map ptype types)) --- --- Which is layed out as: --- --- let empty :: Doc --- nest :: Int -> Doc -> Doc --- linebreak :: Doc --- --- Note that `fill` is not guaranteed to be linear-time bounded since it has to --- compute the width of a document before pretty printing it fill :: Int -> Doc -> Doc fill i d = d <> fill' where w = width d fill' = if w >= i then empty else spaces (i - w) --- The document `(fillBreak i d)` first renders document `d`. It --- than appends `space`s until the width is equal to `i`. If the --- width of `d` is already larger than `i`, the nesting level is --- increased by `i` and a `line` is appended. When we redefine `ptype` --- in the previous example to use `fillBreak`, we get a useful --- variation of the previous output: --- --- ptype (name,tp) --- = fillBreak 6 (text name) <+> text "::" <+> text tp --- --- The output will now be: --- --- let empty :: Doc --- nest :: Int -> Doc -> Doc --- linebreak --- :: Doc --- --- Note that `fillBreak` is not guaranteed to be linear-time bounded since it --- has to compute the width of a document before pretty printing it fillBreak :: Int -> Doc -> Doc fillBreak i d = d <> fill' where w = width d fill' = if w >= i then nest i linebreak else spaces (i - w) --- Compute the width of a given document width :: Doc -> Int width (Doc d) = width' 0 (d EOD) where width' w EOD = w width' w (Empty ts) = width' w ts width' w (Text s ts) = width' (w + lengthVis s) ts width' w (LineBreak Nothing ts) = width' w ts width' w (LineBreak (Just s) ts) = width' (w + lengthVis s) ts width' w (OpenGroup ts) = width' w ts width' w (CloseGroup ts) = width' w ts width' w (OpenNest _ ts) = width' w ts width' w (CloseNest ts) = width' w ts width' w (OpenFormat _ ts) = width' w ts width' w (CloseFormat ts) = width' w ts -- ----------------------------------------------------------------------------- -- Formatting combinators -- ----------------------------------------------------------------------------- --- The document `(bold d)` displays document `d` with bold text --- @param d - a document --- @return document d displayed with bold text bold :: Doc -> Doc bold d = Doc (OpenFormat (SetIntensity Bold) . deDoc d . CloseFormat) --- The document `(faint d)` displays document `d` with faint text --- @param d - a document --- @return document d displayed with faint text faint :: Doc -> Doc faint d = Doc (OpenFormat (SetIntensity Faint) . deDoc d . CloseFormat) --- The document `(blinkSlow d)` displays document `d` with slowly blinking text --- (rarely supported) --- @param d - a document --- @return document d displayed with slowly blinking text blinkSlow :: Doc -> Doc blinkSlow d = Doc (OpenFormat (SetBlinkMode Slow) . deDoc d . CloseFormat) --- The document `(blinkRapid d)` displays document `d` with rapidly blinking --- text (rarely supported) --- @param d - a document --- @return document d displayed with rapidly blinking text blinkRapid :: Doc -> Doc blinkRapid d = Doc (OpenFormat (SetBlinkMode Rapid) . deDoc d . CloseFormat) --- The document `(italic d)` displays document `d` with italicized text --- (rarely supported) --- @param d - a document --- @return document d displayed with italicized text italic :: Doc -> Doc italic d = Doc (OpenFormat (SetItalicized True) . deDoc d . CloseFormat) --- The document `(underline d)` displays document `d` with underlined text --- @param d - a document --- @return document d displayed with underlined text underline :: Doc -> Doc underline d = Doc (OpenFormat (SetUnderlined True) . deDoc d . CloseFormat) --- The document `(crossout d)` displays document `d` with crossed out text --- @param d - a document --- @return document d displayed with crossed out text crossout :: Doc -> Doc crossout d = Doc (OpenFormat (SetCrossedout True) . deDoc d . CloseFormat) --- The document `(inverse d)` displays document `d` with inversed coloring, --- i.e. use text color of `d` as background color and background color of `d` --- as text color --- @param d - a document --- @return document d displayed with inversed coloring inverse :: Doc -> Doc inverse d = Doc (OpenFormat (InverseColoring True) . deDoc d . CloseFormat) -- ----------------------------------------------------------------------------- -- Colorisation combinators -- ----------------------------------------------------------------------------- -- foreground colors --- The document `(black d)` displays document `d` with black text color --- @param d - a document --- @return document d displayed with black text color black :: Doc -> Doc black d = Doc (OpenFormat (SetForeground Black) . deDoc d . CloseFormat) --- The document `(red d)` displays document `d` with red text color --- @param d - a document --- @return document d displayed with red text color red :: Doc -> Doc red d = Doc (OpenFormat (SetForeground Red) . deDoc d . CloseFormat) --- The document `(green d)` displays document `d` with green text color --- @param d - a document --- @return document d displayed with green text color green :: Doc -> Doc green d = Doc (OpenFormat (SetForeground Green) . deDoc d . CloseFormat) --- The document `(yellow d)` displays document `d` with yellow text color --- @param d - a document --- @return document d displayed with yellow text color yellow :: Doc -> Doc yellow d = Doc (OpenFormat (SetForeground Yellow) . deDoc d . CloseFormat) --- The document `(blue d)` displays document `d` with blue text color --- @param d - a document --- @return document d displayed with blue text color blue :: Doc -> Doc blue d = Doc (OpenFormat (SetForeground Blue) . deDoc d . CloseFormat) --- The document `(magenta d)` displays document `d` with magenta text color --- @param d - a document --- @return document d displayed with magenta text color magenta :: Doc -> Doc magenta d = Doc (OpenFormat (SetForeground Magenta) . deDoc d . CloseFormat) --- The document `(cyan d)` displays document `d` with cyan text color --- @param d - a document --- @return document d displayed with cyan text color cyan :: Doc -> Doc cyan d = Doc (OpenFormat (SetForeground Cyan) . deDoc d . CloseFormat) --- The document `(white d)` displays document `d` with white text color --- @param d - a document --- @return document d displayed with white text color white :: Doc -> Doc white d = Doc (OpenFormat (SetForeground White) . deDoc d . CloseFormat) -- background colors --- The document `(bgBlack d)` displays document `d` with black background color --- @param d - a document --- @return document d displayed with black background color bgBlack :: Doc -> Doc bgBlack d = Doc (OpenFormat (SetBackground Black) . deDoc d . CloseFormat) --- The document `(bgRed d)` displays document `d` with red background color --- @param d - a document --- @return document d displayed with red background color bgRed :: Doc -> Doc bgRed d = Doc (OpenFormat (SetBackground Red) . deDoc d . CloseFormat) --- The document `(bgGreen d)` displays document `d` with green background color --- @param d - a document --- @return document d displayed with green background color bgGreen :: Doc -> Doc bgGreen d = Doc (OpenFormat (SetBackground Green) . deDoc d . CloseFormat) --- The document `(bgYellow d)` displays document `d` with yellow background --- color --- @param d - a document --- @return document d displayed with yellow background color bgYellow :: Doc -> Doc bgYellow d = Doc (OpenFormat (SetBackground Yellow) . deDoc d . CloseFormat) --- The document `(bgBlue d)` displays document `d` with blue background color --- @param d - a document --- @return document d displayed with blue background color bgBlue :: Doc -> Doc bgBlue d = Doc (OpenFormat (SetBackground Blue) . deDoc d . CloseFormat) --- The document `(bgMagenta d)` displays document `d` with magenta background --- color --- @param d - a document --- @return document d displayed with magenta background color bgMagenta :: Doc -> Doc bgMagenta d = Doc (OpenFormat (SetBackground Magenta) . deDoc d . CloseFormat) --- The document `(bgCyan d)` displays document `d` with cyan background color --- @param d - a document --- @return document d displayed with cyan background color bgCyan :: Doc -> Doc bgCyan d = Doc (OpenFormat (SetBackground Cyan) . deDoc d . CloseFormat) --- The document `(bgWhite d)` displays document `d` with white background color --- @param d - a document --- @return document d displayed with white background color bgWhite :: Doc -> Doc bgWhite d = Doc (OpenFormat (SetBackground White) . deDoc d . CloseFormat) -------------------------------------------------------------------------------- -- Pretty type class and instances for basic types -------------------------------------------------------------------------------- class Pretty a where pretty :: a -> Doc prettyList :: [a] -> Doc prettyList = list . map pretty instance Pretty a => Pretty [a] where pretty = prettyList instance Pretty Doc where pretty = id instance Pretty () where pretty () = text "()" instance Pretty Bool where pretty = bool instance Pretty Char where pretty = char prettyList = string instance Pretty Int where pretty = int instance Pretty Float where pretty = float instance (Pretty a, Pretty b) => Pretty (a,b) where pretty (x,y) = tupled [pretty x, pretty y] curry-tools-v3.3.0/cpm/vendor/wl-pprint/src/Text/PrettyImpl.curry000066400000000000000000000435361377556325500251640ustar00rootroot00000000000000--- Implementation of the Pretty library using --- [linear-time, bounded implementation](http://www.cs.kent.ac.uk/pubs/2006/2381/index.html) --- by Olaf Chitil. --- --- @author Sebastian Fischer, Bjoern Peemoeller, Jan Tikovsky --- @version December 2018 ------------------------------------------------------------------------------ module Text.PrettyImpl where import qualified Data.Queue as Q (Queue, cons, empty, matchHead, matchLast) -- The abstract data type Doc represents pretty documents. data Doc = Doc (Tokens -> Tokens) -- Extract the internal representation from a document. deDoc :: Doc -> Tokens -> Tokens deDoc (Doc d) = d type Horizontal = Bool type Remaining = Int type Width = Int type Position = Int type StartPosition = Position type EndPosition = Position type Out = Remaining -> Margins -> FormatHistory -> String -- Type of a `group output function`: Takes information whether group content -- should be formatted horizontally or vertically and a continuation to output -- parts of the document which come after the group type OutGroupPrefix = Horizontal -> Out -> Out type Margins = [Int] -- A nesting is either an alignment or a relative indentation data Nesting = Align | Inc Int -- text colorisation data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White | Default -- console intensity data Intensity = Faint | Normal | Bold -- support of blinking text data BlinkMode = Off | Slow | Rapid -- text formatting statement data FormatStm = SetForeground Color | SetBackground Color | SetIntensity Intensity | SetBlinkMode BlinkMode | SetItalicized Bool | SetUnderlined Bool | SetCrossedout Bool | InverseColoring Bool type FormatHistory = [FormatStm] resetFormat :: FormatHistory -> (FormatStm, FormatHistory) resetFormat [] = error "Pretty.resetFormat2: illegal format history" resetFormat (stm:stms) = case stm of SetForeground _ -> (SetForeground (prevFGColor stms), stms) SetBackground _ -> (SetBackground (prevBGColor stms), stms) SetIntensity _ -> (SetIntensity (prevIntensity stms), stms) SetBlinkMode _ -> (SetBlinkMode (prevBlinkMode stms), stms) SetItalicized b -> (SetItalicized (not b), stms) SetUnderlined b -> (SetUnderlined (not b), stms) SetCrossedout b -> (SetCrossedout (not b), stms) InverseColoring b -> (InverseColoring (not b), stms) -- Find previous foreground color in history prevFGColor :: FormatHistory -> Color prevFGColor history = case history of [] -> Default (SetForeground c : _ ) -> c (_ : hs) -> prevFGColor hs -- Find previous background color in history prevBGColor :: FormatHistory -> Color prevBGColor history = case history of [] -> Default (SetBackground c : _ ) -> c (_ : hs) -> prevBGColor hs -- Find previous text intensity in history prevIntensity :: FormatHistory -> Intensity prevIntensity history = case history of [] -> Normal (SetIntensity i : _ ) -> i (_ : hs) -> prevIntensity hs -- Find previous blinking mode in history prevBlinkMode :: FormatHistory -> BlinkMode prevBlinkMode history = case history of [] -> Off (SetBlinkMode b : _ ) -> b (_ : hs) -> prevBlinkMode hs applyFormat :: FormatStm -> String applyFormat (SetForeground c) = txtMode (colorMode c) applyFormat (SetBackground c) = txtMode (colorMode c + 10) applyFormat (SetIntensity i) = txtMode (intensityMode i) applyFormat (SetBlinkMode b) = txtMode (blinkMode b) applyFormat (SetItalicized b) = txtMode (if b then 3 else 23) applyFormat (SetUnderlined b) = txtMode (if b then 4 else 24) applyFormat (SetCrossedout b) = txtMode (if b then 9 else 29) applyFormat (InverseColoring b) = txtMode (if b then 7 else 27) -- Text mode txtMode :: Int -> String txtMode m = csiCmd ++ show m ++ "m" where csiCmd :: String csiCmd = '\ESC' : '[' : "" -- Color mode colorMode :: Color -> Int colorMode c = case c of Black -> 30 Red -> 31 Green -> 32 Yellow -> 33 Blue -> 34 Magenta -> 35 Cyan -> 36 White -> 37 Default -> 39 -- Intensity mode intensityMode :: Intensity -> Int intensityMode i = case i of Faint -> 2 Normal -> 22 Bold -> 1 -- Blink mode blinkMode :: BlinkMode -> Int blinkMode b = case b of Off -> 25 Slow -> 5 Rapid -> 6 -- Token sequence. Note that the data type linearizes a document so that -- a fragment is usually followed by a remaining document. data Tokens = EOD -- end of document | Empty Tokens -- empty document | Text String Tokens -- string | LineBreak (Maybe String) Tokens -- linebreak that will be replaced by the -- separator if the linebreak is undone | OpenGroup Tokens -- Beginning of a group | CloseGroup Tokens -- End of a group | OpenNest Nesting Tokens -- Beginning of a nesting | CloseNest Tokens -- End of a nesting | OpenFormat FormatStm Tokens -- Beginning of a formatting statement | CloseFormat Tokens -- End of a formatting statement applyNesting :: Nesting -> Width -> Remaining -> Margins -> Margins applyNesting Align w r ms = (w - r) : ms applyNesting (Inc i) _ _ ms = case ms of m:_ -> (m + i) : ms _ -> error "Pretty.applyNesting: empty margin list" unApplyNesting :: Margins -> Margins unApplyNesting [] = error "Pretty.unApplyNesting: empty margin list" unApplyNesting (_:ms) = ms addSpaces :: Int -> Tokens -> String addSpaces m ts = case ts of LineBreak _ _ -> "" EOD -> "" Empty ts' -> addSpaces m ts' OpenGroup ts' -> addSpaces m ts' CloseGroup ts' -> addSpaces m ts' OpenNest _ ts' -> addSpaces m ts' CloseNest ts' -> addSpaces m ts' OpenFormat _ ts' -> addSpaces m ts' CloseFormat ts' -> addSpaces m ts' Text _ _ -> replicate m ' ' -- Normalise a token sequence using the following rewriting rules: -- -- CloseGroup (Text s ts) => Text s (CloseGroup ts) -- OpenGroup (Text s ts) => Text s (OpenGroup ts) -- OpenGroup (CloseGroup ts) => ts -- -- Rewriting moves `Text` tokens in and out of groups. The set of `lines` -- "belonging" to each group, i.e., the set of layouts, is left unchanged. normalise :: Tokens -> Tokens normalise = go id where go co EOD = co EOD go co (Empty ts) = go co ts -- there should be no deferred opening brackets go co (OpenGroup ts) = go (co . open) ts go co (CloseGroup ts) = go (co . CloseGroup) ts go co (LineBreak ms ts) = (co . LineBreak ms . go id) ts go co (Text s ts) = Text s (go co ts) go co (OpenNest n ts) = OpenNest n (go co ts) go co (CloseNest ts) = CloseNest (go co ts) go co (OpenFormat f ts) = OpenFormat f (go co ts) go co (CloseFormat ts) = CloseFormat (go co ts) open t = case t of CloseGroup ts -> ts _ -> OpenGroup t -- Transform a document into a group-closed document by normalising its token -- sequence. -- A document is called group-closed, if between the end of every `group` and -- the next `text` document there is always a `line` document. doc2Tokens :: Doc -> Tokens doc2Tokens (Doc d) = normalise (d EOD) --- `(showWidth w d)` pretty prints document `d` with a page width of `w` characters --- @param w - width of page --- @param d - a document --- @return pretty printed document showWidth :: Width -> Doc -> String showWidth w d = noGroup (doc2Tokens d) w 1 w [0] [] -- Compute number of visible ASCII characters lengthVis :: String -> Int lengthVis = Prelude.length . filter isVisible where isVisible c = ord c `notElem` ([5, 6, 7] ++ [16 .. 31]) -- Basic pretty printing algorithm: -- -- 1. Determine for each group in the document its width, i.e. the space it -- requires for printing if it was printed horizontally, all in one line. -- 2. Traverse document tree and keep track of remaining free space in current -- output line. -- At the start of a group compare remaining space with width of the group: -- If the width is smaller or equal, the group is formatted horizontally, -- otherwise vertically. -- Determine widths of all groups and produce actual layout by traversing token -- sequence a single time using continuations: -- At the start of each group construct a `group output function` which receives -- formate information and information about the remaining space at the -- beginning of the group. -- Since groups can be nested we don't want to update a width value for each -- surrounding group when processing a token. Instead we introduce an absolute -- measure of a token's position: The width of a group is the difference between -- the position of its `CloseGroup` token and the position of its `OpenGroup` token. -- When traversing the document only the `group output function` of the -- innermost group is extended. All the other `group output function`s are -- passed on unchanged. When we come across a `CloseGroup` token we merge the -- function for the innermost group with the function for the next inner group. -- noGroup is used when there is currently no deferred group noGroup :: Tokens -> Width -> Position -> Out noGroup EOD _ _ _ _ _ = "" -- should not occur: noGroup (Empty ts) w p r ms fs = noGroup ts w p r ms fs noGroup (Text t ts) w p r ms fs = t ++ noGroup ts w (p + l) (r - l) ms fs where l = lengthVis t noGroup (LineBreak _ ts) w p _ ms fs = case ms of [] -> error "Pretty.noGroup: illegal line" m:_ -> '\n' : addSpaces m ts ++ noGroup ts w (p + 1) (w - m) ms fs noGroup (OpenGroup ts) w p r ms fs = oneGroup ts w p (p + r) (\_ c -> c) r ms fs noGroup (CloseGroup ts) w p r ms fs = noGroup ts w p r ms fs -- may have been pruned noGroup (OpenNest n ts) w p r ms fs = noGroup ts w p r (applyNesting n w r ms) fs noGroup (CloseNest ts) w p r ms fs = noGroup ts w p r (unApplyNesting ms) fs noGroup (OpenFormat f ts) w p r ms fs = applyFormat f ++ noGroup ts w p r ms (f:fs) noGroup (CloseFormat ts) w p r ms fs = applyFormat f ++ noGroup ts w p r ms ofs where (f, ofs) = resetFormat fs -- oneGroup is used when there is one deferred group -- Whenever the tokens `Text` or `LineBreak` are processed, -- i.e. the current position is increased, -- pruneOne checks whether whether the group still fits the line -- Furthermore the `group output function` is extended with the current token oneGroup :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Out oneGroup EOD _ _ _ _ = error "Pretty.oneGroup: EOD" -- should not occur: oneGroup (Empty ts) w p e outGrpPre = oneGroup ts w p e outGrpPre oneGroup (Text s ts) w p e outGrpPre = pruneOne ts w (p + l) e (\h cont -> outGrpPre h (outText cont)) where l = lengthVis s outText cont r ms fs = s ++ cont (r - l) ms fs oneGroup (LineBreak Nothing ts) w p _ outGrpPre = outGrpPre False (outLine (noGroup ts w p)) where outLine _ _ [] _ = error "Pretty.oneGroup.outLine: empty margins" outLine cont _ ms@(m:_) fs = '\n' : addSpaces m ts ++ cont (w - m) ms fs oneGroup (LineBreak (Just s) ts) w p e outGrpPre = pruneOne ts w (p + l) e (\h cont -> outGrpPre h (outLine h cont)) where l = lengthVis s outLine _ _ _ [] _ = error "Pretty.oneGroup.outLine: empty margins" outLine h cont r ms@(m:_) fs = if h then s ++ cont (r - l) ms fs else '\n' : addSpaces m ts ++ cont (w - m) ms fs oneGroup (OpenGroup ts) w p e outGrpPre = multiGroup ts w p e outGrpPre Q.empty p (\_ cont -> cont) oneGroup (CloseGroup ts) w p e outGrpPre = outGrpPre (p <= e) (noGroup ts w p) oneGroup (OpenNest n ts) w p e outGrpPre = oneGroup ts w p e (\h cont -> outGrpPre h (\r ms fs -> cont r (applyNesting n w r ms) fs)) oneGroup (CloseNest ts) w p e outGrpPre = oneGroup ts w p e (\h cont -> outGrpPre h (\r ms fs -> cont r (unApplyNesting ms) fs)) oneGroup (OpenFormat f ts) w p e outGrpPre = oneGroup ts w p e (\h cont -> outGrpPre h (outFormat cont)) where outFormat cont r ms fs = applyFormat f ++ cont r ms (f:fs) oneGroup (CloseFormat ts) w p e outGrpPre = oneGroup ts w p e (\h cont -> outGrpPre h (outUnformat cont)) where outUnformat cont r ms fs = applyFormat f ++ cont r ms ofs where (f, ofs) = resetFormat fs -- multiGroup is used when there are at least two deferred groups -- Whenever the tokens `Text` or `LineBreak` are processed, i.e. the current position -- is increased, pruneMulti checks whether whether the outermost group still -- fits the line. -- Furthermore the `group output function` of the innermost group is extended -- with the current token. -- When we come across a `OpenGroup` token during traversal of the token sequence, -- the current innermost `group output function` is added to the queue. -- Reaching a `CloseGroup` token it is checked whether the queue still contains a -- deferred `group output function`: If the queue is empty, there is only one -- group left, otherwise there are at least two groups left. -- In both cases the function for the innermost group is merged with the -- function for the next inner group multiGroup :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Q.Queue (StartPosition, OutGroupPrefix) -> StartPosition -> OutGroupPrefix -> Out multiGroup EOD _ _ _ _ _ _ _ = error "Pretty.multiGroup: EOD" -- should not occur: multiGroup (Empty ts) w p e outGrpPreOuter qs s outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs s outGrpPreInner multiGroup (Text t ts) w p e outGrpPreOuter qs s outGrpPreInner = pruneMulti ts w (p+l) e outGrpPreOuter qs s (\h cont -> outGrpPreInner h (outText cont)) where l = lengthVis t outText cont r ms fs = t ++ cont (r-l) ms fs multiGroup (LineBreak Nothing ts) w p _ outGrpPreOuter qs _ outGrpPreInner = pruneAll outGrpPreOuter qs where pruneAll outGrpPreOuter' qs' = outGrpPreOuter' False (\r -> (case Q.matchLast qs' of Nothing -> outGrpPreInner False (outLine (noGroup ts w p)) Just ((_,outGrpPre),qss) -> pruneAll outGrpPre qss) r) outLine _ _ [] _ = error "Pretty.oneGroup.outLine: empty margins" outLine cont _ ms@(m:_) fs = '\n' : addSpaces m ts ++ cont (w - m) ms fs multiGroup (LineBreak (Just s) ts) w p e outGrpPreOuter qs si outGrpPreInner = pruneMulti ts w (p + l) e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (outLine h cont)) where l = lengthVis s outLine _ _ _ [] _ = error "Pretty.multiGroup.outLine: empty margins" outLine h cont r ms@(m:_) fs = if h then s ++ cont (r-l) ms fs else '\n': addSpaces m ts ++ cont (w-m) ms fs multiGroup (OpenGroup ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter (Q.cons (si,outGrpPreInner) qs) p (\_ cont -> cont) multiGroup (CloseGroup ts) w p e outGrpPreOuter qs si outGrpPreInner = case Q.matchHead qs of Nothing -> oneGroup ts w p e (\h cont -> outGrpPreOuter h (\ri -> outGrpPreInner (p<=si+ri) cont ri)) Just ((s,outGrpPre),qs') -> multiGroup ts w p e outGrpPreOuter qs' s (\h cont -> outGrpPre h (\ri -> outGrpPreInner (p<=si+ri) cont ri)) multiGroup (OpenNest n ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (\r ms fs -> cont r (applyNesting n w r ms) fs)) multiGroup (CloseNest ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (\r ms fs -> cont r (unApplyNesting ms) fs)) multiGroup (OpenFormat f ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (outFormat cont)) where outFormat cont r ms fs = applyFormat f ++ cont r ms (f:fs) multiGroup (CloseFormat ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (outUnformat cont)) where outUnformat cont r ms fs = applyFormat f ++ cont r ms ofs where (f, ofs) = resetFormat fs -- pruneOne checks whether the outermost group (in this case there is only one -- group) still fits in the current line. If it doesn't fit, it applies the -- corresponding `group output function` (the group is formatted vertically) -- and continues processing the token sequence pruneOne :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Out pruneOne ts w p e outGrpPre | p <= e = oneGroup ts w p e outGrpPre | otherwise = outGrpPre False (noGroup ts w p) -- pruneMulti checks whether the outermost group (in this case there are at -- least two groups) still fits in the current line. If it doesn't fit, it -- applies the corresponding `group output function` (the last queue entry) and -- continues checking whether the next outermost group fits pruneMulti :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Q.Queue (StartPosition, OutGroupPrefix) -> StartPosition -> OutGroupPrefix -> Out pruneMulti ts w p e outGrpPreOuter qs si outGrpPreInner | p <= e = multiGroup ts w p e outGrpPreOuter qs si outGrpPreInner | otherwise = outGrpPreOuter False (\r -> (case Q.matchLast qs of Nothing -> pruneOne ts w p (si+r) outGrpPreInner Just ((s,outGrpPre),qs') -> pruneMulti ts w p (s+r) outGrpPre qs' si outGrpPreInner) r) -------------------------------------------------------------------------------- -- Debugging -------------------------------------------------------------------------------- -- inspect the token sequence of a document inspect :: Doc -> Tokens inspect (Doc d) = normalise (d EOD) curry-tools-v3.3.0/cpm/vendor/xml/000077500000000000000000000000001377556325500171035ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/xml/LICENSE000066400000000000000000000027351377556325500201170ustar00rootroot00000000000000Copyright (c) 2017, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/cpm/vendor/xml/README.md000066400000000000000000000016101377556325500203600ustar00rootroot00000000000000# xml - Libraries for XML processing This package contains libraries for processing XML data, like reading and writing XML files, converting, or querying XML documents. Currently, it contains the following libraries: * `XML`: This module defines a datatype for representing XML data and operations for reading and writing XML data, e.g., which is stored in files. * `XmlConv`: This module provides type-based combinators to construct XML converters. * `XCuery`: This module defines combinators to search in XML documents. It is a literate Curry program which contains the paper [Declarative Processing of Semistructured Web Data](http://dx.doi.org/10.4230/LIPIcs.ICLP.2011.198) which appeared in the Technical Communications of the 27th International Conference on Logic Programming (ICLP 2011), Leibniz International Proceedings in Informatics (LIPIcs), Vol. 11, pp. 198-208, 2011 curry-tools-v3.3.0/cpm/vendor/xml/examples/000077500000000000000000000000001377556325500207215ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/xml/examples/XmlMatching.curry000066400000000000000000000064411377556325500242270ustar00rootroot00000000000000-- Some examples for matching in XML documents based on the `XCuery` library. -- -- Note that this module requires the installation -- of the package `setfunctions`! import Control.SetFunctions import XML import XCuery import Test.Prop -- Some sample XML documents: entry1 :: XmlExp entry1 = xml "entry" [xml "name" [xtxt "Hanus"], xml "first" [xtxt "Michael"], xml "phone" [xtxt "+49-431-8807271"], xml "email" [xtxt "mh@informatik.uni-kiel.de"], xml "email" [xtxt "hanus@acm.org"]] entry2 :: XmlExp entry2 = xml "entry" [xml "phone" [xtxt "+1-987-742-9388"], xml "name" [xtxt "Smith"], xml "first" [xtxt "William"], xml "nickname" [xtxt "Bill"]] contacts :: XmlExp contacts = xml "contacts" [entry1,entry2] -- Search for names and their phone numbers: getNamePhone :: XmlExp -> String getNamePhone (xml "entry" (with [xml "name" [xtxt name], xml "phone" [xtxt phone]])) = name ++ ": " ++ phone test1 = getNamePhone entry1 -=- "Hanus: +49-431-8807271" test2 = failing $ getNamePhone entry2 -- due to wrong order of phone/name -- Search for names and their phone numbers appearing in any order: getAnyNamePhone :: XmlExp -> String getAnyNamePhone (xml "entry" (with (anyorder [xml "phone" [xtxt phone], xml "name" [xtxt name]]))) = name ++ ": " ++ phone test3 = getAnyNamePhone entry2 -=- "Smith: +1-987-742-9388" -- Search for some email occurring anywhere (deep) in a document: getEmail :: XmlExp -> String getEmail (deepXml "email" [xtxt email]) = email test4 = getEmail contacts <~> ("hanus@acm.org" ? "mh@informatik.uni-kiel.de") -- Get all emails: allEmails :: [String] allEmails = sortValues ((set1 getEmail) contacts) test5 = allEmails -=- ["hanus@acm.org","mh@informatik.uni-kiel.de"] -- Negated patterns: constructive negation using `withOthers` combinator: -- get name/phone of all persons without email: getNamePhoneWithoutEmail :: XmlExp -> String getNamePhoneWithoutEmail (deepXml "entry" (withOthers (anyorder [xml "name" [xtxt name], xml "phone" [xtxt phone]]) others)) | "email" `noTagOf` others = name ++ ": " ++ phone noTagOf :: String -> [XmlExp] -> Bool noTagOf tag xmlexps = all (\xe -> tag /= (tagOf xe)) xmlexps test6 = getNamePhoneWithoutEmail contacts <~> "Smith: +1-987-742-9388" --- Transformation of contact data into the form (phone,fullname): transPhone :: XmlExp -> XmlExp transPhone (deepXml "entry" (with (anyorder ([xml "name" [xtxt name], xml "first" [xtxt first], xml "phone" [xtxt phone]])))) = xml "phonename" [xml "phone" [xtxt phone], xml "fullname" [xtxt (first++" "++name)]] phoneTable :: XmlExp phoneTable = xml "table" (sortValues ((set1 transPhone) contacts)) -- Collect results: -- Get all names with number of email addresses getEmails :: XmlExp -> (String,Int) getEmails (deepXml "entry" (withOthers [xml "name" [xtxt name]] others)) = (name, length (sortValues ((set1 emailOf) others))) emailOf :: [XmlExp] -> [XmlExp] emailOf (with [xml "email" email]) = email test8 = getEmails contacts <~> (("Hanus",2) ? ("Smith",0)) curry-tools-v3.3.0/cpm/vendor/xml/package.json000066400000000000000000000021071377556325500213710ustar00rootroot00000000000000{ "name": "xml", "version": "3.0.0", "author": "Michael Hanus ", "maintainer": "Michael Hanus ", "synopsis": "Libraries for XML processing", "category": [ "Data", "Web" ], "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "read-legacy": ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "XML", "XmlConv", "XCuery" ], "description": "This package contains libraries for processing XML data, like reading and writing XML files, converting, or querying XML documents.", "license": "BSD-3-Clause", "licenseFile": "LICENSE", "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/xml.git", "tag": "$version" }, "testsuite": [ { "src-dir": "src", "modules": [ "XML","XCuery" ] }, { "src-dir": "src", "options": "--nosource", "modules": [ "XmlConv" ] } ] } curry-tools-v3.3.0/cpm/vendor/xml/src/000077500000000000000000000000001377556325500176725ustar00rootroot00000000000000curry-tools-v3.3.0/cpm/vendor/xml/src/XCuery.lcurry000066400000000000000000001512461377556325500223640ustar00rootroot00000000000000\documentclass[12pt,fleqn]{article} \setlength{\textwidth}{16.0cm} \setlength{\textheight}{22cm} \setlength{\topmargin}{-1cm} \setlength{\oddsidemargin}{0cm} \setlength{\evensidemargin}{\oddsidemargin} \setlength{\marginparwidth}{0.0cm} \setlength{\marginparsep}{0.0cm} \usepackage{url} \def\UrlFont{\tt} \usepackage{xspace} \usepackage{hyperref} \usepackage{pdfpages} \usepackage{listings} \lstset{aboveskip=1.5ex, belowskip=1.5ex, showstringspaces=false, % no special string space mathescape=true, basewidth=0.5em, basicstyle=\small\ttfamily,% backgroundcolor=\color[rgb]{0.9,0.9,0.9}} \lstset{literate={->}{{$\rightarrow{}\!\!\!$}}3 {unknown}{{\char95}}1 } \lstnewenvironment{lcurry}{\lstset{firstline=2}}{} \lstnewenvironment{curry}{}{} \lstnewenvironment{xmldoc}{\lstset{backgroundcolor=\color{white}}}{} \newcommand{\listline}{\vrule width0pt depth1.75ex} \newcommand{\code}[1]{\texttt{#1}} \newcommand{\ccode}[1]{``\code{#1}''} \newcommand{\bs}{\char92\xspace} % backslash \newcommand{\us}{\char95\xspace} % underscore \newcommand{\funset}{\ensuremath{_{\cal S}}} \begin{document} \pagestyle{plain} \date{\small Technical Report 1103, March 2011} \sloppy %\includepdf[nup=1x1,pages=-]{cover.pdf} \setcounter{page}{1} \title{Declarative Processing of\\ Semistructured Web Data} \author{Michael Hanus\\[1ex] \small Institut f\"ur Informatik, CAU Kiel, D-24098 Kiel, Germany. \\ \small{\tt mh@informatik.uni-kiel.de} } \maketitle \begin{abstract} In order to give application programs access to data stored in the web in semistructured formats, in particular, in XML format, we propose a domain-specific language for declarative processing such data. Our language is embedded in the functional logic programming language Curry and offers powerful matching constructs that enable a declarative description of accessing and transforming XML data. We exploit advanced features of functional logic programming to provide a high-level and maintainable implementation of our language. Actually, this paper contains the complete code of our implementation so that the source text of this paper is an executable implementation of our language. \end{abstract} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Motivation} \label{sec:motivation} Nowadays, huge amounts of information are available in the world-wide web. Much of this information is also available in semistructured formats so that it can be automatically accessed by application programs. The extensible markup language (XML) is often used as an exchange format for such data. Since data in XML format are basically term structures, XML data can be (in principle) easily processed with functional or logic programming languages: one has to define a term representation of XML data in the programming language, implement a parser from the textual XML representation into such terms, and exploit pattern matching to implement the specific processing task. In practice, such an implementation causes some difficulties due to the fact that the concrete data formats are complex or evolve over time: \begin{itemize} \item For many application areas, concrete XML languages are defined. However, they are often quite complex so that it is difficult or tedious to deal with all details when one is interested in extracting only some parts of the given data. \item For more specialized areas without standardized XML languages, the XML format might be incompletely specified or evolves over time. Thus, application programs with standard pattern matching must be adapted if the data format changes. \end{itemize} % \begin{figure} \centering \begin{xmldoc} Hanus Michael +49-431-8807271 mh@informatik.uni-kiel.de hanus@acm.org Smith William Bill +1-987-742-9388 \end{xmldoc} \caption{A simple XML document} \label{fig:xml-contacts} \end{figure} % For instance, consider the XML document shown in Figure~\ref{fig:xml-contacts} which represents the data of a small address book. As one can see, the two entries have different information fields: the first entry contains two email addresses but no nickname whereas the second entry contains no email address but a nickname. Such data, which is not uncommon in practice, is also called ``semistructured'' \cite{AbiteboulBunemanSuciu00}. Semistructured data causes difficulties when it should be processed with a declarative programming language by mapping the XML structures into data terms of the implementation language. Therefore, various distinguished languages for processing XML data have been proposed. For instance, the language XPath\footnote{\url{http://www.w3.org/TR/xpath}} provides powerful path expressions to select sub-documents in XML documents. Although path expressions allow flexible retrievals by the use of wildcards, regular path expressions, stepping to father and sibling nodes etc, they are oriented towards following a path through the document from the root to the selected sub-documents. This gives them a more imperative rather than a descriptive or declarative flavor. The same is true for query and transformation languages like XQuery\footnote{\url{http://www.w3.org/XML/Query/}} or XSLT\footnote{\url{http://www.w3.org/TR/xslt}} which are based on the XPath-oriented style to select the required sub-documents. As an alternative to path-oriented processing languages, the language Xcerpt \cite{BrySchaffert02,BrySchaffertSchroeder05} is a proposal to exploit ideas from logic programming in order to provide a declarative method to select and transform semistructured data in XML format. In contrast to pure logic programming, Xcerpt proposes matching with partial term structures for which a specialized unification procedure, called ``simulation unification'' \cite{BrySchaffert02ICLP}, has been developed. Since matching with partial term structures is a powerful feature that avoids many problems related to the evolution of web data over time, we propose a language with similar features. However, our language is an embedded domain-specific language (eDSL). Due to the embedding into the functional logic programming language Curry \cite{Hanus06Curry}, our language for XML processing has the following features and advantages: \begin{itemize} \item The selection and transformation of incompletely specified XML data is supported. \item Due to the embedding into a universal programming language, the selected or transformed data can be directly used in the application program. \item Due to the use of advanced functional logic programming features, the implementation is straightforward and can be easily extended with new features. Actually, this paper contains the complete source code of the implementation. \item The direct implementation in a declarative language results in immediate correctness proofs of the implementation. \end{itemize} In the following, we present our language for XML processing together with their implementation. Since the implementation exploits features of modern functional logic programming languages, we review them in the next section before presenting our eDSL. \section{Functional Logic Programming and Curry} Curry \cite{Hanus06Curry} is a declarative multi-paradigm language combining features from functional programming (demand-driven evaluation, parametric polymorphism, higher-order functions) and logic programming (computing with partial information, unification, constraints). Recent surveys are available in \cite{AntoyHanus10CACM,Hanus07ICLP}. The syntax of Curry is close to Haskell\footnote{% Variables and function names usually start with lowercase letters and the names of type and data constructors start with an uppercase letter. The application of $f$ to $e$ is denoted by juxtaposition (``$f~e$'').} \cite{PeytonJones03Haskell}. In addition, Curry allows free (logic) variables in conditions and right-hand sides of defining rules. The operational semantics is based on an optimal evaluation strategy \cite{AntoyEchahedHanus00JACM} which is a conservative extension of lazy functional programming and (concurrent) logic programming. A Curry program consists of the definition of data types and operations on these types. Note that in a functional logic language operations might yield more than one result on the same input due to the logic programming features. Thus, Curry operations are not functions in the classical mathematical sense so that they are sometimes called ``nondeterministic functions'' \cite{GonzalezEtAl99}. Nevertheless, a Curry program has a purely declarative semantics where nondeterministic operations are modeled as set-valued functions (to be more precise, down-closed partially ordered sets are used as target domains in order to cover non-strictness, see \cite{GonzalezEtAl99} for a detailed account of this model-theoretic semantics). For instance, Curry contains a \emph{choice} operation defined by: % \begin{curry} x ? _ = x _ ? y = y \end{curry} % Thus, the expression \ccode{0$~$?$~$1} has two values: \code{0} and \code{1}. If expressions have more than one value, one wants to select intended values according to some constraints, typically in conditions of program rules. A \emph{rule} has the form \ccode{$f~t_1\ldots{}t_n$ | $c$ = $e$} where the (optional) condition $c$ is a \emph{constraint}, i.e., an expression of the built-in type \code{Success}. For instance, the trivial constraint \code{success} is a value of type \code{Success} that denotes the always satisfiable constraint. Thus, we say that a constraint $c$ is \emph{satisfied} if it can be evaluated to \code{success}. An \emph{equational constraint} $e_1 \,\code{=:=}\, e_2$ is satisfiable if both sides $e_1$ and $e_2$ are reducible to unifiable values. Furthermore, if $c_1$ and $c_2$ are constraints, \code{$c_1\,$\&$\,\,c_2$} denotes their concurrent conjunction (i.e., both argument constraints are concurrently evaluated). As a simple example, consider the following Curry program which defines a polymorphic data type for lists and operations to compute the concatenation of lists and the last element of a list:\footnote{Note that lists are a built-in data type with a more convenient syntax, e.g., one can write \code{[x,y,z]} instead of \code{x:y:z:[]} and \code{[a]} instead of the list type \ccode{List a}.} % \begin{curry} data List a = [] | a : List a --[a] denotes "List a" -- "++" is a right-associative infix operator (++) :: [a] -> [a] -> [a] [] ++ ys = ys (x:xs) ++ ys = x : (xs ++ ys) last :: [a] -> a last xs | (ys ++ [z]) =:= xs = z where ys,z free \end{curry} % Logic programming is supported by admitting function calls with free variables (e.g., \code{(ys++[z])} in the rule defining \code{last}) and constraints in the condition of a defining rule. In contrast to Prolog, free variables need to be declared explicitly to make their scopes clear (e.g., \ccode{where ys,z free} in the example). A conditional rule is applicable if its condition is satisfiable. Thus, the rule defining \code{last} states in its condition that \code{z} is the last element of a given list \code{xs} if there exists a list \code{ys} such that the concatenation of \code{ys} and the one-element list \code{[z]} is equal to the given list \code{xs}. The combination of functional and logic programming features has led to new design patterns \cite{AntoyHanus02FLOPS} and better abstractions for application programming, e.g., as shown for programming with databases \cite{BrasselHanusMueller08PADL,Fischer05}, GUI programming \cite{Hanus00PADL}, web programming \cite{Hanus01PADL,Hanus06PPDP,HanusKoschnicke10PADL}, or string parsing \cite{CaballeroLopez99}. In this paper, we show how to exploit these combined features to implement an eDSL for XML processing. To make this implementation as simple as possible, we exploit two more recent features described in the following: functional patterns \cite{AntoyHanus05LOPSTR} and set functions \cite{AntoyHanus09}. A fundamental requirement in functional as well as logic languages is that patterns in the left-hand sides of program rules contain only variables and data constructors. This excludes rules like \begin{curry} (xs ++ ys) ++ zs = xs ++ (ys ++ zs) \end{curry} stating the associativity property of list concatenation. This restriction is the key to construct efficient evaluation strategies \cite{Hanus07ICLP}. However, in a functional logic language one can relax this requirement and allow expressions containing defined operations in patterns as an abbreviation for a (potentially infinite) set of ``standard'' patterns. A pattern containing defined operations is called \emph{functional pattern}. For instance, \begin{curry} last (xs ++ [e]) = e \end{curry} is a rule with the functional pattern \code{(xs++[e])} stating that \code{last} is reducible to \code{e} provided that the argument can be matched against some value of \code{(xs++[e])} where \code{xs} and \code{e} are free variables. By instantiating \code{xs} to arbitrary lists, the value of \code{(xs++[e])} is any list having \code{e} as its last element. The semantics of functional patterns can be defined in terms of standard pattern by interpreting a functional pattern as the set of all constructor terms that is the result of evaluating (by narrowing \cite{AntoyEchahedHanus00JACM}) the functional pattern. Thus, the above rule abbreviates the following (infinite) set of rules: \begin{curry} last [e] = e last [x1,e] = e last [x1,x2,e] = e $\ldots$ \end{curry} As we will see in this paper, functional patterns are a powerful feature to express arbitrary selections in term structures. In order to assign a reasonable semantics to functional patterns, one need syntactic conditions (like stratification) to ensure meaningful definitions (e.g., the above rule stating associativity of \ccode{++} is not allowed). Detailed requirements and a constructive implementation of functional patterns by a demand-driven unification procedure can be found in \cite{AntoyHanus05LOPSTR}. If nondeterministic programming techniques are applied, it is sometimes useful to collect all the values of some expression, e.g., to accumulate all results of a query. A ``set-of-values'' operation applied to an arbitrary argument might depend on the degree of evaluation of the argument, which is difficult to grasp in a non-strict language. Hence, \emph{set functions} \cite{AntoyHanus09} have been proposed to encapsulate nondeterministic computations in non-strict functional logic languages. For each defined function $f$, $f\funset$ denotes the corresponding set function. In order to be independent of the evaluation order, $f\funset$ encapsulates only the nondeterminism caused by evaluating $f$ except for the nondeterminism caused by evaluating the arguments to which $f$ is applied. For instance, consider the operation \code{decOrInc} defined by \begin{curry} decOrInc x = (x-1) ? (x+1) \end{curry} Then \ccode{decOrInc$\funset$ 3} evaluates to (an abstract representation of) the set $\{\code{2},\code{4}\}$, i.e., the nondeterminism caused by \code{decOrInc} is encapsulated into a set. However, \ccode{decOrInc$\funset$ (2?5)} evaluates to two different sets $\{\code{1},\code{3}\}$ and $\{\code{4},\code{6}\}$ due to its nondeterministic argument, i.e., the nondeterminism caused by the argument is not encapsulated. As already mentioned, this paper contains the complete source code of our implementation. Actually, it is a literate program \cite{Knuth84}, i.e., the paper's source text is directly executable. In a literate Curry program, all real program code starts with the special character \ccode{>}. Curry code not starting with \ccode{>}, e.g., the example code shown so far, is like a comment and not required to run the program. To give an example of executable code, we show the declaration of the module \code{XCuery} for XML processing in Curry developed in this paper: \begin{lcurry} > module XCuery where > > import XML \end{lcurry} % Thus, we import the system module \code{XML} which contains an XML parser and the definition of XML structures in Curry that are explained in the next section. \section{XML Documents} There are two basic methods to represent XML documents in a programming language: a type-based or a generic representation \cite{WallaceRunciman99}. In a type-based representation, each tagged XML structure (like \code{contacts}, \code{entry}, \code{name} etc) is represented as a record structure of appropriate type according to the XML schema. The advantage of this approach is that schema-correct XML structures correspond to type-correct record structures. On the negative side, this representation depends on the given XML schema. Thus, it is hardly applicable if the schema is not completely known. Moreover, if the schema evolves, the data types representing the XML structure must be adapted. Due to these reasons, we prefer a generic representation where any XML document is represented with one generic structure. Since any XML document is either a structure with a tag, attributes and embedded XML documents (also call \emph{child nodes} of the document), or a text string, one can define the following datatype to represent XML documents:\footnote{% For the sake of simplicity, we ignore other specific elements like comments.} \begin{curry} data XmlExp = XText String | XElem String [(String,String)] [XmlExp] \end{curry} For instance, the second \code{entry} structure of the XML document shown in Figure~\ref{fig:xml-contacts} can be represented by the data term \begin{curry} XElem "entry" [] [XElem "name" [] [XText "Smith"], XElem "first" [] [XText "William"], XElem "nickname" [] [XText "Bill"], XElem "phone" [] [XText "+1-987-742-9388"]] \end{curry} % Since it could be tedious to write XML documents with these basic data constructors, one can define some useful abstractions for XML documents: \begin{curry} xtxt :: String -> XmlExp xtxt s = XText s xml :: String -> [XmlExp] -> XmlExp xml t xs = XElem t [] xs \end{curry} % Thus, we can specify the previous document a bit more compact: \begin{curry} xml "entry" [xml "name" [xtxt "Smith"], xml "first" [xtxt "William"], xml "nickname" [xtxt "Bill"], xml "phone" [xtxt "+1-987-742-9388"]] \end{curry} % These definitions together with operations to parse and pretty-print XML documents are contained in the system module \code{XML} of the PAKCS programming environment for Curry \cite{Hanus10PAKCS}. In principle, these definitions are sufficient for XML processing, i.e., to select and transform XML documents. For instance, one can extract the name and phone number of an \code{entry} structure consisting of a name, first name and phone number by the following operation: \begin{curry} getNamePhone (XElem "entry" [] [XElem "name" [] [XText name], _, XElem "phone" [] [XText phone]]) = name++": "++phone \end{curry} This can be also implemented in a similar way in other functional or logic programming languages. However, functional logic languages support a nicer way to write such matchings. Whereas typical functional or logic languages require the use of data constructors in patterns, functional patterns allow also to use already defined abstractions in patterns so that we can define the previous operation also in the following form: \begin{curry} getNamePhone (xml "entry" [xml "name" [xtxt name], _, xml "phone" [xtxt phone]]) = name++": "++phone \end{curry} This shows how functional patterns improves the readability of pattern matching by reusing already defined abstractions also in patterns and not only to construct new data in right-hand sides of program rules. Apart from these advantages, XML processing operations as defined above have several disadvantages: \begin{itemize} \item The exact structure of the XML document must be known in advance. For instance, the operation \code{getNamePhone} matches only entries with three components, i.e., it fails on both entries shown in Figure~\ref{fig:xml-contacts}. \item In large XML documents, many parts are often irrelevant if one wants to select only some specific information entities. However, one has to define an operation to match the complete document. \item If the structure of the XML document changes (e.g., due to the evolution of the web services providing these documents), one has to update all patterns in the matching operations which could be tedious and error prone for large documents. \end{itemize} % As a solution to these problems, we propose in the next section appropriate abstractions that can be used in patterns of operations for XML processing. \section{Abstractions for XML Processing} In order to define reasonable abstractions for XML processing, we start with a wish list. Since we have seen that exact matchings are not desirable to process semistructured data, we want to develop a language supporting the following features for pattern matching: \begin{itemize} \item \emph{Partial patterns:} allow patterns where only some child nodes are known. \item \emph{Unordered patterns:} allow patterns where child nodes can appear in any order. \item \emph{Patterns at arbitrary depth:} allow patterns that are matched at an arbitrary position in an XML document. \item \emph{Negation of patterns:} allow patterns defined by the absence of tags or provide default values for tags that are not present in the given XML document. \item \emph{Transformation:} generate new structures from matched patterns. \item \emph{Collect matchings:} accumulate results in a newly generated structure. \end{itemize} In the following, we show how these features can be supported by the use of carefully defined abstractions as functional patterns and other features of functional logic programming. \subsection{Partial Patterns} As we have seen in the example operation \code{getNamePhone} above, one would like to select some child nodes in a document independent of the availability of further components. Thus, instead of enumerating the list of \emph{all} child nodes as in the definition above, it would be preferable to enumerate only the relevant child nodes. We support this by putting the operator \ccode{with} in front of the list of child nodes: \begin{curry} getNamePhone (xml "entry" (with [xml "name" [xtxt name], xml "phone" [xtxt phone]])) = name++": "++phone \end{curry} The intended meaning of \ccode{with} is that the given child nodes must be present but in between any number of other elements can also occur. We can directly implement this operator as follows:\footnote{% The symbol ``\lstinline{unknown}'' denotes an anonymous variable, i.e., each occurrence of ``\lstinline{unknown}'' in the right-hand side of a rule denotes a fresh logic variable.} \begin{lcurry} > with :: Data a => [a] -> [a] > with [] = unknown > with (x:xs) = unknown ++ x : with xs \end{lcurry} Thus, an expression like \ccode{with [1,2]} reduces to any list of the form \begin{curry} $x_1$:$\ldots$:$x_m$:1:$y_1$:$\ldots$:$y_n$:2:$zs$ \end{curry} where the variables $x_i,y_j,zs$ are fresh logic variables. Due to the semantics of functional patterns, the definition of \code{getNamePhone} above matches any \code{entry} structure containing a \code{name} and a \code{phone} element as children. Hence, the use of the operation \code{with} in patterns avoids the exact enumeration of all children and makes the program robust against the addition of further information elements in a structure. A disadvantage of a definition like \code{getNamePhone} above is the fact that it matches only XML structures with an empty attribute list due to the definition of the operation \code{xml}. In order to support more flexible matchings that are independent of the given attributes (which are ignored if present), we define the operation \label{sec:xmlprime} \begin{lcurry} > xml' :: String -> [XmlExp] -> XmlExp > xml' t xs = XElem t unknown xs \end{lcurry} For instance, the operation \code{getName} defined by \begin{curry} getName (xml' "entry" (with [xml' "name" [xtxt n]])) = n \end{curry} returns the name of an \code{entry} structure independent of the fact whether the given document contains attributes in the \code{entry} or \code{name} structures. \subsection{Unordered Patterns} If the structure of data evolves over time, it might happen that the order of elements changes over time. Moreover, even in some given XML schema, the order of relevant elements can vary. In order to make the matching independent of a particular order, we can specify that the required child nodes can appear in any order by putting the operator \ccode{anyorder} in front of the list of child nodes: \begin{curry} getNamePhone (xml "entry" (with (anyorder [xml "phone" [xtxt phone], xml "name" [xtxt name]]))) = name++": "++phone \end{curry} Obviously, the operation \code{anyorder} should compute any permutation of its argument list. In a functional logic language, it can be easily defined as a nondeterministic operation by inserting the first element of a list at an arbitrary position in the permutation of the remaining elements: \begin{lcurry} > anyorder :: [a] -> [a] > anyorder [] = [] > anyorder (x:xs) = insert (anyorder xs) > where insert [] = [x] > insert (y:ys) = x:y:ys ? y : insert ys \end{lcurry} % Thus, the previous definition of \code{getNamePhone} matches both \code{entry} structures shown in Figure~\ref{fig:xml-contacts}. \subsection{Patterns at Arbitrary Depths} \label{sec:deepxml} If one wants to select some information in deeply nested documents, it would be tedious to define the exact matching from the root to the required elements. Instead, it is preferable to allow matchings at an arbitrary depth in a document. Such matchings are also supported in other languages like XPath since they ease the implementation of queries in complex structures and support flexibility of the implementation w.r.t.\ to future structural changes of the given documents. We support this feature by an operation \ccode{deepXml}: if \code{deepXml} is used instead of \code{xml} in a pattern, this structure can occur at an arbitrary position in the given document. For instance, if we define \begin{curry} getNamePhone (deepXml "entry" (with [xml "name" [xtxt name], xml "phone" [xtxt phone]])) = name++": "++phone \end{curry} and apply \code{getNamePhone} to the complete document shown in Figure~\ref{fig:xml-contacts}, two results are (nondeterministically) computed (methods to collect all those results are discussed later). The implementation of \code{deepXml} is similar to \code{with} by specifying that \code{deepXml} reduces to a structure where the node is at the root or at some nested child node: \begin{lcurry} > deepXml :: String -> [XmlExp] -> XmlExp > deepXml tag elems = xml tag elems > deepXml tag elems = xml' unknown (unknown ++ [deepXml tag elems] ++ unknown) \end{lcurry} Thus, an expression like \ccode{deepXml $t$ $cs$} reduces to \ccode{xml $t$ $cs$} or to a structure containing this element at some inner position. \subsection{Negation of Patterns} As mentioned above, in semistructured data some information might not be present in a given structure, like the email address in the second entry of Figure~\ref{fig:xml-contacts}. Instead of failing on missing information pieces, one wants to have a constructive behavior in application programs. For instance, one could select all entries with a missing email address or one puts a default nickname in the output if the nickname is missing. In order to implement such behaviors, one could try to negate matchings. Since negation is a non-trivial subject in functional logic programming, we propose a much simpler but practically reasonable solution. We provide an operation \ccode{withOthers} which is similar to \ccode{with} but has a second argument that contains the child nodes that are present but not part of the first argument. Thus, one can use this operation to denote the ``unmatched'' part of a document in order to put arbitrary conditions on it. For instance, if we want to get the name and phone number of an entry that has no email address, we can specify this as follows: \begin{curry} getNamePhoneWithoutEmail (deepXml "entry" (withOthers [xml "name" [xtxt name], xml "phone" [xtxt phone]] others)) | "email" `noTagOf` others = name++": "++phone \end{curry} The useful predicate \code{noTagOf} returns true if the given tag is not a tag of all argument documents (the operation \code{tagOf} returns the tag of an XML document): \begin{lcurry} > noTagOf :: String -> [XmlExp] -> Bool > noTagOf tag = all ((/=tag) . tagOf) \end{lcurry} % Hence, the application of \code{getNamePhoneWithoutEmail} to the document in Figure~\ref{fig:xml-contacts} returns a single value. The implementation of \code{withOthers} is slightly different from \code{with} since we have to accumulate the remaining elements that are not part of the first arguments in the second argument: \begin{lcurry} > withOthers :: Data a => [a] -> [a] -> [a] > withOthers ys zs = withAcc [] ys zs > where -- Accumulate remaining elements: > withAcc prevs [] others | others=:=prevs++suffix = suffix > where suffix free > withAcc prevs (x:xs) others = > prefix ++ x : withAcc (prevs++prefix) xs others > where prefix free \end{lcurry} Thus, an expression like \ccode{withOthers [1,2] $os$} reduces to any list of the form \begin{curry} $x_1$:$\ldots$:$x_m$:1:$y_1$:$\ldots$:$y_n$:2:$zs$ \end{curry} where \code{$os$ $=$ $x_1$:$\ldots$:$x_m$:$y_1$:$\ldots$:$y_n$:$zs$}. If we use this expression as a pattern, the semantics of functional patterns ensures that this pattern matches any list containing the elements \code{1} and \code{2} where the variable $os$ is bound to the list of the remaining elements. \subsection{Transformation of Documents} Apart from the inclusion of data selected in XML documents in the application program, one also wants to implement transformations on documents, e.g., transform an XML document into a corresponding HTML document. Such transformation tasks are almost trivial to implement in declarative languages supporting pattern matching by using a scheme like \[ \mathit{transform}~pattern~=~newdoc \] and applying the $\mathit{transform}$ operation to the given document. For instance, we can transform an \code{entry} document into another XML structure containing the phone number and full name of the person by \label{ex:transphone} \begin{curry} transPhone (deepXml "entry" (with [xml "name" [xtxt n], xml "first" [xtxt f], xml "phone" phone])) = xml "phonename" [xml "phone" phone, xml "fullname" [xtxt (f++' ':n)]] \end{curry} If we apply \code{transPhone} to the document of Figure~\ref{fig:xml-contacts}, we nondeterministically obtain two new XML documents corresponding to the two entries contained in this document. \subsection{Collect Matchings} If we want to collect all matchings in a given document in a single new document, we have to encapsulate the nondeterministic computations performed on the input document. For this purpose, we can exploit set functions described above. Since set functions return an unordered set of values, we have to transform this value set into an ordered list structure that can be printed or embedded in another document. This can be done by the predefined operation \code{sortValues}. Thus, if $c$ denotes the XML document shown in Figure~\ref{fig:xml-contacts}, we can use our previous transformation operation to create a complete table of all pairs of phone numbers and full names by evaluating the expression\footnote{% In the implementation of set functions in the PAKCS environment \cite{Hanus10PAKCS}, one has to write \code{(set$n$ $f$)} for the set function corresponding to the $n$-ary operation $f$.} \begin{curry} xml "table" (sortValues (transPhone$\funset$ $c$)) \end{curry} which yields the representation of the XML document \begin{xmldoc} +1-987-742-9388 William Smith +49-431-8807271 Michael Hanus
\end{xmldoc} Similarly, one can also transform XML documents into HTML documents by exploiting the HTML library of Curry \cite{Hanus01PADL}. Furthermore, one can also nest set functions to accumulate intermediate information. As an example, we want to compute a list of all persons together with the number of their email addresses. For this purpose, we define a matching rule for an \code{entry} document that returns the number of email addresses in this document by a set function \code{emailOf$\funset$}: \begin{curry} getEmails (deepXml "entry" (withOthers [xml "name" [xtxt name]] os)) = (name, length (sortValues (emailOf$\funset$ os))) where emailOf (with [xml "email" email]) = email \end{curry} In order to compute a complete list of all entries matched in a document $c$, we apply the set function \code{getEmails$\funset$} to collect all results in a list structure: \begin{curry} sortValues (getEmails$\funset$ $c$) \end{curry} For our example document, this evaluates to \code{[("Hanus",2),("Smith",0)]}. \subsection{Attribute Matchings} So far we have only defined matchings of XML structures where the attributes are not taken into account. If we want to match on attribute values, we can also use the generic matching operators like \code{with}, \code{anyorder}, or \code{withOthers} for this purpose. For instance, if the \code{first} structure of an XML document contains an attribute \code{sex} to indicate the gender, we can select all male first names by the operation \label{ex:getMaleFirstNames} \begin{curry} getMaleFirstNames (deepXml "entry" (with [XElem "first" (with [("sex","male")]) [xtxt f]])) = f \end{curry} Here, we use the pattern \code{(with [("sex","male")])} for the attribute list in order to match on any occurrence of the attribute \code{sex} with value \code{male}. \section{Properties of the Implementation} \subsection{Correctness} As shown in the previous section, the matching operations are quite powerful and can be directly implemented in a functional logic language. This has the advantage that the correctness of the implemented matching operations is a direct consequence of the correctness results for functional logic programming. We demonstrate this reasoning by a simple example. Consider the following operation to select a name in an \code{entry} document: \begin{curry} getName (xml "entry" (with [xml "name" [xtxt n]])) = n \end{curry} In order to show the correctness of this operation, we have to show the following property ($\to^*$ denotes the evaluation relation): \paragraph{\textbf{Proposition:}} If $xdoc = \code{xml "entry" [\ldots,xml "name" [xtxt $n$],\ldots]}$, then \code{getName $x$ $\to^*$ $n$}. \medskip Since the formal definition of the semantics of functional logic programming is outside the scope of this paper, we provide only a proof sketch. The definition of \code{with} implies that the expression \code{(with [xml "name" [xtxt n]])} evaluates to \begin{curry} x$_1$:$\ldots$:x$_m$:xml "name" [xtxt n]:ys \end{curry} for any $m \geq 0$. Hence, by the semantics of functional patterns, \begin{curry} getName (xml "entry" (x$_1$:$\ldots$:x$_m$:xml "name" [xtxt n]:ys)) = n \end{curry} is a rule defining \code{getName} for any $m \geq 0$ (more precisely, we must also evaluate the operations \code{xml} and \code{xtxt}, but we omit this detail here). Thus, \begin{curry} getName $xdoc$ $~\to^*~$ $n$ \end{curry} is a valid rewrite step. \subsection{Termination} A functional pattern like \code{(with [xml "name" [xtxt n]])} denotes an infinite set of constructor patterns, i.e., it denotes all constructor patterns of the form \begin{curry} x$_1$:$\ldots$:x$_m$:xml "name" [xtxt n]:ys \end{curry} for any $m \geq 0$. Thus, it is not obvious that a search for all possible matchings, which is usually performed by set functions in order to collect all results, will ever terminate. In principle, general termination criteria for functional logic programs with functional patterns are not yet known. However, it should be noted that the set of constructor patterns represented by a functional patterns is not blindly enumerated. Actually, the corresponding constructor patterns are generated in a demand-driven manner, i.e., new constructor patterns are computed only if they are demanded to match the actual argument. Thus, the structure of the actual argument determines how far the operations in the functional patterns are evaluated (see \cite{AntoyHanus05LOPSTR} for more details about the demand-driven unification procedure). Hence, the finite size of the actual arguments (i.e., the XML documents) implies the finiteness of the set of constructor patterns that are computed to match the actual argument.\footnote{% Obviously, this need not be the case for general functional patterns. For instance, if the pattern contains a non-terminating operation like \ccode{loop = loop}, the functional pattern unification will not terminate. However, our operations have the property that a data constructor is produced around each recursive call. Thus, an infinite recursion results in constructor terms of infinite size.} Therefore, the search space is finite in all our examples. \subsection{Performance} Our implementation heavily exploits nondeterministic computations, e.g., when matching partially specified or deep structures, a nondeterministic guessing of appropriate patterns takes place. This raises the question whether this approach can be used in practice. Since our main emphasis is on expressiveness (i.e., we want to be able to express selections and transformations in a declarative rather than navigational manner), we do not intend to compete in performance with specialized languages for XML processing. For our purpose it is sufficient, to be practically useful, that there is a reasonable relation between the time to read an XML document and the time to process it, because each XML document must be read from a file or network connection before processing it. Our first practical experiments (using the PAKCS environment \cite{Hanus10PAKCS} which compiles Curry programs into Prolog programs that are executed by SICStus-Prolog) indicate that the processing time to select or transform documents is almost equal or smaller than the parsing time. Since the XML parser is implemented by deterministic operations without any nondeterministic steps, this shows that the nondeterminism used to implement our matching operators does not hinder the practical application of our implementation. \section{Related Work} Since the processing of semistructured data is a relevant issue in current application systems, there are many proposals for specialized languages or embedding languages in multi-purpose programming languages. We discuss some related approaches in this section. We have already mentioned in the beginning the languages XPath, XQuery, and XSLT for XML processing supported by the W3C. These languages provide a different XML-oriented syntax and use a navigational approach to select information rather than the pattern-oriented approach we proposed. Since these are separate languages, it is more difficult to use them in application programs written in a general purpose language where one wants to process data available in the web. The same is true for the language Xcerpt \cite{BrySchaffert02,BrySchaffertSchroeder05}. It is also a separate XML processing language without a close connection to a multi-purpose programming language. In contrast to XPath, Xcerpt proposes the use of powerful matching constructs to select information in semistructured documents. Xcerpt supports similar features as our embedded language but provide a more compact syntax due to its independence of a concrete base language. In contrast to our approach, Xcerpt requires a dedicated implementation based on a specialized unification procedure \cite{BrySchaffert02ICLP}. The disadvantages of such separate developments become obvious if one tries to access the implementation of Xcerpt (which failed at the time of this writing due to inaccessible web pages and incompatible compiler versions). HaXML \cite{WallaceRunciman99} is a language for XML processing embedded in the functional language Haskell. It provides a rich set of combinators based on \emph{content filters}, i.e., functions that map XML data into collections of XML data. This allows an elegant description of many XML transformations, whereas our rule-based approach is not limited to such transformations since we have no restrictions on the type of data constructed from successful matchings. Caballero et al.\ \cite{CaballeroEtAl10} proposed the embedding of XPath into the functional logic language Toy that has many similarities to Curry. Similarly to our approach, they also exploit nondeterministic evaluation for path selection. Due to the use of a functional logic language allowing inverse computations, they also support the generation of test cases for path expressions, i.e., the generation of documents to which a path expression can be applied. Nevertheless, their approach is limited to the navigational processing of XPath rather than a rule-based approach as in our case. The same holds for FnQuery \cite{SeipelBaumeisterHopfner05}, a domain-specific language embedded in Prolog for the querying and transformation of XML data. \section{Conclusions} We have presented a rule-based language for processing semistructured data that is implemented and embedded in the functional logic language Curry. The language supports a declarative description to query and transform such data. It is based on providing operations to describe partial matchings in the data and exploits functional patterns and set functions for the programming tasks. Due to its embedding into a general-purpose programming language, it can be used to further process the selected data in application systems or one can combine semistructured data from different sources. Moreover, it is easy to extend our language with new features without adapting a complex implementation. The simplicity of our implementation together with the expressiveness of our language demonstrate the general advantages of high-level declarative programming languages. In order to check the usability of our language, we applied it to extract information provided by our university information system\footnote{\url{http://univis.uni-kiel.de/}} in XML format into a curricula and module information system% \footnote{\url{http://www-ps.informatik.uni-kiel.de/~mh/studiengaenge/}} that is implemented in Curry. In this application it was quite useful to specify only partial patterns so that most of the huge amount of information contained in the XML document could be ignored. For future work, we intend to apply our language to more examples in order to enrich the set of useful pattern combinators. Moreover, it would be interesting to generate more efficient implementations by specializing functional patterns (e.g., by partial evaluation w.r.t.\ the given definitions, or by exploiting the XML schema if it is precisely known in advance). \begin{thebibliography}{10} \bibitem{AbiteboulBunemanSuciu00} S.~Abiteboul, P.~Buneman, and D.~Suciu. \newblock {\em Data on the Web: From Relations to Semistructured Data and XML}. \newblock Morgan Kaufmann, 2000. \bibitem{AntoyEchahedHanus00JACM} S.~Antoy, R.~Echahed, and M.~Hanus. \newblock A Needed Narrowing Strategy. \newblock {\em Journal of the ACM}, Vol.~47, No.~4, pp. 776--822, 2000. \bibitem{AntoyHanus02FLOPS} S.~Antoy and M.~Hanus. \newblock Functional Logic Design Patterns. \newblock In {\em Proc.\ of the 6th International Symposium on Functional and Logic Programming (FLOPS 2002)}, pp. 67--87. Springer LNCS 2441, 2002. \bibitem{AntoyHanus05LOPSTR} S.~Antoy and M.~Hanus. \newblock Declarative Programming with Function Patterns. \newblock In {\em Proceedings of the International Symposium on Logic-based Program Synthesis and Transformation (LOPSTR'05)}, pp. 6--22. Springer LNCS 3901, 2005. \bibitem{AntoyHanus09} S.~Antoy and M.~Hanus. \newblock Set Functions for Functional Logic Programming. \newblock In {\em Proceedings of the 11th ACM SIGPLAN International Conference on Principles and Practice of Declarative Programming (PPDP'09)}, pp. 73--82. ACM Press, 2009. \bibitem{AntoyHanus10CACM} S.~Antoy and M.~Hanus. \newblock Functional Logic Programming. \newblock {\em Communications of the ACM}, Vol.~53, No.~4, pp. 74--85, 2010. \bibitem{BrasselHanusMueller08PADL} B.~Bra{\ss}el, M.~Hanus, and M.~M{\"u}ller. \newblock High-Level Database Programming in {Curry}. \newblock In {\em Proc. of the Tenth International Symposium on Practical Aspects of Declarative Languages (PADL'08)}, pp. 316--332. Springer LNCS 4902, 2008. \bibitem{BrySchaffert02} F.~Bry and S.~Schaffert. \newblock A gentle introduction to {Xcerpt}, a rule-based query and transformation language for {XML}. \newblock In {\em Proceedings of the International Workshop on Rule Markup Languages for Business Rules on the Semantic Web (RuleML'02)}, 2002. \bibitem{BrySchaffert02ICLP} F.~Bry and S.~Schaffert. \newblock Towards a Declarative Query and Transformation Language for {XML} and Semistructured Data: Simulation Unification. \newblock In {\em Proceedings of the International Conference on Logic Programming (ICLP'02)}, pp. 255--270. Springer LNCS 2401, 2002. \bibitem{BrySchaffertSchroeder05} F.~Bry, S.~Schaffert, and A.~Schroeder. \newblock A Contribution to the Semantics of {Xcerpt}, a Web Query and Transformation Language. \newblock In {\em Applications of Declarative Programming and Knowledge Management (INAP/WLP 2004)}, pp. 258--268. Springer LNCS 3392, 2005. \bibitem{CaballeroEtAl10} R.~Caballero, Y.~Garc{\'\i}a-Ruiz, and F.~S{\'a}enz-P{\'e}rez. \newblock Integrating {XPath} with the Functional-Logic Language {Toy}. \newblock Technical Report SIC-05-10, Univ. Complutense de Madrid, 2010. \bibitem{CaballeroLopez99} R.~Caballero and F.J. L{\'o}pez-Fraguas. \newblock A Functional-Logic Perspective of Parsing. \newblock In {\em Proc. 4th Fuji International Symposium on Functional and Logic Programming (FLOPS'99)}, pp. 85--99. Springer LNCS 1722, 1999. \bibitem{Fischer05} S.~Fischer. \newblock A Functional Logic Database Library. \newblock In {\em Proc. of the ACM SIGPLAN 2005 Workshop on Curry and Functional Logic Programming (WCFLP 2005)}, pp. 54--59. ACM Press, 2005. \bibitem{GonzalezEtAl99} J.C. Gonz{\'a}lez-Moreno, M.T. Hortal{\'a}-Gonz{\'a}lez, F.J. L{\'o}pez-Fraguas, and M.~Rodr{\'\i}guez-Artalejo. \newblock An approach to declarative programming based on a rewriting logic. \newblock {\em Journal of Logic Programming}, Vol.~40, pp. 47--87, 1999. \bibitem{Hanus00PADL} M.~Hanus. \newblock A Functional Logic Programming Approach to Graphical User Interfaces. \newblock In {\em International Workshop on Practical Aspects of Declarative Languages (PADL'00)}, pp. 47--62. Springer LNCS 1753, 2000. \bibitem{Hanus01PADL} M.~Hanus. \newblock High-Level Server Side Web Scripting in {Curry}. \newblock In {\em Proc.\ of the Third International Symposium on Practical Aspects of Declarative Languages (PADL'01)}, pp. 76--92. Springer LNCS 1990, 2001. \bibitem{Hanus06PPDP} M.~Hanus. \newblock Type-Oriented Construction of Web User Interfaces. \newblock In {\em Proceedings of the 8th ACM SIGPLAN International Conference on Principles and Practice of Declarative Programming (PPDP'06)}, pp. 27--38. ACM Press, 2006. \bibitem{Hanus07ICLP} M.~Hanus. \newblock Multi-paradigm Declarative Languages. \newblock In {\em Proceedings of the International Conference on Logic Programming (ICLP 2007)}, pp. 45--75. Springer LNCS 4670, 2007. \bibitem{Hanus10PAKCS} M.~Hanus, S.~Antoy, B.~Bra{\ss}el, M.~Engelke, K.~H{\"o}ppner, J.~Koj, P.~Niederau, R.~Sadre, and F.~Steiner. \newblock {PAKCS}: The {P}ortland {A}achen {K}iel {C}urry {S}ystem. \newblock Available at \url{http://www.informatik.uni-kiel.de/~pakcs/}, 2010. \bibitem{HanusKoschnicke10PADL} M.~Hanus and S.~Koschnicke. \newblock An {ER-based} Framework for Declarative Web Programming. \newblock In {\em Proc. of the 12th International Symposium on Practical Aspects of Declarative Languages (PADL 2010)}, pp. 201--216. Springer LNCS 5937, 2010. \bibitem{Hanus06Curry} M.~Hanus~(ed.). \newblock Curry: An Integrated Functional Logic Language (Vers.\ 0.8.2). \newblock Available at \url{http://www.curry-language.org}, 2006. \bibitem{Knuth84} D.E. Knuth. \newblock Literate Programming. \newblock {\em The Computer Journal}, Vol.~27, No.~2, pp. 97--111, 1984. \bibitem{PeytonJones03Haskell} S.~Peyton~Jones, editor. \newblock {\em Haskell 98 Language and Libraries---The Revised Report}. \newblock Cambridge University Press, 2003. \bibitem{SeipelBaumeisterHopfner05} D.~Seipel, J.~Baumeister, and M.~Hopfner. \newblock Declaratively Querying and Visualizing Knowledge Bases in {XML}. \newblock In {\em Applications of Declarative Programming and Knowledge Management (INAP/WLP 2004)}, pp. 16--31. Springer LNCS 3392, 2005. \bibitem{WallaceRunciman99} M.~Wallace and C.~Runciman. \newblock Haskell and {XML}: Generic Combinators or Type-Based Translation? \newblock In {\em Proc. of the ACM SIGPLAN International Conference on Functional Programming (ICFP'99)}, pp. 148--159. ACM Press, 1999. \end{thebibliography} \newpage \appendix \section{Further Abstractions} This appendix contains some further abstractions that are not relevant for this paper but useful for XML processing. The operation \code{deepXml} defined in Section~\ref{sec:deepxml} can be used to match XML structures without attributes at an arbitrary position. In order to match structures with a possibly non-empty list of attributes, we provide (analogously to the definition of \code{xml'} in Section~\ref{sec:xmlprime}) the following operation: \begin{lcurry} > deepXml' :: String -> [XmlExp] -> XmlExp > deepXml' tag elems = xml' tag elems > deepXml' tag elems = xml' unknown (unknown ++ [deepXml' tag elems] ++ unknown) \end{lcurry} % If we are also interested to match the attributes of a deep XML structure, we can use the following operation: \begin{lcurry} > deepXElem :: String -> [(String,String)] -> [XmlExp] > -> XmlExp > deepXElem tag attrs elems = XElem tag attrs elems > deepXElem tag attrs elems = xml' unknown (unknown ++ [deepXElem tag attrs elems] ++ unknown) \end{lcurry} For instance, we can use this abstraction to provide a simpler and more general definition of the operation \code{getMaleFirstNames} shown in Section~\ref{ex:getMaleFirstNames}: \begin{curry} getMaleFirstNames (deepXElem "first" (with [("sex","male")]) [xtxt f]) = f \end{curry} % When dealing with semistructured data, it could be the case that one wants to use a default value if some element is not present. For this purpose, we define an operation \code{optXml} such that \ccode{optXml $t$ $xs$ $ys$} evaluates to \ccode{xml $t$ $xs$} if there is no element with tag $t$ in $ys$, otherwise the first element of $ys$ with tag $t$ is returned: \begin{lcurry} > optXml :: String -> [XmlExp] -> [XmlExp] -> XmlExp > optXml tag elems [] = xml tag elems > optXml tag elems (x:xs) = > if tag == tagOf x then x else optXml tag elems xs \end{lcurry} % One can apply this operation in combination with the matching operator \code{withOthers} to check optional occurrences in the remaining elements. As an example, we transform the entries of Figure~\ref{fig:xml-contacts} into \code{nickphone} structures consisting of a nickname and a phone number. The definition is similar to \code{transPhone} (see Section~\ref{ex:transphone}) with the difference that the nickname is assumed to be optional: if it is not present in the given \code{entry} structure, it is generated by concatenating the given names: \begin{curry} transNickPhone (deepXml "entry" (withOthers [xml "name" [xtxt n], xml "first" [xtxt f], xml "phone" phone] others)) = xml "nickphone" [optXml "nickname" [xtxt (f++n)] others, xml "phone" phone] \end{curry} Thus, if $c$ denotes the XML document of Figure~\ref{fig:xml-contacts}, the evaluation of \begin{curry} xml "table" (sortValues (transNickPhone$\funset$ $c$)) \end{curry} yields the representation of the XML document \begin{xmldoc} Bill +1-987-742-9388 MichaelHanus +49-431-8807271
\end{xmldoc} \end{document} % LocalWords: Curry evaluable XML HTML Xcerpt XPath %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% curry-tools-v3.3.0/cpm/vendor/xml/src/XML.curry000066400000000000000000000373231377556325500214300ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for processing XML data. --- --- Warning: the structure of this library is not stable and --- might be changed in the future! --- --- @author Michael Hanus --- @version June 2018 ------------------------------------------------------------------------------ module XML(XmlExp(..),Encoding(..),XmlDocParams(..), tagOf,elemsOf,textOf,textOfXml,xtxt,xml, showXmlDoc,showXmlDocWithParams, writeXmlFile,writeXmlFileWithParams,parseXmlString,readXmlFile, readUnsafeXmlFile,readFileWithXmlDocs,updateXmlFile) where import Data.Char import Data.List (intersperse) import Numeric ------------------------------------------------------------------------------ --- The data type for representing XML expressions. --- @cons XText - a text string (PCDATA) --- @cons XElem - an XML element with tag field, attributes, and a list --- of XML elements as contents data XmlExp = XText String -- text string (PCDATA) | XElem String [(String,String)] [XmlExp] -- (tag attrs contents) deriving (Eq,Ord,Show) ------------------------------------------------------------------------------ --- The data type for encodings used in the XML document. data Encoding = StandardEnc | Iso88591Enc -- Transform an encoding into its XML-attribute form encoding2Attribute :: Encoding -> String encoding2Attribute StandardEnc = "" encoding2Attribute Iso88591Enc = "encoding=\"iso-8859-1\" " -- Transform an encoding into its encoding-function encoding2EncFunc :: Encoding -> String -> String encoding2EncFunc StandardEnc = standardEncoding encoding2EncFunc Iso88591Enc = iso88591Encoding ------------------------------------------------------------------------------ -- List of encoding maps ------------------------------------------------------------------------------ -- standard encoding map standardEncoding :: String -> String standardEncoding [] = [] standardEncoding (c:cs) | c=='<' = "<" ++ standardEncoding cs | c=='>' = ">" ++ standardEncoding cs | c=='&' = "&" ++ standardEncoding cs | c=='"' = """ ++ standardEncoding cs | c=='\'' = "'" ++ standardEncoding cs | ord c < 32 = "&#" ++ show (ord c) ++ ";" ++ standardEncoding cs | ord c > 127 = "&#" ++ show (ord c) ++ ";" ++ standardEncoding cs | otherwise = c : standardEncoding cs -- iso-8859-1 iso88591Encoding :: String -> String iso88591Encoding [] = [] iso88591Encoding (c:cs) = if ord c `elem` iso88591list then c : iso88591Encoding cs else standardEncoding [c] ++ iso88591Encoding cs -- iso-8859-1-list -- not yet completed... iso88591list :: [Int] iso88591list = [192,193,194,195,196,197,198,199,200,201,202,203,204,205,207, 208,209,210,211,212,214,216,217,218,219,220,221,224,225,228, 229,226,227,230,231,233,232,235,234,236,237,239,240,241,248, 246,242,243,244,245,250,249,252,251,253,255] ------------------------------------------------------------------------------ --- The data type for XML document parameters. --- @cons Enc - the encoding for a document --- @cons DtdUrl - the url of the DTD for a document data XmlDocParams = Enc Encoding | DtdUrl String -- get the right encoding (i.e., first or standard encoding if not present) -- from a list of XmlDocParams lookupEncoding :: [XmlDocParams] -> Encoding lookupEncoding (Enc f:_) = f lookupEncoding (DtdUrl _:l) = lookupEncoding l lookupEncoding [] = StandardEnc -- get the first DtdUrl from a list of XmlDocParams lookupDtdUrl :: [XmlDocParams] -> String lookupDtdUrl [] = "" lookupDtdUrl (Enc _ : l) = lookupDtdUrl l lookupDtdUrl (DtdUrl url : _) = url -- does a XmlDocParam include a DtdUrl? hasDtdUrl :: [XmlDocParams] -> Bool hasDtdUrl [] = False hasDtdUrl (DtdUrl _:_) = True hasDtdUrl (Enc _:l) = hasDtdUrl l ------------------------------------------------------------------------------ -- useful selectors: --- Returns the tag of an XML element (or empty for a textual element). tagOf :: XmlExp -> String tagOf (XElem tag _ _) = tag tagOf (XText _) = "" --- Returns the child elements an XML element. elemsOf :: XmlExp -> [XmlExp] elemsOf (XElem _ _ xexps) = xexps elemsOf (XText _) = [] --- Extracts the textual contents of a list of XML expressions. --- Useful auxiliary function when transforming XML expressions into --- other data structures. --- --- For instance, --- textOf [XText "xy", XElem "a" [] [], XText "bc"] == "xy bc" textOf :: [XmlExp] -> String textOf = unwords . filter (not . null) . map textOfXmlExp where textOfXmlExp (XText s) = s textOfXmlExp (XElem _ _ xs) = textOf xs --- Included for backward compatibility, better use textOf! textOfXml :: [XmlExp] -> String textOfXml = textOf ------------------------------------------------------------------------------ -- some useful abbreviations: --- Basic text (maybe containing special XML chars). xtxt :: String -> XmlExp xtxt s = XText s --- XML element without attributes. xml :: String -> [XmlExp] -> XmlExp xml t c = XElem t [] c ------------------------------------------------------------------------------ -- Pretty printer for XML documents ------------------------------------------------------------------------------ --- Writes a file with a given XML document. writeXmlFile :: String -> XmlExp -> IO () writeXmlFile file xexp = writeXmlFileWithParams file [Enc StandardEnc] xexp --- Writes a file with a given XML document and XML parameters. writeXmlFileWithParams :: String -> [XmlDocParams] -> XmlExp -> IO () writeXmlFileWithParams file ps xexp = writeFile file (showXmlDocWithParams ps xexp) ------------------------------------------------------------------------------ --- Show an XML document in indented format as a string. ------------------------------------------------------------------------------ showXmlDoc :: XmlExp -> String showXmlDoc xexp = showXmlDocWithParams [] xexp showXmlDocWithParams :: [XmlDocParams] -> XmlExp -> String showXmlDocWithParams ps (XElem root attrL xmlEL) = "\n\n" ++ (if hasDtdUrl ps then "\n\n" else "") ++ showXmlExp 0 (encoding2EncFunc (lookupEncoding ps)) (XElem root attrL xmlEL) showXmlDocWithParams _ (XText _) = error "XML.showXmlDocWithParams: document without tags" showXmlExp :: Int -> (String -> String) -> XmlExp -> String showXmlExp i encFun (XText s) = xtab i ++ (encFun s) ++ "\n" showXmlExp i encFun (XElem tag attrs xexps) = xtab i ++ showXmlOpenTag tag attrs encFun ++ if null xexps then " />\n" else if length xexps == 1 && isXText (head xexps) then let [XText s] = xexps in ">" ++ (encFun s) ++ "\n" else ">\n" ++ showXmlExps (i+2) xexps encFun ++ xtab i ++ "\n" xtab :: Int -> String xtab n = take n (repeat ' ') showXmlOpenTag :: String -> [(String, a)] -> (a -> String) -> String showXmlOpenTag tag attrs encFun = "<" ++ tag ++ concat (map ((" "++) . attr2string) attrs) where attr2string (attr,value) = attr ++ "=\"" ++ (encFun value) ++ "\"" showXmlExps :: Int -> [XmlExp] -> (String -> String) -> String showXmlExps encFun xexps i = concatMap (showXmlExp encFun i) xexps isXText :: XmlExp -> Bool isXText (XText _) = True isXText (XElem _ _ _) = False -- unquote special characters (<,>,&,',") in an XML string: xmlUnquoteSpecials :: String -> String xmlUnquoteSpecials [] = [] xmlUnquoteSpecials (c:cs) | c=='&' = let (special,rest) = splitAtChar ';' cs in xmlUnquoteSpecial special rest | otherwise = c : xmlUnquoteSpecials cs xmlUnquoteSpecial :: String -> String -> String xmlUnquoteSpecial special cs | special=="lt" = '<' : xmlUnquoteSpecials cs | special=="gt" = '>' : xmlUnquoteSpecials cs | special=="amp" = '&' : xmlUnquoteSpecials cs | special=="quot" = '"' : xmlUnquoteSpecials cs | special=="apos" = '\'' : xmlUnquoteSpecials cs | special=="auml" = '\228' : xmlUnquoteSpecials cs | special=="ouml" = '\246' : xmlUnquoteSpecials cs | special=="uuml" = '\252' : xmlUnquoteSpecials cs | special=="Auml" = '\196' : xmlUnquoteSpecials cs | special=="Ouml" = '\214' : xmlUnquoteSpecials cs | special=="Uuml" = '\220' : xmlUnquoteSpecials cs | special=="szlig"= '\223' : xmlUnquoteSpecials cs | otherwise = unquoteUnicode special ++ xmlUnquoteSpecials cs unquoteUnicode :: String -> String unquoteUnicode [] = [] unquoteUnicode (c:cs) | c=='#' = case cs of 'x':cs' -> [chr (extr (readHex cs'))] cs' -> [chr (extr (readInt cs'))] | otherwise = '&':(c:cs) ++ ";" where extr [(a,"")] = a ------------------------------------------------------------------------------ -- Parser for XML documents ------------------------------------------------------------------------------ --- Reads a file with an XML document and returns --- the corresponding XML expression. readXmlFile :: String -> IO XmlExp readXmlFile file = do xmlstring <- readFile file let xexps = parseXmlString xmlstring if null xexps then error ("File "++file++" contains no XML document!") else if null (tail xexps) then return (head xexps) else error ("File "++file++" contains more than one XML document!") --- Tries to read a file with an XML document and returns --- the corresponding XML expression, if possible. --- If file or parse errors occur, Nothing is returned. readUnsafeXmlFile :: String -> IO (Maybe XmlExp) readUnsafeXmlFile file = catch (readXmlFile file >>= return . Just) (\_ -> return Nothing) --- Pretty prints the contents of an XML file. showXmlFile :: String -> IO () showXmlFile file = readXmlFile file >>= putStr . showXmlDoc --- Reads a file with an arbitrary sequence of XML documents and --- returns the list of corresponding XML expressions. readFileWithXmlDocs :: String -> IO [XmlExp] readFileWithXmlDocs file = readFile file >>= return . parseXmlString ------------------------------------------------------------------------------ --- Transforms an XML string into a list of XML expressions. --- If the XML string is a well structured document, the list --- of XML expressions should contain exactly one element. parseXmlString :: String -> [XmlExp] parseXmlString s = fst (parseXmlTokens (scanXmlString s) Nothing) -- parse a list of XML tokens into list of XML expressions: -- parseXmlTokens tokens stoptoken = (xml_expressions, remaining_tokens) parseXmlTokens :: [XmlExp] -> Maybe String -> ([XmlExp],[XmlExp]) parseXmlTokens [] Nothing = ([],[]) parseXmlTokens [] (Just _) = error "XML.parseXmlTokens: incomplete parse" parseXmlTokens (XText s : xtokens) stop = let (xexps, rem_xtokens) = parseXmlTokens xtokens stop in (XText (xmlUnquoteSpecials s) : xexps, rem_xtokens) parseXmlTokens (XElem (t:ts) args cont : xtokens) stop | t == '<' && head ts /= '/' = let (xexps1, xtokens1) = parseXmlTokens xtokens (Just ts) (xexps, rem_xtokens) = parseXmlTokens xtokens1 stop in (XElem ts args xexps1 : xexps, rem_xtokens) | t == '<' && head ts == '/' = if maybe False (==(tail ts)) stop then ([], xtokens) -- stop this parser if appropriate stop token reached else let (xexps, rem_xtokens) = parseXmlTokens xtokens stop in (XElem ts args cont : xexps, rem_xtokens) | otherwise = let (xexps, rem_xtokens) = parseXmlTokens xtokens stop in (XElem (t:ts) args cont : xexps, rem_xtokens) parseXmlTokens (XElem [] _ _ : _) _ = error "XML.parseXmlTokens: incomplete parse" -- scan an XML string into list of XML tokens: -- here we reuse XML expressions for representing XML tokens: -- single open or closing tags are returned by the scanner -- as an XElem with no contents and first character '<' added to the tag field scanXmlString :: String -> [XmlExp] scanXmlString s = scanXml (dropBlanks s) where scanXml [] = [] scanXml (c:cs) = if c=='<' then scanXmlElem cs else let (initxt,remtag) = scanXmlText (c:cs) in XText initxt : scanXml remtag -- scan an XML text until next tag and remove superflous blanks: scanXmlText :: String -> (String,String) --original definition: --scanXmlText s = let (s1,s2) = break (=='<') s -- in (concat (intersperse " " (words s1)), s2) --this implementation is more efficient: scanXmlText [] = ([],[]) scanXmlText (c:cs) | c=='<' = ([],c:cs) | isSpace c = let (txt,rem) = scanXmlText (dropBlanks cs) in (if null txt then txt else ' ':txt, rem) | otherwise = let (txt,rem) = scanXmlText cs in (c:txt,rem) -- scan an XML element: scanXmlElem :: String -> [XmlExp] scanXmlElem [] = [] scanXmlElem (c:cs) | c=='!' = if take 2 cs == "--" then scanXmlComment (drop 2 cs) else scanXmlCData cs | c=='?' = scanXmlProcInstr cs | otherwise = scanXmlElemName [c] cs scanXmlElemName :: String -> String -> [XmlExp] scanXmlElemName ct [] = [XElem ('<':ct) [] []] scanXmlElemName ct (c:cs) | c=='>' = XElem ('<':ct) [] [] : scanXmlString cs | isSpace c = let (attrs,rest) = parseAttrs (dropBlanks cs) in if (head rest)=='/' then XElem ct attrs [] : scanXmlString (drop 2 rest) else XElem ('<':ct) attrs [] : scanXmlString (tail rest) | c=='/' && head cs == '>' = XElem ct [] [] : scanXmlString (tail cs) | otherwise = scanXmlElemName (ct++[c]) cs -- scan (and drop) an XML comment: scanXmlComment :: String -> [XmlExp] scanXmlComment [] = [] scanXmlComment (c:cs) = if c=='-' && take 2 cs == "->" then scanXmlString (drop 2 cs) else scanXmlComment cs -- scan (and drop) an XML CDATA element (simplified version): scanXmlCData :: String -> [XmlExp] scanXmlCData cs = let rest = dropCData cs in if head rest == '>' then scanXmlString (tail rest) else scanXmlCData rest dropCData :: String -> String dropCData [] = [] dropCData (c:cs) | c=='[' = tail (dropWhile (/=']') cs) -- must be improved | c=='>' = c:cs | otherwise = dropCData cs -- scan (and drop) an XML processing instructions: scanXmlProcInstr :: String -> [XmlExp] scanXmlProcInstr [] = [] scanXmlProcInstr (c:cs) = if c=='?' && head cs == '>' then scanXmlString (tail cs) else scanXmlProcInstr cs -- parse a string as an attribute list: parseAttrs :: String -> ([(String,String)],String) parseAttrs [] = ([],[]) parseAttrs (c:cs) | isAlpha c = let (name,rest1) = splitAtChar '=' (c:cs) (value,rest2) = splitAtChar '"' (tail rest1) (rem_attrs,rem_inp) = parseAttrs (dropBlanks rest2) in ((name,xmlUnquoteSpecials value):rem_attrs, rem_inp) | otherwise = ([],c:cs) -- drop blanks in input string: dropBlanks :: String -> String dropBlanks = dropWhile isSpace -- split string at particular character, if possible: splitAtChar :: Char -> String -> (String, String) splitAtChar _ [] = ([],[]) splitAtChar char (c:cs) = if c==char then ([],cs) else let (first,rest) = splitAtChar char cs in (c:first,rest) ------------------------------------------------------------------------------ --- An action that updates the contents of an XML file by some transformation --- on the XML document. --- @param f - the function to transform the XML document in the file --- @param file - the name of the XML file updateXmlFile :: (XmlExp -> XmlExp) -> String -> IO () updateXmlFile xmltrans filename = do xdoc <- readXmlFile filename writeXmlFile filename $!! (xmltrans xdoc) -- end of XML library curry-tools-v3.3.0/cpm/vendor/xml/src/XmlConv.curry000066400000000000000000000756121377556325500223610ustar00rootroot00000000000000--- Provides type-based combinators to construct XML converters. --- Arbitrary XML data can be represented as algebraic datatypes and vice versa. --- See --- here for a description of this library. --- --- @author Sebastian Fischer (with changes by Michael Hanus) --- @version February 2015 {-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-overlapping #-} module XmlConv ( -- converter types XElemConv, XAttrConv, XPrimConv, XOptConv, XRepConv, -- Reads and Shows types for XML trees XmlReads, XmlShows, -- read and show functions xmlRead, xmlShow, xmlReads, xmlShows, -- converter for primitive values int, float, char, string, -- combinators for complex XML data (!), element, empty, attr, adapt, opt, rep, -- attribute converter for primitive values and booleans aInt, aFloat, aChar, aString, aBool, -- element converter eInt, eFloat, eChar, eString, eBool, eEmpty, eOpt, eRep, -- converter for sequences seq1, seq2, seq3, seq4, seq5, seq6, -- converter for repeated sequences repSeq1, repSeq2, repSeq3, repSeq4, repSeq5, repSeq6, -- element converter for sequences eSeq1, eSeq2, eSeq3, eSeq4, eSeq5, eSeq6, -- element converter for repeated sequences eRepSeq1, eRepSeq2, eRepSeq3, eRepSeq4, eRepSeq5, eRepSeq6 ) where import XML import ReadShowTerm ( readQTerm ) infixr 0 ! infixl 1 />= --- Phantom type for XML data that may be part of a repetition data Repeatable = Repeatable --- Phantom type for XML data that must not be part of a repetition data NotRepeatable = NotRepeatable --- Phantom type for single elements data Elem = Elem --- Phantom type for primitive values, multiple elements and/or attributes data NoElem = NoElem type Attrs = [(String,String)] type Childs = (Attrs,[XmlExp]) --- Type of functions that consume some XML data to compute a result type XmlReads a = Childs -> (a,Childs) --- Type of functions that extend XML data corresponding to a given value type XmlShows a = a -> Childs -> Childs data XmlConv _ _ a = Conv (XmlReads a) (XmlShows a) type ValConv a = (String -> a,a -> String) --- Type of converters for XML elements type XElemConv a = XmlConv Repeatable Elem a --- Type of converters for attributes type XAttrConv a = XmlConv NotRepeatable NoElem a --- Type of converters for primitive values type XPrimConv a = XmlConv NotRepeatable NoElem a --- Type of converters for optional values type XOptConv a = XmlConv NotRepeatable NoElem a --- Type of converters for repetitions type XRepConv a = XmlConv NotRepeatable NoElem a --- Type of converters for sequences type XSeqConv a = XmlConv NotRepeatable NoElem a -- Monadic bind for XML parser (/>=) :: XmlReads a -> (a -> XmlReads b) -> XmlReads b rd />= f = \childs -> case rd childs of (a,childs') -> f a childs' -- Monadic return for XML parser ret :: a -> XmlReads a ret x y = (x,y) --- Takes an XML converter and returns a function that consumes XML data --- and returns the remaining data along with the result. --- --- @param conv XML converter --- @return XmlReads function xmlReads :: XmlConv _ _ a -> XmlReads a xmlReads (Conv rd _) = rd --- Takes an XML converter and returns a function that extends XML data --- with the representation of a given value. --- --- @param conv XML converter --- @return XmlShows function xmlShows :: XmlConv _ _ a -> XmlShows a xmlShows (Conv _ sh) = sh --- Takes an XML converter and an XML expression and returns a --- corresponding Curry value. --- --- @param conv XML converter --- @return XML read function xmlRead :: XmlConv _ Elem a -> XmlExp -> a xmlRead xa x = a where (a,([],[])) = xmlReads xa ([],[x]) --- Takes an XML converter and a value and returns a corresponding --- XML expression. --- --- @param conv XML converter --- @return XML show function xmlShow :: XmlConv _ Elem a -> a -> XmlExp xmlShow xa a = x where ([],[x]) = xmlShows xa a ([],[]) int_ :: ValConv Int int_ = (read,show) float_ :: ValConv Float float_ = (readQTerm,show) char_ :: ValConv Char char_ = (head,(:[])) string_ :: ValConv String string_ = (id,id) bool_ :: String -> String -> ValConv Bool bool_ true false = (readBool,showBool) where fromJust (Just x) = x readBool s = fromJust (lookup s [(true,True),(false,False)]) showBool b = if b then true else false val_ :: ValConv a -> XPrimConv a val_ (rda,sha) = Conv rd sh where rd childs = (rda a,(attrs,elems)) where (attrs,XText a : elems) = childs sh a childs = (attrs,XText (sha a) : elems) where (attrs,elems) = childs --- Creates an XML converter for integer values. Integer values must not be --- used in repetitions and do not represent XML elements. --- --- @return Int converter int :: XPrimConv Int int = val_ int_ --- Creates an XML converter for float values. Float values must not be --- used in repetitions and do not represent XML elements. --- --- @return Float converter float :: XPrimConv Float float = val_ float_ --- Creates an XML converter for character values. Character values must not be --- used in repetitions and do not represent XML elements. --- --- @return Char converter char :: XPrimConv Char char = val_ char_ --- Creates an XML converter for string values. String values must not be --- used in repetitions and do not represent XML elements. --- --- @return String converter string :: XPrimConv String string = Conv rd sh where rd childs = ("",childs) ? case elems of XText s : elems' -> (s,(attrs,elems')) where (attrs,elems) = childs sh "" childs = childs sh s@(_:_) childs = (attrs,XText s : elems) where (attrs,elems) = childs --- Parallel composition of XML converters. --- --- @return Nondeterministic choice of XML converters (!) :: XmlConv rep elem a -> XmlConv rep elem a -> XmlConv rep elem a (Conv rd1 sh1) ! (Conv rd2 sh2) = Conv rd sh where rd childs = rd1 childs ? rd2 childs sh x = sh1 x ? sh2 x --- Takes an arbitrary XML converter and returns a converter representing --- an XML element that contains the corresponding data. XML elements may be --- used in repetitions. --- --- @param name Tag name of the XML element --- @param conv XML converter for the childs of the XML element --- @return XML converter representing an XML element element :: String -> XmlConv _ _ a -> XElemConv a element name xa = Conv rd sh where rd childs | myName==name = case xmlReads xa (myAttrs,myElems) of (a,([],[])) -> (a,(attrs,elems)) where (attrs,XElem myName myAttrs myElems : elems) = childs sh a childs = case xmlShows xa a ([],[]) of (myAttrs,myElems) -> (attrs,XElem name myAttrs myElems : elems) where (attrs,elems) = childs --- Takes a value and returns an XML converter for this value which is not --- represented as XML data. Empty XML data must not be used in repetitions --- and does not represent an XML element. --- --- @param val Value without an XML representation --- @return Empty XML converter empty :: Data a => a -> XPrimConv a empty val = Conv rd sh where rd = ret val sh v childs | v=:=val = childs --- Takes a name and string conversion functions and returns an XML converter --- that represents an attribute. Attributes must not be used in repetitions --- and do not represent an XML element. --- --- @param name Attribute name --- @param readShow functions that convert between values and strings --- @return Attribute converter attr :: String -> ValConv a -> XAttrConv a attr name (rda,sha) = Conv rd sh where rd childs = (rda value,(attrs',elems)) where (attrs,elems) = childs ((_,value),attrs') = exposeBy ((name==) . fst) attrs sh a childs = ((name,sha a) : attrs,elems) where (attrs,elems) = childs -- Fetch a list element that satisfies a given predicate. exposeBy :: (a -> Bool) -> [a] -> (a,[a]) exposeBy p (x:xs) = if p x then (x,xs) else (y,x:ys) where (y,ys) = exposeBy p xs --- Converts between arbitrary XML converters for different types. --- --- @param a2b_b2a functions that convert between values of types a and b --- @param conv XML converter for type a --- @return XML converter for type b adapt :: (a -> b,b -> a) -> XmlConv rep e a -> XmlConv rep e b adapt (a2b,b2a) (Conv rda sha) = Conv rd sh where rd = rda />= ret . a2b sh = sha . b2a --- Creates a converter for arbitrary optional XML data. Optional XML data --- must not be used in repetitions and does not represent an XML element. --- --- @param conv XML converter --- @return XML converter for optional data represented by the given converter opt :: XmlConv _ _ a -> XOptConv (Maybe a) opt xa = Conv rd sh where rd childs = ret Nothing childs ? (xmlReads xa />= ret . Just) childs sh Nothing = id sh (Just a) = xmlShows xa a --- Takes an XML converter representing repeatable data and returns an --- XML converter that represents repetitions of this data. Repetitions --- must not be used in other repetitions and do not represent XML elements. --- --- @param conv XML converter representing repeatable data --- @return XML converter representing repetitions rep :: XmlConv Repeatable _ a -> XRepConv [a] rep xa = Conv rd sh where rd childs = ret [] childs ? ( xmlReads xa />= \x -> rd />= \xs -> ret (x:xs)) childs sh = foldr (.) id . map (xmlShows xa) --- Creates an XML converter for integer attributes. Integer attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @return Int attribute converter aInt :: String -> XAttrConv Int aInt name = attr name int_ --- Creates an XML converter for float attributes. Float attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @return Float attribute converter aFloat :: String -> XAttrConv Float aFloat name = attr name float_ --- Creates an XML converter for character attributes. Character attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @return Char attribute converter aChar :: String -> XAttrConv Char aChar name = attr name char_ --- Creates an XML converter for string attributes. String attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @return String attribute converter aString :: String -> XAttrConv String aString name = attr name string_ --- Creates an XML converter for boolean attributes. Boolean attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @param true String representing True --- @param false String representing False --- @return Bool attribute converter aBool :: String -> String -> String -> XAttrConv Bool aBool name true false = attr name (bool_ true false) --- Creates an XML converter for integer elements. Integer elements may be --- used in repetitions. --- --- @param name Tag name of the XML element containing the integer value --- @return Int element converter eInt :: String -> XElemConv Int eInt name = element name int --- Creates an XML converter for float elements. Float elements may be --- used in repetitions. --- --- @param name Tag name of the XML element containing the float value --- @return Float element converter eFloat :: String -> XElemConv Float eFloat name = element name float --- Creates an XML converter for character elements. Character elements may be --- used in repetitions. --- --- @param name Tag name of the XML element containing the character value --- @return Char element converter eChar :: String -> XElemConv Char eChar name = element name char --- Creates an XML converter for string elements. String elements may be --- used in repetitions. --- --- @param name Tag name of the XML element containing the string value --- @return String element converter eString :: String -> XElemConv String eString name = element name string --- Creates an XML converter for boolean elements. Boolean elements may be --- used in repetitions. --- --- @param true Tag name of the XML element representing True --- @param false Tag name of the XML element representing False --- @return Bool element converter eBool :: String -> String -> XElemConv Bool eBool true false = eEmpty true True ! eEmpty false False --- Takes a name and a value and creates an empty XML element that represents --- the given value. The created element may be used in repetitions. --- --- @param name Tag name of the empty element --- @param val Value represented by the empty element --- @return XML converter representing an empty XML element eEmpty :: Data a => String -> a -> XElemConv a eEmpty name a = element name (empty a) --- Creates an XML converter that represents an element containing --- optional XML data. The created element may be used in repetitions. --- --- @param name Tag name of the element containing optional XML data --- @return XML converter for an element enclosing optional XML data eOpt :: String -> XmlConv _ _ a -> XElemConv (Maybe a) eOpt name xa = element name (opt xa) --- Creates an XML converter that represents an element containing --- repeated XML data. The created element may be used in repetitions. --- --- @param name Tag name of the element containing repeated XML data --- @return XML converter for an element enclosing repeated XML data eRep :: String -> XmlConv Repeatable _ a -> XElemConv [a] eRep name xa = element name (rep xa) --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq1 :: (Data a, Data b) => (a -> b) -> XmlConv rep _ a -> XmlConv rep NoElem b seq1 cons xa = Conv rd sh where rd = xmlReads xa />= ret . cons sh arg | cons a =:<= arg = xmlShows xa a where a free --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions but does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq1 :: (Data a, Data b) => (a -> b) -> XmlConv Repeatable _ a -> XRepConv [b] repSeq1 cons xa = rep (seq1 cons xa) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq1 :: (Data a, Data b) => String -> (a -> b) -> XmlConv _ _ a -> XElemConv b eSeq1 name cons xa = element name (seq1 cons xa) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq1 :: (Data a, Data b) => String -> (a -> b) -> XmlConv Repeatable _ a -> XElemConv [b] eRepSeq1 name cons xa = element name (repSeq1 cons xa) seq2_ :: (Data a, Data b, Data c) => (a -> b -> c) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ NoElem c seq2_ cons xa xb = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> ret (cons a b) sh arg | cons a b =:<= arg = xmlShows xa a . xmlShows xb b where a,b free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq2 :: (Data a, Data b, Data c) => (a -> b -> c) -> XmlConv _ _ a -> XmlConv _ _ b -> XSeqConv c seq2 = seq2_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq2 :: (Data a, Data b, Data c) => (a -> b -> c) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XRepConv [c] repSeq2 cons xa xb = rep (seq2_ cons xa xb) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq2 :: (Data a, Data b, Data c) => String -> (a -> b -> c) -> XmlConv _ _ a -> XmlConv _ _ b -> XElemConv c eSeq2 name cons xa xb = element name (seq2 cons xa xb) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq2 :: (Data a, Data b, Data c) => String -> (a -> b -> c) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XElemConv [c] eRepSeq2 name cons xa xb = element name (repSeq2 cons xa xb) seq3_ :: (Data a, Data b, Data c, Data d) => (a -> b -> c -> d) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ NoElem d seq3_ cons xa xb xc = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> xmlReads xc />= \c -> ret (cons a b c) sh arg | (cons a b c) =:<= arg = xmlShows xa a . xmlShows xb b . xmlShows xc c where a,b,c free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq3 :: (Data a, Data b, Data c, Data d) => (a -> b -> c -> d) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XSeqConv d seq3 = seq3_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq3 :: (Data a, Data b, Data c, Data d) => (a -> b -> c -> d) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XRepConv [d] repSeq3 cons xa xb xc = rep (seq3_ cons xa xb xc) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq3 :: (Data a, Data b, Data c, Data d) => String -> (a -> b -> c -> d) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XElemConv d eSeq3 name cons xa xb xc = element name (seq3 cons xa xb xc) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq3 :: (Data a, Data b, Data c, Data d) => String -> (a -> b -> c -> d) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XElemConv [d] eRepSeq3 name cons xa xb xc = element name (repSeq3 cons xa xb xc) seq4_ :: (Data a, Data b, Data c, Data d, Data e) => (a -> b -> c -> d -> e) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ NoElem e seq4_ cons xa xb xc xd = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> xmlReads xc />= \c -> xmlReads xd />= \d -> ret (cons a b c d) sh arg | (cons a b c d) =:<= arg = xmlShows xa a . xmlShows xb b . xmlShows xc c . xmlShows xd d where a,b,c,d free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq4 :: (Data a, Data b, Data c, Data d, Data e) => (a -> b -> c -> d -> e) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XSeqConv e seq4 = seq4_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq4 :: (Data a, Data b, Data c, Data d, Data e) => (a -> b -> c -> d -> e) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XRepConv [e] repSeq4 cons xa xb xc xd = rep (seq4_ cons xa xb xc xd) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq4 :: (Data a, Data b, Data c, Data d, Data e) => String -> (a -> b -> c -> d -> e) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XElemConv e eSeq4 name cons xa xb xc xd = element name (seq4 cons xa xb xc xd) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq4 :: (Data a, Data b, Data c, Data d, Data e) => String -> (a -> b -> c -> d -> e) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XElemConv [e] eRepSeq4 name cons xa xb xc xd = element name (repSeq4 cons xa xb xc xd) seq5_ :: (Data a, Data b, Data c, Data d, Data e, Data f) => (a -> b -> c -> d -> e -> f) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XmlConv _ NoElem f seq5_ cons xa xb xc xd xe = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> xmlReads xc />= \c -> xmlReads xd />= \d -> xmlReads xe />= \e -> ret (cons a b c d e) sh arg | (cons a b c d e) =:<= arg = xmlShows xa a . xmlShows xb b . xmlShows xc c . xmlShows xd d . xmlShows xe e where a,b,c,d,e free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq5 :: (Data a, Data b, Data c, Data d, Data e, Data f) => (a -> b -> c -> d -> e -> f) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XSeqConv f seq5 = seq5_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq5 :: (Data a, Data b, Data c, Data d, Data e, Data f) => (a -> b -> c -> d -> e -> f) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XmlConv Repeatable _ e -> XRepConv [f] repSeq5 cons xa xb xc xd xe = rep (seq5_ cons xa xb xc xd xe) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq5 :: (Data a, Data b, Data c, Data d, Data e, Data f) => String -> (a -> b -> c -> d -> e -> f) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XElemConv f eSeq5 name cons xa xb xc xd xe = element name (seq5 cons xa xb xc xd xe) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq5 :: (Data a, Data b, Data c, Data d, Data e, Data f) => String -> (a -> b -> c -> d -> e -> f) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XmlConv Repeatable _ e -> XElemConv [f] eRepSeq5 name cons xa xb xc xd xe = element name (repSeq5 cons xa xb xc xd xe) seq6_ :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => (a -> b -> c -> d -> e -> f -> g) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XmlConv _ _ f -> XmlConv _ NoElem g seq6_ cons xa xb xc xd xe xf = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> xmlReads xc />= \c -> xmlReads xd />= \d -> xmlReads xe />= \e -> xmlReads xf />= \f -> ret (cons a b c d e f) sh arg | (cons a b c d e f) =:<= arg = xmlShows xa a . xmlShows xb b . xmlShows xc c . xmlShows xd d . xmlShows xe e . xmlShows xf f where a,b,c,d,e,f free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq6 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => (a -> b -> c -> d -> e -> f -> g) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XmlConv _ _ f -> XSeqConv g seq6 = seq6_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq6 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => (a -> b -> c -> d -> e -> f -> g) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XmlConv Repeatable _ e -> XmlConv Repeatable _ f -> XRepConv [g] repSeq6 cons xa xb xc xd xe xf = rep (seq6_ cons xa xb xc xd xe xf) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq6 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => String -> (a -> b -> c -> d -> e -> f -> g) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XmlConv _ _ f -> XElemConv g eSeq6 name cons xa xb xc xd xe xf = element name (seq6 cons xa xb xc xd xe xf) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq6 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => String -> (a -> b -> c -> d -> e -> f -> g) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XmlConv Repeatable _ e -> XmlConv Repeatable _ f -> XElemConv [g] eRepSeq6 name cons xa xb xc xd xe xf = element name (repSeq6 cons xa xb xc xd xe xf) curry-tools-v3.3.0/download_tools.sh000077500000000000000000000060521377556325500176200ustar00rootroot00000000000000#!/bin/sh # This shell script updates some tools by downloading the current version # from the Curry package repository. # # Note that the execution of this script requires an already installed 'cypm'! # use local Curry executable if it exists (e.g., we are inside the distro): CURRYBIN=`pwd`/../bin/curry if [ -x "$CURRYBIN" ] ; then CPMOPTS="-d curry_bin=$CURRYBIN" else CPMOPTS= fi CPM="cypm $CPMOPTS" ############################################################################## echo "Updating 'cpm'..." mv cpm/Makefile Makefile.cpm # keep old Makefile mv cpm/vendor/cass/src/CASS/PackageConfig.curry CASS_PackageConfig.curry rm -rf cpm $CPM checkout cpm cd cpm rm -rf .git* bin package.json make fetchdeps rm -rf vendor/*/.git* rm -rf dependencies.txt fetch-dependencies.sh Makefile cd .. mv Makefile.cpm cpm/Makefile mv CASS_PackageConfig.curry cpm/vendor/cass/src/CASS/PackageConfig.curry echo "'cpm' updated from package repository." ############################################################################## echo "Updating 'optimize'..." mv optimize/Makefile Makefile.optimize # keep old Makefile mv optimize/.cpm/packages/cass/src/CASS/PackageConfig.curry CASS_PackageConfig.curry mv optimize/package.json optimize_package.json rm -rf optimize $CPM checkout transbooleq mv transbooleq optimize cd optimize $CPM install --noexec rm -rf .git* rm -rf .cpm/*_cache rm -rf .cpm/packages/*/.git* cd .cpm/packages CANAV=`ls -d cass-analysis-*` mv $CANAV cass-analysis CASSV=`ls -d cass-*\.*\.*` mv $CASSV cass ln -s cass-analysis $CANAV ln -s cass $CASSV PKGV=`ls -d containers-*` mv $PKGV containers ln -s containers $PKGV PKGV=`ls -d csv-*` mv $PKGV csv ln -s csv $PKGV PKGV=`ls -d currypath-*` mv $PKGV currypath ln -s currypath $PKGV PKGV=`ls -d directory-*` mv $PKGV directory ln -s directory $PKGV PKGV=`ls -d filepath-*` mv $PKGV filepath ln -s filepath $PKGV PKGV=`ls -d flatcurry-*` mv $PKGV flatcurry ln -s flatcurry $PKGV PKGV=`ls -d frontend-exec-*` mv $PKGV frontend-exec ln -s frontend-exec $PKGV PKGV=`ls -d global-*` mv $PKGV global ln -s global $PKGV PKGV=`ls -d io-extra-*` mv $PKGV io-extra ln -s io-extra $PKGV PKGV=`ls -d process-*` mv $PKGV process ln -s process $PKGV PKGV=`ls -d propertyfile-*` mv $PKGV propertyfile ln -s propertyfile $PKGV PKGV=`ls -d queue-*` mv $PKGV queue ln -s queue $PKGV PKGV=`ls -d random-*` mv $PKGV random ln -s random $PKGV PKGV=`ls -d read-legacy-*` mv $PKGV read-legacy ln -s read-legacy $PKGV PKGV=`ls -d redblacktree-*` mv $PKGV redblacktree ln -s redblacktree $PKGV PKGV=`ls -d scc-*` mv $PKGV scc ln -s scc $PKGV PKGV=`ls -d socket-*` mv $PKGV socket ln -s socket $PKGV PKGV=`ls -d time-*` mv $PKGV time ln -s time $PKGV PKGV=`ls -d wl-pprint-*` mv $PKGV wl-pprint ln -s wl-pprint $PKGV PKGV=`ls -d xml-*` mv $PKGV xml ln -s xml $PKGV cd ../.. cd .. mv Makefile.optimize optimize/Makefile mv CASS_PackageConfig.curry optimize/.cpm/packages/cass/src/CASS/PackageConfig.curry mv optimize_package.json optimize/package.json echo "'optimize' updated from package repository." curry-tools-v3.3.0/optimize/000077500000000000000000000000001377556325500160675ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/000077500000000000000000000000001377556325500167245ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/000077500000000000000000000000001377556325500205025ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/000077500000000000000000000000001377556325500232545ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/LICENSE000066400000000000000000000027351377556325500242700ustar00rootroot00000000000000Copyright (c) 2017, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/README.md000066400000000000000000000003721377556325500245350ustar00rootroot00000000000000# cass-analysis - Base libraries and implementation of program analyses for CASS This directory contains the implementation of various program analyses which can be used with CASS (the Curry Analysis Server System), available in the package `cass`. curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/package.json000066400000000000000000000017511377556325500255460ustar00rootroot00000000000000{ "name": "cass-analysis", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Libraries with various compile-time analyses for Curry", "category": [ "Analysis" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "currypath" : ">= 3.0.0, < 4.0.0", "containers" : ">= 3.0.0, < 4.0.0", "directory" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0", "flatcurry" : ">= 3.0.0, < 4.0.0", "global" : ">= 3.0.0, < 4.0.0", "read-legacy": ">= 3.0.0, < 4.0.0", "scc" : ">= 3.0.0, < 4.0.0", "xml" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/cass-analysis.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/000077500000000000000000000000001377556325500240435ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/000077500000000000000000000000001377556325500256265ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/Demandedness.curry000066400000000000000000000076041377556325500313150ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Demandedness analysis: --- checks whether functions demands a particular argument, i.e., --- delivers only bottom if some argument is bottom. --- --- @author Michael Hanus --- @version May 2013 ------------------------------------------------------------------------------ module Analysis.Demandedness where import Analysis.Types import FlatCurry.Types import FlatCurry.Goodies import Data.List ( (\\), intercalate ) ------------------------------------------------------------------------------ --- Data type to represent information about demanded arguments. --- Demanded arguments are represented as a list of indices --- for the arguments, where arguments are numbered from 1. type DemandedArgs = [Int] -- Show determinism information as a string. showDemand :: AOutFormat -> DemandedArgs -> String showDemand AText [] = "no demanded arguments" showDemand ANote [] = "" showDemand fmt (x:xs) = (if fmt==AText then "demanded arguments: " else "") ++ intercalate "," (map show (x:xs)) -- Abstract demand domain. data DemandDomain = Bot | Top deriving Eq -- Least upper bound on abstract demand domain. lub :: DemandDomain -> DemandDomain -> DemandDomain lub Bot x = x lub Top _ = Top --- Demandedness analysis. demandAnalysis :: Analysis DemandedArgs demandAnalysis = dependencyFuncAnalysis "Demand" [1..] daFunc -- We define the demanded arguments of some primitive prelude operations. -- Otherwise, we analyse the right-hand sides of the rule. daFunc :: FuncDecl -> [(QName,DemandedArgs)] -> DemandedArgs daFunc (Func (m,f) _ _ _ rule) calledFuncs | f `elem` prelude2s && m==prelude = [1,2] | f `elem` prelude1s && m==prelude = [1] | otherwise = daFuncRule calledFuncs rule where prelude2s = ["==","=:=","compare","<=","$#","$##","$!","$!!", "+","-","*","div","mod","divMod","quot","rem","quotRem"] prelude1s = ["seq","ensureNotFree","apply","cond","=:<=","negateFloat"] -- TODO: >>= catch catchFail daFuncRule :: [(QName,DemandedArgs)] -> Rule -> DemandedArgs daFuncRule _ (External _) = [] -- nothing known about other externals daFuncRule calledFuncs (Rule args rhs) = map fst (filter ((==Bot) . snd) (map (\botarg -> (botarg, absEvalExpr rhs [botarg])) args)) where -- abstract evaluation of an expression w.r.t. variables assumed to be Bot absEvalExpr (Var i) bvs = if i `elem` bvs then Bot else Top absEvalExpr (Lit _) _ = Top absEvalExpr (Comb ct g es) bvs = if ct == FuncCall then if g == (prelude,"failed") then Bot -- Prelude.failed never returns a value else maybe (error $ "Abstract value of " ++ show g ++ " not found!") (\gdas -> let curargs = map (\ (i,e) -> (i,absEvalExpr e bvs)) (zip [1..] es) cdas = gdas \\ map fst (filter ((/=Bot) . snd) curargs) in if null cdas then Top else Bot) (lookup g calledFuncs) else Top absEvalExpr (Free _ e) bvs = absEvalExpr e bvs absEvalExpr (Let bs e) bvs = absEvalExpr e (absEvalBindings bs bvs) absEvalExpr (Or e1 e2) bvs = lub (absEvalExpr e1 bvs) (absEvalExpr e2 bvs) absEvalExpr (Case _ e bs) bvs = if absEvalExpr e bvs == Bot then Bot else foldr lub Bot (map absEvalBranch bs) where absEvalBranch (Branch _ be) = absEvalExpr be bvs absEvalExpr (Typed e _) bvs = absEvalExpr e bvs -- could be improved with local fixpoint computation absEvalBindings [] bvs = bvs absEvalBindings ((i,exp) : bs) bvs = let ival = absEvalExpr exp bvs in if ival==Bot then absEvalBindings bs (i:bvs) else absEvalBindings bs bvs prelude :: String prelude = "Prelude" ------------------------------------------------------------------------------ curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/Deterministic.curry000066400000000000000000000251401377556325500315210ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Determinism analysis: --- checks whether functions are deterministic or nondeterministic, i.e., --- whether its evaluation on ground argument terms might cause --- different computation paths. --- --- @author Michael Hanus --- @version August 2016 ------------------------------------------------------------------------------ module Analysis.Deterministic ( overlapAnalysis, showOverlap, showDet , functionalAnalysis, showFunctional , Deterministic(..),nondetAnalysis , showNonDetDeps, nondetDepAnalysis, nondetDepAllAnalysis ) where import Analysis.Types import FlatCurry.Types import FlatCurry.Goodies import Data.List import Data.Char (isDigit) ------------------------------------------------------------------------------ -- The overlapping analysis can be applied to individual functions. -- It assigns to a FlatCurry function definition a flag which is True -- if this function is defined with overlapping left-hand sides. overlapAnalysis :: Analysis Bool overlapAnalysis = simpleFuncAnalysis "Overlapping" isOverlappingFunction isOverlappingFunction :: FuncDecl -> Bool isOverlappingFunction (Func _ _ _ _ (Rule _ e)) = orInExpr e isOverlappingFunction (Func f _ _ _ (External _)) = f==("Prelude","?") -- Check an expression for occurrences of OR: orInExpr :: Expr -> Bool orInExpr (Var _) = False orInExpr (Lit _) = False orInExpr (Comb _ f es) = f==(pre "?") || any orInExpr es orInExpr (Free _ e) = orInExpr e orInExpr (Let bs e) = any orInExpr (map snd bs) || orInExpr e orInExpr (Or _ _) = True orInExpr (Case _ e bs) = orInExpr e || any orInBranch bs where orInBranch (Branch _ be) = orInExpr be orInExpr (Typed e _) = orInExpr e -- Show overlapping information as a string. showOverlap :: AOutFormat -> Bool -> String showOverlap _ True = "overlapping" showOverlap AText False = "non-overlapping" showOverlap ANote False = "" ------------------------------------------------------------------------------ -- The functional analysis is a global function dependency analysis. -- It assigns to a FlatCurry function definition a flag which is True -- if this function is purely functional defined, i.e., its definition -- does not depend on operation containing overlapping rules or free variables. functionalAnalysis :: Analysis Bool functionalAnalysis = dependencyFuncAnalysis "Functional" True isFuncDefined -- Show functionally defined information as a string. showFunctional :: AOutFormat -> Bool -> String showFunctional _ True = "functional" showFunctional AText False = "defined with logic features" showFunctional ANote False = "" -- An operation is functionally defined if its definition is not -- non-deterministic (no overlapping rules, no extra variables) and -- it depends only on functionally defined operations. isFuncDefined :: FuncDecl -> [(QName,Bool)] -> Bool isFuncDefined func calledFuncs = not (isNondetDefined func) && and (map snd calledFuncs) -- Is a function f defined to be potentially non-deterministic, i.e., -- is the rule non-deterministic or does it contain extra variables? isNondetDefined :: FuncDecl -> Bool isNondetDefined (Func f _ _ _ rule) = f `notElem` (map pre ["failed","$!!","$##","normalForm","groundNormalForm"]) -- these operations are internally defined in PAKCS with extra variables && isNondetRule rule where isNondetRule (Rule _ e) = orInExpr e || extraVarInExpr e isNondetRule (External _) = f==("Prelude","?") -- check an expression for occurrences of extra variables: extraVarInExpr :: Expr -> Bool extraVarInExpr (Var _) = False extraVarInExpr (Lit _) = False extraVarInExpr (Comb _ _ es) = or (map extraVarInExpr es) extraVarInExpr (Free vars e) = (not (null vars)) || extraVarInExpr e extraVarInExpr (Let bs e) = any extraVarInExpr (map snd bs) || extraVarInExpr e extraVarInExpr (Or e1 e2) = extraVarInExpr e1 || extraVarInExpr e2 extraVarInExpr (Case _ e bs) = extraVarInExpr e || any extraVarInBranch bs where extraVarInBranch (Branch _ be) = extraVarInExpr be extraVarInExpr (Typed e _) = extraVarInExpr e ------------------------------------------------------------------------------ -- The determinism analysis is a global function dependency analysis. -- It assigns to a function a flag which indicates whether is function -- might be non-deterministic, i.e., might reduce in different ways -- for given ground arguments. -- If the non-determinism is encapsulated (set functions, AllSolutions), -- it is classified as deterministic. --- Data type to represent determinism information. data Deterministic = NDet | Det deriving (Eq, Ord, Show, Read) -- Show determinism information as a string. showDet :: AOutFormat -> Deterministic -> String showDet _ NDet = "non-deterministic" showDet AText Det = "deterministic" showDet ANote Det = "" nondetAnalysis :: Analysis Deterministic nondetAnalysis = dependencyFuncAnalysis "Deterministic" Det nondetFunc -- An operation is non-deterministic if its definition is potentially -- non-deterministic or it calls a non-deterministic operation -- where the non-deterministic call is not encapsulated. nondetFunc :: FuncDecl -> [(QName,Deterministic)] -> Deterministic nondetFunc func@(Func _ _ _ _ rule) calledFuncs = if isNondetDefined func || callsNDOpInRule rule then NDet else Det where callsNDOpInRule (Rule _ e) = callsNDOp e callsNDOpInRule (External _) = False callsNDOp (Var _) = False callsNDOp (Lit _) = False callsNDOp (Free _ e) = callsNDOp e callsNDOp (Let bs e) = any callsNDOp (map snd bs) || callsNDOp e callsNDOp (Or _ _) = True callsNDOp (Case _ e bs) = callsNDOp e || any (\ (Branch _ be) -> callsNDOp be) bs callsNDOp (Typed e _) = callsNDOp e callsNDOp (Comb _ qf@(mn,fn) es) | mn == "SetFunctions" && take 3 fn == "set" && all isDigit (drop 3 fn) = -- non-determinism of function (first argument) is encapsulated so that -- its called ND functions are not relevant: if null es then False -- this case should not occur else any callsNDOp (tail es) | mn == "AllSolutions" -- && fn `elem`== "getAllValues" = -- non-determinism of argument is encapsulated so that -- its called ND functions are not relevant: False | otherwise = maybe False (==NDet) (lookup qf calledFuncs) || any callsNDOp es ------------------------------------------------------------------------------ --- Data type to represent information about non-deterministic dependencies. --- Basically, it is the set (represented as a sorted list) of --- all function names that are defined by overlapping rules or rules --- containing free variables which might be called. --- In addition, the second component is (possibly) the list of --- functions from which this non-deterministic function is called. --- The length of this list is limited by 'maxDepsLength' in the --- `NonDetAllDeps` analysis or to 1 (i.e., only the direct caller is --- stored) in the `NonDetDeps` analysis. type NonDetDeps = [(QName,[QName])] --- The maximal length of a call chain associated with a non-deterministic --- operation dependency. We limit the length in order to avoid large --- analysis times for the `NonDetAllDeps` analysis. maxDepsLength :: Int maxDepsLength = 10 -- Show determinism dependency information as a string. showNonDetDeps :: AOutFormat -> NonDetDeps -> String showNonDetDeps AText [] = "deterministic" showNonDetDeps ANote [] = "" showNonDetDeps ANote xs@(_:_) = intercalate " " (nub (map (snd . fst) xs)) showNonDetDeps AText xs@(_:_) = "depends on non-det. operations: " ++ intercalate ", " (map showNDOpInfo xs) where showNDOpInfo (ndop,cfs) = showQName ndop ++ (if null cfs then "" else " (called from " ++ intercalate " -> " (map showQName cfs) ++ ")") showQName (mn,fn) = mn++"."++fn --- Non-deterministic dependency analysis. --- The analysis computes for each operation the set of operations --- with a non-deterministic definition which might be called by this --- operation. Non-deterministic operations that are called by other --- non-deterministic operations are ignored so that only the first --- (w.r.t. the call sequence) non-deterministic operations are returned. nondetDepAnalysis :: Analysis NonDetDeps nondetDepAnalysis = dependencyFuncAnalysis "NonDetDeps" [] (nondetDeps False) --- Non-deterministic dependency analysis. --- The analysis computes for each operation the set of *all* operations --- with a non-deterministic definition which might be called by this --- operation. nondetDepAllAnalysis :: Analysis NonDetDeps nondetDepAllAnalysis = dependencyFuncAnalysis "NonDetAllDeps" [] (nondetDeps True) -- An operation is non-deterministic if its definition is potentially -- non-deterministic (i.e., the dependency is the operation itself) -- or it depends on some called non-deterministic function. nondetDeps :: Bool -> FuncDecl -> [(QName,NonDetDeps)] -> NonDetDeps nondetDeps alldeps func@(Func f _ _ _ rule) calledFuncs = let calledndfuncs = sort (nub (map addCaller (calledNDFuncsInRule rule))) addCaller (ndf,cfs) | null cfs = (ndf,[f]) | alldeps && f `notElem` cfs && length cfs < maxDepsLength = (ndf,f:cfs) | otherwise = (ndf,cfs) in if isNondetDefined func then (f,[]) : (if alldeps then calledndfuncs else []) else calledndfuncs where calledNDFuncsInRule (Rule _ e) = calledNDFuncs e calledNDFuncsInRule (External _) = [] calledNDFuncs (Var _) = [] calledNDFuncs (Lit _) = [] calledNDFuncs (Free _ e) = calledNDFuncs e calledNDFuncs (Let bs e) = concatMap calledNDFuncs (map snd bs) ++ calledNDFuncs e calledNDFuncs (Or e1 e2) = calledNDFuncs e1 ++ calledNDFuncs e2 calledNDFuncs (Case _ e bs) = calledNDFuncs e ++ concatMap (\ (Branch _ be) -> calledNDFuncs be) bs calledNDFuncs (Typed e _) = calledNDFuncs e calledNDFuncs (Comb _ qf@(mn,fn) es) | mn == "SetFunctions" && take 3 fn == "set" && all isDigit (drop 3 fn) = -- non-determinism of function (first argument) is encapsulated so that -- its called ND functions are not relevant: if null es then [] -- this case should not occur else concatMap calledNDFuncs (tail es) | mn == "AllSolutions" -- && fn `elem`== "getAllValues" = -- non-determinism of argument is encapsulated so that -- its called ND functions are not relevant: [] | otherwise = maybe [] id (lookup qf calledFuncs) ++ concatMap calledNDFuncs es ------------------------------------------------------------------------------ pre :: String -> QName pre n = ("Prelude",n) ------------------------------------------------------------------------------ curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/Files.curry000066400000000000000000000233741377556325500277670ustar00rootroot00000000000000-------------------------------------------------------------------------- --- This module contains operations to load and store analysis information --- persistently in files. --- --- @author Heiko Hoffmann, Michael Hanus --- @version December 2020 -------------------------------------------------------------------------- module Analysis.Files where import Curry.Compiler.Distribution ( curryCompiler, curryCompilerMajorVersion , curryCompilerMinorVersion , curryCompilerRevisionVersion, installDir ) import System.Directory import System.FilePath import Data.List ( intercalate, isPrefixOf, isSuffixOf ) import Data.Time ( ClockTime ) import Control.Monad ( when, unless ) import ReadShowTerm ( readQTerm, showQTerm ) import FlatCurry.Files import FlatCurry.Goodies ( progImports ) import FlatCurry.Types ( Prog, QName ) import System.CurryPath ( lookupModuleSourceInLoadPath, stripCurrySuffix ) import Analysis.Logging ( debugMessage ) import Analysis.ProgInfo --- Get the file name in which analysis results are stored --- (without suffix ".pub" or ".priv") getAnalysisBaseFile :: String -> String -> IO String getAnalysisBaseFile moduleName anaName = do analysisDirectory <- getAnalysisDirectory currentDir <- getCurrentDirectory >>= return . dropDrive let modAnaName = moduleName <.> anaName (fileDir,_) <- findModuleSourceInLoadPath moduleName if isAbsolute fileDir then return (analysisDirectory dropDrive fileDir modAnaName) else return (analysisDirectory currentDir fileDir modAnaName) --- Get the file name in which public analysis results are stored. getAnalysisPublicFile :: String -> String -> IO String getAnalysisPublicFile modname ananame = do getAnalysisBaseFile modname ananame >>= return . (<.> "pub") -- Cache directory where analysis info files are stored. -- If $HOME exists, it is ~/.curryanalysis_cache getAnalysisDirectory :: IO String getAnalysisDirectory = do homedir <- getHomeDirectory hashomedir <- doesDirectoryExist homedir let cassStoreDir = if hashomedir then homedir else installDir return $ cassStoreDir ".curryanalysis_cache" syspath where syspath = curryCompiler ++ "-" ++ intercalate "." (map show [ curryCompilerMajorVersion , curryCompilerMinorVersion , curryCompilerRevisionVersion ]) -- loads analysis results for a list of modules getInterfaceInfos :: Read a => String -> [String] -> IO (ProgInfo a) getInterfaceInfos _ [] = return emptyProgInfo getInterfaceInfos anaName (mod:mods) = do modInfo <- loadPublicAnalysis anaName mod modsInfo <- getInterfaceInfos anaName mods return (combineProgInfo modInfo modsInfo) --- Gets the file name in which default analysis values different from --- standard start values are stored. Typically, such a file contains --- specific analysis information for external operations. --- The file must contain a term of the type `[(String,a)]` where --- the first component of each pair is the name of the operation --- (it is assumed that this denotes an operation of the current module) --- and the second component is an analysis value. loadDefaultAnalysisValues :: String -> String -> IO [(QName,a)] loadDefaultAnalysisValues anaName moduleName = do (_,fileName) <- findModuleSourceInLoadPath moduleName let defaultFileName = stripCurrySuffix fileName ++ ".defaults." ++ anaName fileExists <- doesFileExist defaultFileName if fileExists then do debugMessage 3 ("Load default values from " ++ defaultFileName) defaultValues <- readFile defaultFileName >>= return . readQTerm return (map (\ (f,a) -> ((moduleName,f),a)) defaultValues) else return [] --- Loads the currently stored analysis information for a module. loadCompleteAnalysis :: Read a => String -> String -> IO (ProgInfo a) loadCompleteAnalysis ananame mainModule = getAnalysisBaseFile mainModule ananame >>= readAnalysisFiles --- Reads analysis result from file for the public entities of a given module. loadPublicAnalysis:: Read a => String -> String -> IO (ProgInfo a) loadPublicAnalysis anaName moduleName = do getAnalysisPublicFile moduleName anaName >>= readAnalysisPublicFile --- Store current import dependencies. storeImportModuleList :: String -> [String] -> IO () storeImportModuleList modname modlist = do importListFile <- getAnalysisBaseFile modname "IMPORTLIST" createDirectoryR (dropFileName importListFile) writeFile importListFile (showQTerm modlist) --- Gets the file containing import dependencies for a main module --- (if it exists). getImportModuleListFile :: String -> IO (Maybe String) getImportModuleListFile modname = do importListFile <- getAnalysisBaseFile modname "IMPORTLIST" iflExists <- doesFileExist importListFile return $ if iflExists then Just importListFile else Nothing --- Store an analysis results in a file and create directories if neccesssary. --- The first argument is the analysis name. storeAnalysisResult :: Show a => String -> String -> ProgInfo a -> IO () storeAnalysisResult ananame moduleName result = do baseFileName <- getAnalysisBaseFile moduleName ananame createDirectoryR (dropFileName baseFileName) debugMessage 4 ("Analysis result: " ++ showProgInfo result) writeAnalysisFiles baseFileName result -- creates directory (and all needed root-directories) recursively createDirectoryR :: String -> IO () createDirectoryR maindir = let (drv,dir) = splitDrive maindir in createDirectories drv (splitDirectories dir) where createDirectories _ [] = return () createDirectories dirname (dir:dirs) = do let createdDir = dirname dir dirExists <- doesDirectoryExist createdDir unless dirExists $ do debugMessage 3 ("Creating directory '" ++ createdDir ++ "'...") createDirectory createdDir createDirectories createdDir dirs --- Deletes all analysis files for a given analysis name. deleteAllAnalysisFiles :: String -> IO () deleteAllAnalysisFiles ananame = do analysisDir <- getAnalysisDirectory deleteAllInDir analysisDir where deleteAllInDir dir = do dircont <- getDirectoryContents dir mapM_ processDirElem (filter (not . isPrefixOf ".") dircont) where processDirElem f = do let fullname = dir f when (isAnaFile f) $ do putStrLn ("DELETE: " ++ fullname) removeFile fullname isdir <- doesDirectoryExist fullname when isdir $ deleteAllInDir fullname isAnaFile f = (".pub" `isSuffixOf` f && ('.':ananame) `isSuffixOf` dropExtension f) || (".priv" `isSuffixOf` f && ('.':ananame) `isSuffixOf` dropExtension f) -------------------------------------------------------------------------- -- Auxiliaries for dealing with Curry files. --- Returns a directory name and the actual source file name for a module --- by looking up the module source in the current load path. --- If the module is hierarchical, the directory is the top directory --- of the hierarchy. --- An error is raised if there is no corresponding source file. findModuleSourceInLoadPath :: String -> IO (String,String) findModuleSourceInLoadPath modname = lookupModuleSourceInLoadPath modname >>= maybe (error $ "Source file for module '"++modname++"' not found!") return --- Get the imports of a module. getImports :: String -> IO [String] getImports moduleName = do debugMessage 3 ("Reading interface of module "++moduleName) readNewestFlatCurryInt moduleName >>= return . progImports -- Get timestamp of a Curry source module file (together with the module name) getSourceFileTime :: String -> IO (String,ClockTime) getSourceFileTime moduleName = do (_,fileName) <- findModuleSourceInLoadPath moduleName time <- getModificationTime fileName return (moduleName,time) -- Get timestamp of FlatCurry file (together with the module name) getFlatCurryFileTime :: String -> IO (String,Maybe ClockTime) getFlatCurryFileTime modname = lookupFlatCurryFileInLoadPath modname >>= maybe (return (modname, Nothing)) (\fcyFileName -> do ftime <- getModificationTime fcyFileName return (modname, Just ftime)) --- Returns name of the FlatCurry file of a module if this file exists --- and is newer than the source file. flatCurryFileNewer :: String -> IO (Maybe String) flatCurryFileNewer modname = do (_,sourceFileName) <- findModuleSourceInLoadPath modname stime <- getModificationTime sourceFileName lookupFlatCurryFileInLoadPath modname >>= maybe (return Nothing) (\fcyFileName -> do itime <- getModificationTime fcyFileName return (if itime >= stime then Just fcyFileName else Nothing)) --- Returns the newest FlatCurry program for a module. --- The source program is parsed if the interface older than the source, --- otherwise the FlatCurry program is read without parsing --- (note that this returns only the correct version if the --- imported modules are already parsed or are not relevant here). readNewestFlatCurry :: String -> IO Prog readNewestFlatCurry modname = flatCurryFileNewer modname >>= maybe (readFlatCurry modname) readFlatCurryFile --- Returns the newest FlatCurry interface for a module. --- The source program is parsed if the interface older than the source, --- otherwise the FlatCurry interface file is read without parsing --- (note that this returns only the correct version if the --- imported modules are already parsed or are not relevant here). readNewestFlatCurryInt :: String -> IO Prog readNewestFlatCurryInt modname = flatCurryFileNewer modname >>= maybe (readFlatCurryInt modname) (readFlatCurryFile . flat2intName) --- Translates FlatCurry file name to corresponding FlatCurry interface --- file name. flat2intName :: String -> String flat2intName fn = reverse ("tnif" ++ drop 3 (reverse fn)) curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/Groundness.curry000066400000000000000000000241161377556325500310470ustar00rootroot00000000000000------------------------------------------------------------------------ --- Groundness/non-determinism effect analysis based on --- [Brassel/Hanus'05](http://www.informatik.uni-kiel.de/~mh/papers/ICLP05.html). --- --- @author Michael Hanus --- @version May 2013 ------------------------------------------------------------------------ module Analysis.Groundness ( Ground(..), showGround, groundAnalysis , NDEffect(..), showNDEffect, ndEffectAnalysis ) where import FlatCurry.Types import Data.List import Analysis.Types import Analysis.ProgInfo ------------------------------------------------------------------------ -- Analyze the groundness of functions. ------------------------------------------------------------------------ --- Type to represent groundness information. --- Definitely ground (G), maybe non-ground (A), or maybe non-ground --- if i-th argument is non-ground (P [...,i,...]). data Ground = G | A | P [Int] deriving (Show, Read, Eq) -- Show groundness information as a string. showGround :: AOutFormat -> Ground -> String showGround ANote G = "G" showGround AText G = "always ground result" showGround ANote A = "A" showGround AText A = "possibly non-ground result" showGround ANote (P ps) = show ps showGround AText (P ps) = "ground if argument" ++ (if length ps == 1 then ' ' : show (head ps) ++ " is ground" else "s " ++ show ps ++ " are ground") -- Lowest upper bound on groundness information. lubG :: Ground -> Ground -> Ground lubG G y = y lubG A _ = A lubG (P ps) G = P ps lubG (P _ ) A = A lubG (P ps) (P qs) = P (mergeInts ps qs) ------------------------------------------------------------------------ -- Analyze the groundness information of functions. groundAnalysis :: Analysis Ground groundAnalysis = dependencyFuncAnalysis "Groundness" G groundFunc groundFunc :: FuncDecl -> [(QName,Ground)] -> Ground groundFunc (Func (m,f) _ _ _ rule) calledFuncs | m==prelude && f `elem` preludeGroundFuncs = G | m==prelude = maybe anaresult id (lookup f preludeFuncs) | otherwise = anaresult where anaresult = groundFuncRule calledFuncs rule preludeFuncs = [("cond",P [2]),("seq",P [2]),("ensureNotFree",P [1])] preludeGroundFuncs = ["+","-","*","div","mod","divMod","quot","rem","quotRem","negateFloat", "==","=:=","=:<=","compare","<",">","<=",">=","failed","error"] groundFuncRule :: [(QName,Ground)] -> Rule -> Ground groundFuncRule _ (External _) = A -- nothing known about other externals groundFuncRule calledFuncs (Rule args rhs) = absEvalExpr (zip args (map (\i->P [i]) [1..])) rhs where -- abstract evaluation of an expression w.r.t. groundness environment absEvalExpr env (Var i) = maybe A -- occurs in case of recursive lets id (lookup i env) absEvalExpr _ (Lit _) = G absEvalExpr env (Comb ct g es) = if ct == FuncCall then maybe (error $ "Abstract value of " ++ show g ++ " not found!") (\gd -> let curargs = zip [1..] (map (absEvalExpr env) es) in groundApply gd curargs) (lookup g calledFuncs) else foldr lubG G (map (absEvalExpr env) es) absEvalExpr env (Free vs e) = absEvalExpr (zip vs (repeat A) ++ env) e absEvalExpr env (Let bs e) = absEvalExpr (absEvalBindings env bs) e absEvalExpr env (Or e1 e2) = lubG (absEvalExpr env e1) (absEvalExpr env e2) absEvalExpr env (Typed e _) = absEvalExpr env e absEvalExpr env (Case _ e bs) = foldr lubG G (map absEvalBranch bs) where gcase = absEvalExpr env e absEvalBranch (Branch (LPattern _) be) = absEvalExpr env be absEvalBranch (Branch (Pattern _ pargs) be) = absEvalExpr (map (\pi -> (pi,gcase)) pargs ++ env) be -- could be improved for recursive lets with local fixpoint computation absEvalBindings env [] = env absEvalBindings env ((i,exp):bs) = absEvalBindings ((i, absEvalExpr env exp) : env) bs -- compute groundness information for an application groundApply :: Ground -> [(Int,Ground)] -> Ground groundApply G _ = G groundApply A _ = A groundApply (P ps) gargs = foldr lubG G (map (\p -> maybe A id (lookup p gargs)) ps) ----------------------------------------------------------------------- -- Non-determinism effect analysis ----------------------------------------------------------------------- --- Type to represent non-determinism effects. --- A non-determinism effect can be due to an Or (first argument), --- due to a narrowing step (second argument), or if i-th argument --- is non-ground (if i is a member of the third argument). data NDEffect = NDEffect Bool Bool [Int] deriving (Eq, Ord, Show, Read) noEffect :: NDEffect noEffect = NDEffect False False [] orEffect :: NDEffect orEffect = NDEffect True False [] narrEffect :: NDEffect narrEffect = NDEffect False True [] narrIfEffect :: [Int] -> NDEffect narrIfEffect = NDEffect False False -- Show non-determinitic effect information as a string. showNDEffect :: AOutFormat -> NDEffect -> String showNDEffect ANote (NDEffect ornd narr ifs) = intercalate " " $ (if ornd then ["choice"] else []) ++ (if narr then ["narr"] else []) ++ (if not (null ifs) then ["narrIf"++show ifs] else []) showNDEffect AText (NDEffect ornd narr ifs) = intercalate " / " $ (if ornd then ["choice"] else []) ++ (if narr then ["possibly non-deterministic narrowing steps"] else []) ++ (if not (null ifs) then ["non-deterministic narrowing if argument" ++ (if length ifs == 1 then ' ' : show (head ifs) ++ " is non-ground" else "s " ++ show ifs ++ " are non-ground")] else []) -- Lowest upper bound on non-determinism effects. lubE :: NDEffect -> NDEffect -> NDEffect lubE (NDEffect ornd1 narr1 ifs1) (NDEffect ornd2 narr2 ifs2) = NDEffect (ornd1 || ornd2) narr (if narr then [] else mergeInts ifs1 ifs2) where narr = narr1 || narr2 -- Lowest upper bound on groundness/non-determinism effects. lubGE :: (Ground,NDEffect) -> (Ground,NDEffect) -> (Ground,NDEffect) lubGE (g1,ne1) (g2,ne2) = (lubG g1 g2, lubE ne1 ne2) ------------------------------------------------------------------------ -- Analyze the non-determinism effect of functions. ndEffectAnalysis :: Analysis NDEffect ndEffectAnalysis = combinedDependencyFuncAnalysis "NDEffect" groundAnalysis noEffect ndEffectFunc ndEffectFunc :: ProgInfo Ground -> FuncDecl -> [(QName,NDEffect)] -> NDEffect ndEffectFunc groundinfo (Func (m,f) _ _ _ rule) calledFuncs | m==prelude = maybe anaresult id (lookup f preludeFuncs) | otherwise = anaresult where anaresult = ndEffectFuncRule groundinfo calledFuncs rule preludeFuncs = [("?",orEffect)] ndEffectFuncRule :: ProgInfo Ground -> [(QName,NDEffect)] -> Rule -> NDEffect ndEffectFuncRule _ _ (External _) = noEffect -- externals are deterministic ndEffectFuncRule groundinfo calledFuncs (Rule args rhs) = snd (absEvalExpr (zip args (map (\i->(P [i],noEffect)) [1..])) rhs) where -- abstract evaluation of an expression w.r.t. NDEffect environment absEvalExpr env (Var i) = maybe (A,noEffect) id (lookup i env) absEvalExpr _ (Lit _) = (G,noEffect) absEvalExpr env (Comb ct g es) = if ct == FuncCall then maybe (error $ "Abstract value of " ++ show g ++ " not found!") (\gnd -> let curargs = zip [1..] (map (absEvalExpr env) es) in maybe (error $ "Ground value of " ++ show g ++ " not found!") (\ggd -> ndEffectApply (ggd,gnd) curargs) (lookupProgInfo g groundinfo)) (lookup g calledFuncs) else foldr lubGE (G,noEffect) (map (absEvalExpr env) es) absEvalExpr env (Free vs e) = absEvalExpr (zip vs (repeat (A,noEffect)) ++ env) e absEvalExpr env (Let bs e) = absEvalExpr (absEvalBindings env bs) e absEvalExpr env (Or e1 e2) = let (g1,nd1) = absEvalExpr env e1 (g2,nd2) = absEvalExpr env e2 in (lubG g1 g2, lubE orEffect (lubE nd1 nd2)) absEvalExpr env (Typed e _) = absEvalExpr env e absEvalExpr env (Case ctype e bs) = if ctype==Rigid {- not really for KiCS2 -} || gcase==G || length bs == 1 then (gbrs, lubE ndbrs ndcase) else (gbrs, lubE (ground2nondet gcase) (lubE ndbrs ndcase)) where (gcase,ndcase) = absEvalExpr env e (gbrs,ndbrs) = foldr lubGE (G,noEffect) (map absEvalBranch bs) ground2nondet G = noEffect ground2nondet A = narrEffect ground2nondet (P ps) = narrIfEffect ps absEvalBranch (Branch (LPattern _) be) = absEvalExpr env be absEvalBranch (Branch (Pattern _ pargs) be) = absEvalExpr (map (\pi -> (pi,(gcase,noEffect))) pargs ++ env) be -- could be improved for recursive lets with local fixpoint computation absEvalBindings env [] = env absEvalBindings env ((i,exp):bs) = absEvalBindings ((i, absEvalExpr env exp) : env) bs -- compute ground/nondet effect information for an application ndEffectApply :: (Ground,NDEffect) -> [(Int,(Ground,NDEffect))] -> (Ground,NDEffect) ndEffectApply (fgd,fnd) argsgnd = let (argsgd,argsnd) = unzip (map (\ (i,(gd,nd)) -> ((i,gd),nd)) argsgnd) in (groundApply fgd argsgd, foldr lubE (ndEffectReplace argsgd fnd) argsnd) -- replace (narrIf i) by i-th ground value ndEffectReplace :: [(Int,Ground)] -> NDEffect -> NDEffect ndEffectReplace argsgd (NDEffect ornd narrnd ifs) = replaceProjs [] ifs where -- replace i by i-th ground value replaceProjs ps [] = NDEffect ornd narrnd ps replaceProjs ps (i:is) = maybe (error $ "Ground value of argument " ++ show i ++ " not found!") (\g -> case g of G -> replaceProjs ps is A -> NDEffect ornd True [] P ips -> replaceProjs (mergeInts ips ps) is) (lookup i argsgd) ----------------------------------------------------------------------- -- merge ascending lists of integers and remove duplicates mergeInts :: [Int] -> [Int] -> [Int] mergeInts [] ys = ys mergeInts (x:xs) [] = x:xs mergeInts (x:xs) (y:ys) | x==y = x : mergeInts xs ys | xy = y : mergeInts (x:xs) ys prelude :: String prelude = "Prelude" ----------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/HigherOrder.curry000066400000000000000000000061521377556325500311220ustar00rootroot00000000000000------------------------------------------------------------------------ --- Analysis of higher-order properties of types and operations. ------------------------------------------------------------------------ module Analysis.HigherOrder (Order(..),showOrder,hiOrdType,hiOrdCons,hiOrdFunc) where import Analysis.Types import Analysis.ProgInfo import FlatCurry.Types import FlatCurry.Goodies import Data.Maybe -- datatype order: higher-order or first-order data Order = HO | FO deriving (Show, Read, Eq) -- Show higher-order information as a string. showOrder :: AOutFormat -> Order -> String showOrder _ HO = "higher-order" showOrder _ FO = "first-order" hoOr :: Order -> Order -> Order hoOr HO _ = HO hoOr FO x = x ------------------------------------------------------------------------ -- higher-order data type analysis hiOrdType :: Analysis Order hiOrdType = dependencyTypeAnalysis "HiOrderType" FO orderOfType orderOfType :: TypeDecl -> [(QName,Order)] -> Order orderOfType (Type _ _ _ conDecls) usedtypes = hoOr (foldr hoOr FO (map orderOfConsDecl conDecls)) (foldr hoOr FO (map snd usedtypes)) where orderOfConsDecl (Cons _ _ _ typeExprs) = foldr hoOr FO (map orderOfTypeExpr typeExprs) orderOfType (TypeSyn _ _ _ typeExpr) usedtypes = hoOr (orderOfTypeExpr typeExpr) (foldr hoOr FO (map snd usedtypes)) orderOfType (TypeNew _ _ _ (NewCons _ _ typeExpr)) usedtypes = hoOr (orderOfTypeExpr typeExpr) (foldr hoOr FO (map snd usedtypes)) -- compute the order of a type expression (ignore the type constructors, -- i.e., check whether this expression contains a `FuncType`). orderOfTypeExpr :: TypeExpr -> Order orderOfTypeExpr (TVar _) = FO orderOfTypeExpr (FuncType _ _) = HO orderOfTypeExpr (TCons _ typeExprs) = foldr hoOr FO (map orderOfTypeExpr typeExprs) orderOfTypeExpr (ForallType _ texp) = orderOfTypeExpr texp ----------------------------------------------------------------------- -- higher-order constructor analysis hiOrdCons :: Analysis Order hiOrdCons = simpleConstructorAnalysis "HiOrderConstr" orderOfConsDecl where orderOfConsDecl (Cons _ _ _ typeExprs) _ = foldr hoOr FO (map orderOfTypeExpr typeExprs) ----------------------------------------------------------------------- -- higher-order function analysis hiOrdFunc :: Analysis Order hiOrdFunc = combinedSimpleFuncAnalysis "HiOrderFunc" hiOrdType orderOfFunc orderOfFunc :: ProgInfo Order -> FuncDecl-> Order orderOfFunc orderMap func = orderOfFuncTypeArity orderMap (funcType func) (funcArity func) orderOfFuncTypeArity :: ProgInfo Order -> TypeExpr -> Int -> Order orderOfFuncTypeArity orderMap functype arity = if arity==0 then case functype of FuncType _ _ -> HO TVar (-42) -> HO TCons x (y:ys) -> hoOr (orderOfFuncTypeArity orderMap y 0) (orderOfFuncTypeArity orderMap (TCons x ys) 0) TCons tc [] -> fromMaybe FO (lookupProgInfo tc orderMap) _ -> FO else let (FuncType x y) = functype in hoOr (orderOfFuncTypeArity orderMap x 0) (orderOfFuncTypeArity orderMap y (arity-1)) ----------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/Indeterministic.curry000066400000000000000000000052241377556325500320510ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Indeterminism analysis: --- check whether functions are indeterministic, i.e., might deliver --- different results for different runs of a program. --- This could be the case if there are explicit or implicit calls --- to `SetFunctions.select` or to a committed choice. --- --- @author Michael Hanus --- @version April 2013 ------------------------------------------------------------------------------ module Analysis.Indeterministic(indetAnalysis,showIndet) where import Analysis.Types import FlatCurry.Types ------------------------------------------------------------------------------ --- The indeterminism analysis is a global function dependency analysis. --- It assigns to a function a flag which is True if this function --- might be indeterministic (i.e., calls directly or indirectly --- a select or committed choice operation). indetAnalysis :: Analysis Bool indetAnalysis = dependencyFuncAnalysis "Indeterministic" False indetFunc --- An operation is indeterministic if it calls a select or committed choice --- or depends on some indeterministic operation. indetFunc :: FuncDecl -> [(QName,Bool)] -> Bool indetFunc func calledFuncs = hasIndetRules func || any snd calledFuncs -- Show right-linearity information as a string. showIndet :: AOutFormat -> Bool -> String showIndet AText True = "impure (indeterministic) operation" showIndet ANote True = "indeterministic" showIndet AText False = "referentially transparent operation" showIndet ANote False = "" ------------------------------------------------------------------------------ -- The right-linearity analysis can also be applied to individual functions. -- It returns True for a function if it is defined by right-linear rules. hasIndetRules :: FuncDecl -> Bool hasIndetRules (Func _ _ _ _ (Rule _ e)) = choiceInExpr e hasIndetRules (Func _ _ _ _ (External _)) = False -- check an expression for occurrences of select, committed choice, or send: choiceInExpr :: Expr -> Bool choiceInExpr (Var _) = False choiceInExpr (Lit _) = False choiceInExpr (Comb _ f es) = f `elem` indetFuns || any choiceInExpr es choiceInExpr (Free _ e) = choiceInExpr e choiceInExpr (Let bs e) = any choiceInExpr (map snd bs) || choiceInExpr e choiceInExpr (Or e1 e2) = choiceInExpr e1 || choiceInExpr e2 choiceInExpr (Case _ e bs) = choiceInExpr e || any choiceInBranch bs where choiceInBranch (Branch _ be) = choiceInExpr be choiceInExpr (Typed e _) = choiceInExpr e indetFuns :: [QName] indetFuns = [("Prelude","commit"), ("Ports","send"),("Ports","doSend"), ("SetFunctions","select")] -- end of Indeterministic curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/Logging.curry000066400000000000000000000030221377556325500302770ustar00rootroot00000000000000-------------------------------------------------------------------------- --- This module provides operation for log messages and setting --- the log level for the analyses. --- --- @author Michael Hanus --- @version March 2017 -------------------------------------------------------------------------- module Analysis.Logging ( getDebugLevel, setDebugLevel, debugMessage, debugString ) where import Control.Monad import Global -------------------------------------------------------------------------- --- Global variable to store the debug level. --- Debug levels: --- 0 : show nothing --- 1 : show worker activity, e.g., timings --- 2 : show server communication --- 3 : ...and show read/store information --- 4 : ...show also stored/computed analysis data debugLevel :: Global Int debugLevel = global 1 Temporary --- Gets the current debug level. getDebugLevel :: IO Int getDebugLevel = readGlobal debugLevel --- Sets the debug level to a new value. setDebugLevel :: Int -> IO () setDebugLevel l = writeGlobal debugLevel l -------------------------------------------------------------------------- --- Prints a message line if debugging level is at least n: debugMessage :: Int -> String -> IO () debugMessage n message = debugString n (message++"\n") --- Prints a string if debugging level (as specified in the Config file) --- is at least n: debugString :: Int -> String -> IO () debugString n message = do dl <- getDebugLevel when (dl>=n) $ putStr message -------------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/ProgInfo.curry000066400000000000000000000113601377556325500304400ustar00rootroot00000000000000----------------------------------------------------------------------- --- This module defines a datatype to represent the analysis information. --- --- @author Heiko Hoffmann, Michael Hanus --- @version January 2019 ----------------------------------------------------------------------- module Analysis.ProgInfo ( ProgInfo, emptyProgInfo, lookupProgInfo, combineProgInfo , lists2ProgInfo, publicListFromProgInfo, progInfo2Lists, progInfo2XML , mapProgInfo, publicProgInfo , showProgInfo, equalProgInfo , readAnalysisFiles, readAnalysisPublicFile, writeAnalysisFiles ) where import Prelude hiding (empty, lookup) import System.Directory (removeFile) import System.FilePath ((<.>)) import Data.Map import FlatCurry.Types import XML import Analysis.Logging (debugMessage) --- Type to represent analysis information. --- The first component are public declarations, the second the private ones. data ProgInfo a = ProgInfo (Map QName a) (Map QName a) --- The empty program information. emptyProgInfo:: ProgInfo a emptyProgInfo = ProgInfo empty empty --- Gets the information about an entity. lookupProgInfo:: QName -> ProgInfo a -> Maybe a lookupProgInfo key (ProgInfo map1 map2) = case lookup key map1 of Just x -> Just x Nothing -> lookup key map2 --- Combines two analysis informations. combineProgInfo :: ProgInfo a -> ProgInfo a -> ProgInfo a combineProgInfo (ProgInfo x1 x2) (ProgInfo y1 y2) = ProgInfo (union x1 y1) (union x2 y2) --- Converts a public and a private analysis list into a program info. lists2ProgInfo :: ([(QName,a)],[(QName,a)]) -> ProgInfo a lists2ProgInfo (xs,ys) = ProgInfo (fromList xs) (fromList ys) --- Returns the infos of public operations as a list. publicListFromProgInfo:: ProgInfo a -> [(QName,a)] publicListFromProgInfo (ProgInfo fm1 _) = toList fm1 --- Transforms a program information into a pair of lists --- containing the information about public and private entities. progInfo2Lists :: ProgInfo a -> ([(QName,a)],[(QName,a)]) progInfo2Lists (ProgInfo map1 map2)= (toList map1,toList map2) --- Transforms analysis information into XML format. progInfo2XML :: ProgInfo String -> ([XmlExp],[XmlExp]) progInfo2XML (ProgInfo map1 map2) = (foldrWithKey entry2xml [] map1, foldrWithKey entry2xml [] map2) where entry2xml (mname,name) value xmlList = (xml "operation" [xml "module" [xtxt mname], xml "name" [xtxt name], xml "result" [xtxt value]]) : xmlList mapProgInfo:: (a->b) -> ProgInfo a -> ProgInfo b mapProgInfo func (ProgInfo map1 map2) = ProgInfo (mapWithKey (\_ b->func b) map1) (mapWithKey (\_ b->func b) map2) --- Transforms a program information into a program information --- about interface entities only. publicProgInfo :: ProgInfo a -> ProgInfo a publicProgInfo (ProgInfo pub _) = ProgInfo pub empty --- Show a ProgInfo as a string (used for debugging only). showProgInfo :: Show a => ProgInfo a -> String showProgInfo (ProgInfo fm1 fm2) = "Public: "++show fm1++"\nPrivate: "++show fm2 -- Equality on ProgInfo equalProgInfo :: Eq a => ProgInfo a -> ProgInfo a -> Bool equalProgInfo (ProgInfo pi1p pi1v) (ProgInfo pi2p pi2v) = pi1p == pi2p && pi1v == pi2v --- Writes a ProgInfo into a file. writeAnalysisFiles :: Show a => String -> ProgInfo a -> IO () writeAnalysisFiles basefname (ProgInfo pub priv) = do debugMessage 3 $ "Writing analysis files '"++basefname++"'..." writeFile (basefname <.> "priv") (show priv) writeFile (basefname <.> "pub") (show pub) --- Reads a ProgInfo from the analysis files where the base file name is given. readAnalysisFiles :: Read a => String -> IO (ProgInfo a) readAnalysisFiles basefname = do debugMessage 3 $ "Reading analysis files '"++basefname++"'..." let pubcontfile = basefname <.> "pub" privcontfile = basefname <.> "priv" pubcont <- readFile pubcontfile privcont <- readFile privcontfile let pinfo = ProgInfo (read pubcont) (read privcont) catch (return $!! pinfo) (\err -> do putStrLn ("Buggy analysis files detected and removed:\n"++ basefname) mapM_ removeFile [pubcontfile,privcontfile] putStrLn "Please try to re-run the analysis!" ioError err) --- Reads the public ProgInfo from the public analysis file. readAnalysisPublicFile :: Read a => String -> IO (ProgInfo a) readAnalysisPublicFile fname = do debugMessage 3 $ "Reading public analysis file '"++fname++"'..." fcont <- readFile fname let pinfo = ProgInfo (read fcont) empty catch (return $!! pinfo) (\err -> do putStrLn ("Buggy analysis files detected and removed:\n"++fname) removeFile fname putStrLn "Please try to re-run the analysis!" ioError err) ----------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/RequiredValue.curry000066400000000000000000000301311377556325500314670ustar00rootroot00000000000000----------------------------------------------------------------------------- --- Required value analysis for Curry programs --- --- This analysis checks for each function in a Curry program whether --- the arguments of a function must have a particular shape in order to --- compute some value of this function. --- For instance, the negation operation `not` requires the argument --- value `False` in order to compute the result `True` and it requires --- the argument `True` to compute the result `False`. --- --- @author Michael Hanus --- @version April 2018 ----------------------------------------------------------------------------- module Analysis.RequiredValue (AType(..), showAType, AFType(..), showAFType, lubAType, reqValueAnalysis) where import Analysis.Types import Analysis.ProgInfo import Analysis.TotallyDefined(siblingCons) import FlatCurry.Types import FlatCurry.Goodies import Data.List ------------------------------------------------------------------------------ -- Our abstract (non-standard) type domain. -- `Any` represents any expression, -- `AnyC` represents any value (i.e., constructor-rooted term), -- `Cons c` a value rooted by the constructor `c`, and -- `Empty` represents no possible value. data AType = Any | AnyC | Cons QName | Empty deriving (Eq, Ord, Show, Read) --- Is some abstract type a constructor? isConsValue :: AType -> Bool isConsValue av = case av of Cons _ -> True _ -> False --- Least upper bound of abstract values. lubAType :: AType -> AType -> AType lubAType Any _ = Any lubAType AnyC Any = Any lubAType AnyC AnyC = AnyC lubAType AnyC (Cons _) = AnyC lubAType AnyC Empty = AnyC lubAType (Cons _) Any = Any lubAType (Cons _) AnyC = AnyC lubAType (Cons c) (Cons d) = if c==d then Cons c else AnyC lubAType (Cons c) Empty = Cons c lubAType Empty av = av --- Join two abstract values. The result is `Empty` if they are not compatible. joinAType :: AType -> AType -> AType joinAType Any av = av joinAType AnyC Any = AnyC joinAType AnyC AnyC = AnyC joinAType AnyC (Cons c) = Cons c joinAType AnyC Empty = Empty joinAType (Cons c) Any = Cons c joinAType (Cons c) AnyC = Cons c joinAType (Cons c) (Cons d) = if c==d then Cons c else Empty joinAType (Cons _) Empty = Empty joinAType Empty _ = Empty --- Are two abstract types compatible, i.e., describe common values? compatibleType :: AType -> AType -> Bool compatibleType t1 t2 = joinAType t1 t2 /= Empty -- Shows an abstract value. showAType :: AOutFormat -> AType -> String showAType _ Any = "any" showAType _ AnyC = "cons" showAType _ (Cons (_,n)) = n --q++"."++n showAType _ Empty = "_|_" --- The abstract type of a function. --- It is either `EmptyFunc`, i.e., contains no information about --- the possible result of the function, --- or a list of possible argument/result type pairs. data AFType = EmptyFunc | AFType [([AType],AType)] deriving (Read, Show, Eq, Ord) -- Shows an abstract value. showAFType :: AOutFormat -> AFType -> String showAFType _ EmptyFunc = "EmptyFunc" showAFType aof (AFType fts) = intercalate " | " (map showFType fts) where showFType (targs,tres) = "(" ++ intercalate "," (map (showAType aof) targs) ++ " -> " ++ showAType aof tres ++ ")" showCalledFuncs :: [(QName,AFType)] -> String showCalledFuncs = intercalate "|" . map (\ ((_,f),at) -> f++"::"++showAFType _ at) ------------------------------------------------------------------------------ --- An abstract environments used in the analysis of a function associates --- to each variable (index) an abstract type. type AEnv = [(Int,AType)] --- Extend an abstract environment with variables of any type: extendEnv :: AEnv -> [Int] -> AEnv extendEnv env vars = zip vars (repeat Any) ++ env --- Update a variable in an abstract environment: updateVarInEnv :: AEnv -> Int -> AType -> AEnv updateVarInEnv [] v _ = error ("Variable "++show v++" not found in environment") updateVarInEnv ((i,ov):env) v nv = if i==v then (i,nv) : env else (i,ov) : updateVarInEnv env v nv --- Drop the first n elements from the environment component --- of an environment/type pair: dropEnv :: Int -> ([a],b) -> ([a],b) dropEnv n (env,rtype) = (drop n env, rtype) -- Sorts a list of environment/type pairs by the type. sortEnvTypes :: [(AEnv,AType)] -> [(AEnv,AType)] sortEnvTypes = sortBy (\ (e1,t1) (e2,t2) -> (t1,e1) <= (t2,e2)) ------------------------------------------------------------------------------ --- The maximum number of different constructors considered for the --- required value analysis. If a type has more constructors than --- specified here, it will not be analyzed for individual required --- constructor values. maxReqValues :: Int maxReqValues = 3 --- Required value analysis. reqValueAnalysis :: Analysis AFType reqValueAnalysis = combinedDependencyFuncAnalysis "RequiredValue" siblingCons EmptyFunc analyseReqVal analyseReqVal :: ProgInfo [(QName,Int)] -> FuncDecl -> [(QName,AFType)] -> AFType analyseReqVal consinfo (Func (m,f) arity _ _ rule) calledfuncs | m==prelude = maybe (anaresult rule) id (lookup f preludeFuncs) | otherwise = --trace ("Analyze "++f++"\n"++showCalledFuncs calledfuncs++ -- "\nRESULT: "++showAFType _ (anaresult rule)) $ anaresult rule where anaresult (External _) = AFType [(take arity (repeat Any),AnyC)] anaresult (Rule args rhs) = analyseReqValRule consinfo calledfuncs args rhs -- add special results for prelude functions here: preludeFuncs = [("failed",AFType [([],Empty)]) ,("==",AFType [([AnyC,AnyC],AnyC)]) ,("=:=",AFType [([AnyC,AnyC],AnyC)]) ,("$",AFType [([AnyC,Any],AnyC)]) ,("$!",AFType [([AnyC,AnyC],AnyC)]) ,("$!!",AFType [([AnyC,AnyC],AnyC)]) ,("$#",AFType [([AnyC,AnyC],AnyC)]) ,("$##",AFType [([AnyC,AnyC],AnyC)]) ,("compare",AFType [([AnyC,AnyC],AnyC)]) ] analyseReqValRule :: ProgInfo [(QName,Int)] -> [(QName,AFType)] -> [Int] -> Expr -> AFType analyseReqValRule consinfo calledfuncs args rhs = let initenv = extendEnv [] args envtypes = reqValExp initenv rhs AnyC rtypes = map snd envtypes in -- If some result is `AnyC` and another result is a constructor, then -- analyze again for all constructors as required results -- in order to get more precise information. if any (==AnyC) rtypes && any isConsValue rtypes then let somecons = maybe (error "Internal error") (\ (Cons c) -> c) (find isConsValue rtypes) othercons = maybe [] (map fst) (lookupProgInfo somecons consinfo) consenvtypes = foldr lubEnvTypes [] (map (\rt -> reqValExp initenv rhs rt) (map Cons (somecons:othercons))) in AFType (map (\ (env,rtype) -> (map snd env, rtype)) (lubAnyEnvTypes (if length othercons >= maxReqValues then envtypes else consenvtypes))) else AFType (map (\ (env,rtype) -> (map snd env, rtype)) (lubAnyEnvTypes envtypes)) where reqValExp env exp reqtype = case exp of Var v -> [(updateVarInEnv env v reqtype, reqtype)] Lit _ -> [(env, AnyC)] -- too many literal constants... Comb ConsCall c _ -> [(env, Cons c)] -- analysis of arguments superfluous Comb FuncCall qf funargs -> if qf==(prelude,"?") && length funargs == 2 then -- use intended definition of Prelude.? for more precise analysis: reqValExp env (Or (head funargs) (funargs!!1)) reqtype else maybe [(env, AnyC)] (\ftype -> case ftype of EmptyFunc -> [(env, Empty)] -- no information available AFType ftypes -> let matchingtypes = filter (compatibleType reqtype . snd) ftypes -- for all matching types analyze arguments -- where a constructor value is required: matchingenvs = map (\ (ts,rt) -> let argenvs = concatMap (envForConsArg env) (zip ts funargs) in (foldr joinEnv env argenvs, rt)) matchingtypes in if null matchingtypes then [(env, Empty)] else matchingenvs ) (lookup qf calledfuncs) Comb _ _ _ -> [(env, AnyC)] -- no reasonable info for partial applications Or e1 e2 -> lubEnvTypes (reqValExp env e1 reqtype) (reqValExp env e2 reqtype) Case _ e branches -> let -- filter non-failing branches: nfbranches = filter (\ (Branch _ be) -> be /= Comb FuncCall (prelude,"failed") []) branches reqenvs = filter (not . null) (map (envForBranch env reqtype e) nfbranches) in if null reqenvs then [(env, Empty)] else foldr1 lubEnvTypes reqenvs Free vars e -> map (dropEnv (length vars)) (reqValExp (extendEnv env vars) e reqtype) Let bindings e -> -- bindings are not analyzed since we don't know whether they are used: map (dropEnv (length bindings)) (reqValExp (extendEnv env (map fst bindings)) e reqtype) Typed e _ -> reqValExp env e reqtype -- compute an expression environment for a function argument if this -- argument is required to be a constructor: envForConsArg env (reqtype,exp) = case reqtype of AnyC -> [foldr1 lubEnv (map fst (reqValExp env exp AnyC))] Cons qc -> [foldr1 lubEnv (map fst (reqValExp env exp (Cons qc)))] _ -> [] -- compute an expression environment and required type for an applied branch envForBranch env reqtype exp (Branch pat bexp) = filter (\ (_,rt) -> compatibleType rt reqtype) branchtypes where branchtypes = case pat of LPattern _ -> reqValExp env bexp reqtype Pattern qc pvars -> let caseenvs = map fst (reqValExp env exp (Cons qc)) branchenvs = foldr lubEnvTypes [] (map (\caseenv -> reqValExp (extendEnv caseenv pvars) bexp reqtype) caseenvs) in map (dropEnv (length pvars)) branchenvs --- "lub" two environment lists. All environment lists are ordered --- by the result type. lubEnvTypes :: [(AEnv,AType)] -> [(AEnv,AType)] -> [(AEnv,AType)] lubEnvTypes [] ets2 = ets2 lubEnvTypes ets1@(_:_) [] = ets1 lubEnvTypes ((env1,t1):ets1) ((env2,t2):ets2) | t1==Empty = lubEnvTypes ets1 ((env2,t2):ets2) -- ignore "empty" infos | t2==Empty = lubEnvTypes ((env1,t1):ets1) ets2 | t1==t2 = (lubEnv env1 env2, t1) : lubEnvTypes ets1 ets2 | t1 [(AEnv,AType)] lubAnyEnvTypes envtypes = if null envtypes || snd (head envtypes) /= AnyC then envtypes else foldr1 lubEnvType envtypes : tail envtypes lubEnvType :: (AEnv,AType) -> (AEnv,AType) -> (AEnv,AType) lubEnvType (env1,t1) (env2,t2) = (lubEnv env1 env2, lubAType t1 t2) lubEnv :: AEnv -> AEnv -> AEnv lubEnv [] _ = [] lubEnv (_:_) [] = [] lubEnv ((i1,v1):env1) env2@(_:_) = maybe (lubEnv env1 env2) (\v2 -> (i1, lubAType v1 v2) : lubEnv env1 env2) (lookup i1 env2) joinEnv :: AEnv -> AEnv -> AEnv joinEnv [] _ = [] joinEnv (_:_) [] = [] joinEnv ((i1,v1):env1) env2@(_:_) = maybe (joinEnv env1 env2) (\v2 -> (i1, joinAType v1 v2) : joinEnv env1 env2) (lookup i1 env2) -- Name of the standard prelude: prelude :: String prelude = "Prelude" curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/RequiredValues.curry000066400000000000000000000317451377556325500316660ustar00rootroot00000000000000----------------------------------------------------------------------------- --- Required value analysis for Curry programs --- --- This analysis checks for each function in a Curry program whether --- the arguments of a function must have a particular shape in order to --- compute some value of this function. --- For instance, the negation operation `not` requires the argument --- value `False` in order to compute the result `True` and it requires --- the argument `True` to compute the result `False`. --- --- @author Michael Hanus --- @version April 2018 ----------------------------------------------------------------------------- module Analysis.RequiredValues (AType(..), showAType, AFType(..), showAFType, lubAType, reqValueAnalysis) where import Analysis.Types import Analysis.ProgInfo import Analysis.TotallyDefined(siblingCons) import FlatCurry.Types import FlatCurry.Goodies import Data.List hiding (union,intersect) ------------------------------------------------------------------------------ -- Our abstract (non-standard) type domain. -- `Any` represents any expression, -- `AnyC` represents any value (i.e., constructor-rooted term), -- `Cons cs` a value rooted by some of the constructor `cs`, and data AType = Cons [QName] | AnyC | Any deriving (Eq, Ord, Show, Read) --- Abstract representation of no possible value. empty :: AType empty = Cons [] --- Is some abstract type a constructor? isConsValue :: AType -> Bool isConsValue av = case av of Cons cs -> not (null cs) _ -> False --- Least upper bound of abstract values. lubAType :: AType -> AType -> AType lubAType Any _ = Any lubAType AnyC Any = Any lubAType AnyC AnyC = AnyC lubAType AnyC (Cons _) = AnyC lubAType (Cons _) Any = Any lubAType (Cons _) AnyC = AnyC lubAType (Cons c) (Cons d) = Cons (union c d) -- replace previous rule by following rule in order to use singleton sets: --lubAType (Cons c) (Cons d) = if c==d then Cons c else AnyC --- Join two abstract values. The result is `Empty` if they are not compatible. joinAType :: AType -> AType -> AType joinAType Any av = av joinAType AnyC Any = AnyC joinAType AnyC AnyC = AnyC joinAType AnyC (Cons c) = Cons c joinAType (Cons c) Any = Cons c joinAType (Cons c) AnyC = Cons c joinAType (Cons c) (Cons d) = Cons (intersect c d) -- replace previous rule by following rule in order to use singleton sets: --joinAType (Cons c) (Cons d) = if c==d then Cons c else Cons [] --- Are two abstract types compatible, i.e., describe common values? compatibleType :: AType -> AType -> Bool compatibleType t1 t2 = joinAType t1 t2 /= empty -- Shows an abstract value. showAType :: AOutFormat -> AType -> String showAType _ Any = "any" showAType _ AnyC = "cons" showAType _ (Cons cs) = "{" ++ intercalate "," (map snd cs) ++ "}" --- The abstract type of a function. --- It is either `EmptyFunc`, i.e., contains no information about --- the possible result of the function, --- or a list of possible argument/result type pairs. data AFType = EmptyFunc | AFType [([AType],AType)] deriving (Eq, Ord, Show, Read) -- Shows an abstract value. showAFType :: AOutFormat -> AFType -> String showAFType _ EmptyFunc = "EmptyFunc" showAFType aof (AFType fts) = intercalate " | " (map showFType fts) where showFType (targs,tres) = "(" ++ intercalate "," (map (showAType aof) targs) ++ " -> " ++ showAType aof tres ++ ")" showCalledFuncs :: [(QName,AFType)] -> String showCalledFuncs = intercalate "|" . map (\ ((_,f),at) -> f++"::"++showAFType _ at) ------------------------------------------------------------------------------ --- An abstract environments used in the analysis of a function associates --- to each variable (index) an abstract type. type AEnv = [(Int,AType)] --- Extend an abstract environment with variables of any type: extendEnv :: AEnv -> [Int] -> AEnv extendEnv env vars = zip vars (repeat Any) ++ env --- Update a variable in an abstract environment: updateVarInEnv :: AEnv -> Int -> AType -> AEnv updateVarInEnv [] v _ = error ("Variable "++show v++" not found in environment") updateVarInEnv ((i,ov):env) v nv = if i==v then (i,nv) : env else (i,ov) : updateVarInEnv env v nv --- Drop the first n elements from the environment component --- of an environment/type pair: dropEnv :: Int -> ([a],b) -> ([a],b) dropEnv n (env,rtype) = (drop n env, rtype) -- Sorts a list of environment/type pairs by the type. sortEnvTypes :: [(AEnv,AType)] -> [(AEnv,AType)] sortEnvTypes = sortBy (\ (e1,t1) (e2,t2) -> (t1,e1) <= (t2,e2)) ------------------------------------------------------------------------------ --- The maximum number of different constructors considered for the --- required value analysis. If a type has more constructors than --- specified here, it will not be analyzed for individual required --- constructor values. maxReqValues :: Int maxReqValues = 3 --- Required value analysis. reqValueAnalysis :: Analysis AFType reqValueAnalysis = combinedDependencyFuncAnalysis "RequiredValues" siblingCons EmptyFunc analyseReqVal analyseReqVal :: ProgInfo [(QName,Int)] -> FuncDecl -> [(QName,AFType)] -> AFType analyseReqVal consinfo (Func (m,f) arity _ _ rule) calledfuncs | m==prelude = maybe (anaresult rule) id (lookup f preludeFuncs) | otherwise = --trace ("Analyze "++f++"\n"++showCalledFuncs calledfuncs++ -- "\nRESULT: "++showAFType _ (anaresult rule)) $ anaresult rule where anaresult (External _) = AFType [(take arity (repeat Any),AnyC)] anaresult (Rule args rhs) = analyseReqValRule consinfo calledfuncs args rhs -- add special results for prelude functions here: preludeFuncs = [("failed",AFType [([],empty)]) ,("==",AFType [([AnyC,AnyC],AnyC)]) ,("=:=",AFType [([AnyC,AnyC],AnyC)]) ,("$",AFType [([AnyC,Any],AnyC)]) ,("$!",AFType [([AnyC,AnyC],AnyC)]) ,("$!!",AFType [([AnyC,AnyC],AnyC)]) ,("$#",AFType [([AnyC,AnyC],AnyC)]) ,("$##",AFType [([AnyC,AnyC],AnyC)]) ,("compare",AFType [([AnyC,AnyC],AnyC)]) ] analyseReqValRule :: ProgInfo [(QName,Int)] -> [(QName,AFType)] -> [Int] -> Expr -> AFType analyseReqValRule consinfo calledfuncs args rhs = let initenv = extendEnv [] args envtypes = reqValExp initenv rhs AnyC rtypes = map snd envtypes in -- If some result is `AnyC` and another result is a constructor, then -- analyze again for all constructors as required results -- in order to get more precise information. if any (==AnyC) rtypes && any isConsValue rtypes then let somecons = maybe (error "Internal error") (\ (Cons (c:_)) -> c) (find isConsValue rtypes) othercons = maybe [] (map fst) (lookupProgInfo somecons consinfo) consenvtypes = foldr lubEnvTypes [] (map (\rt -> reqValExp initenv rhs rt) (map (\c -> Cons [c]) (somecons:othercons))) in AFType (map (\ (env,rtype) -> (map snd env, rtype)) (lubAnyEnvTypes (if length othercons >= maxReqValues then envtypes else consenvtypes))) else AFType (map (\ (env,rtype) -> (map snd env, rtype)) (lubAnyEnvTypes envtypes)) where reqValExp env exp reqtype = case exp of Var v -> [(updateVarInEnv env v reqtype, reqtype)] Lit _ -> [(env, AnyC)] -- too many literal constants... Comb ConsCall c _ -> [(env, Cons [c])] -- analysis of arguments superfluous Comb FuncCall qf funargs -> if qf==(prelude,"?") && length funargs == 2 then -- use intended definition of Prelude.? for more precise analysis: reqValExp env (Or (head funargs) (funargs!!1)) reqtype else maybe [(env, AnyC)] (\ftype -> case ftype of EmptyFunc -> [(env, empty)] -- no information available AFType ftypes -> let matchingtypes = filter (compatibleType reqtype . snd) ftypes -- for all matching types analyze arguments -- where a constructor value is required: matchingenvs = map (\ (ts,rt) -> let argenvs = concatMap (envForConsArg env) (zip ts funargs) in (foldr joinEnv env argenvs, rt)) matchingtypes in if null matchingtypes then [(env, empty)] else matchingenvs ) (lookup qf calledfuncs) Comb _ _ _ -> [(env, AnyC)] -- no reasonable info for partial applications Or e1 e2 -> lubEnvTypes (reqValExp env e1 reqtype) (reqValExp env e2 reqtype) Case _ e branches -> let -- filter non-failing branches: nfbranches = filter (\ (Branch _ be) -> be /= Comb FuncCall (prelude,"failed") []) branches reqenvs = filter (not . null) (map (envForBranch env reqtype e) nfbranches) in if null reqenvs then [(env, empty)] else foldr1 lubEnvTypes reqenvs Free vars e -> map (dropEnv (length vars)) (reqValExp (extendEnv env vars) e reqtype) Let bindings e -> -- bindings are not analyzed since we don't know whether they are used: map (dropEnv (length bindings)) (reqValExp (extendEnv env (map fst bindings)) e reqtype) Typed e _ -> reqValExp env e reqtype -- compute an expression environment for a function argument if this -- argument is required to be a constructor: envForConsArg env (reqtype,exp) = case reqtype of AnyC -> [foldr1 lubEnv (map fst (reqValExp env exp AnyC))] Cons qc -> [foldr1 lubEnv (map fst (reqValExp env exp (Cons qc)))] _ -> [] -- compute an expression environment and required type for an applied branch envForBranch env reqtype exp (Branch pat bexp) = filter (\ (_,rt) -> compatibleType rt reqtype) branchtypes where branchtypes = case pat of LPattern _ -> reqValExp env bexp reqtype Pattern qc pvars -> let caseenvs = map fst (reqValExp env exp (Cons [qc])) branchenvs = foldr lubEnvTypes [] (map (\caseenv -> reqValExp (extendEnv caseenv pvars) bexp reqtype) caseenvs) in map (dropEnv (length pvars)) branchenvs --- "lub" two environment lists. All environment lists are ordered --- by the result type. lubEnvTypes :: [(AEnv,AType)] -> [(AEnv,AType)] -> [(AEnv,AType)] lubEnvTypes [] ets2 = ets2 lubEnvTypes ets1@(_:_) [] = ets1 lubEnvTypes ((env1,t1):ets1) ((env2,t2):ets2) | t1==empty = lubEnvTypes ets1 ((env2,t2):ets2) -- ignore "empty" infos | t2==empty = lubEnvTypes ((env1,t1):ets1) ets2 | t1==t2 = (lubEnv env1 env2, t1) : lubEnvTypes ets1 ets2 | t1 < t2 = (env1,t1) : lubEnvTypes ets1 ((env2,t2):ets2) | otherwise = (env2,t2) : lubEnvTypes ((env1,t1):ets1) ets2 --- "lub" the environments of the more specific types to the AnyC type --- (if present). lubAnyEnvTypes :: [(AEnv,AType)] -> [(AEnv,AType)] lubAnyEnvTypes envtypes = if null envtypes || snd (head envtypes) /= AnyC then envtypes else foldr1 lubEnvType envtypes : tail envtypes lubEnvType :: (AEnv,AType) -> (AEnv,AType) -> (AEnv,AType) lubEnvType (env1,t1) (env2,t2) = (lubEnv env1 env2, lubAType t1 t2) lubEnv :: AEnv -> AEnv -> AEnv lubEnv [] _ = [] lubEnv (_:_) [] = [] lubEnv ((i1,v1):env1) env2@(_:_) = maybe (lubEnv env1 env2) (\v2 -> (i1, lubAType v1 v2) : lubEnv env1 env2) (lookup i1 env2) joinEnv :: AEnv -> AEnv -> AEnv joinEnv [] _ = [] joinEnv (_:_) [] = [] joinEnv ((i1,v1):env1) env2@(_:_) = maybe (joinEnv env1 env2) (\v2 -> (i1, joinAType v1 v2) : joinEnv env1 env2) (lookup i1 env2) -- Name of the standard prelude: prelude :: String prelude = "Prelude" ------------------------------------------------------------------------------ -- Auxiliaries: -- Union on sorted lists: union :: Ord a => [a] -> [a] -> [a] union [] ys = ys union xs@(_:_) [] = xs union (x:xs) (y:ys) | x==y = x : union xs ys | x [a] -> [a] -> [a] intersect [] _ = [] intersect (_:_) [] = [] intersect (x:xs) (y:ys) | x==y = x : intersect xs ys | x ResiduationInfo -> ResiduationInfo lubNRI MayResiduate _ = MayResiduate lubNRI NoResInfo nri = nri lubNRI (NoResiduateIf _ ) MayResiduate = MayResiduate lubNRI (NoResiduateIf xs) NoResInfo = NoResiduateIf xs lubNRI (NoResiduateIf xs) (NoResiduateIf ys) = NoResiduateIf (unionS xs ys) -- union on sorted lists: unionS :: Ord a => [a] -> [a] -> [a] unionS [] ys = ys unionS (x:xs) [] = x:xs unionS (x:xs) (y:ys) | x==y = x : unionS xs ys | xy = y : unionS (x:xs) ys -- Show non-residuation information as a string. showResInfo :: AOutFormat -> ResiduationInfo -> String showResInfo AText MayResiduate = "may residuate or has non-ground result" showResInfo ANote MayResiduate = "residuate" showResInfo AText (NoResiduateIf xs) = "does not residuate" ++ case xs of [] -> "" [x] -> " if argument " ++ show x ++ " is ground" _ -> " if arguments " ++ intercalate "," (map show xs) ++ " are ground" showResInfo ANote (NoResiduateIf xs) = "non-residuating" ++ if null xs then "" else " if " ++ intercalate "," (map show xs) showResInfo AText NoResInfo = "unknown residuation behavior" showResInfo ANote NoResInfo = "???" --- Non-residuation analysis. residuationAnalysis :: Analysis ResiduationInfo residuationAnalysis = dependencyFuncAnalysis "Residuation" NoResInfo nrFunc -- We define the demanded arguments of some primitive prelude operations. -- Otherwise, we analyse the right-hand sides of the rule. nrFunc :: FuncDecl -> [(QName,ResiduationInfo)] -> ResiduationInfo nrFunc (Func fn ar _ _ rule) calledFuncs = nrFuncRule fn ar calledFuncs rule nrFuncRule :: QName -> Int -> [(QName,ResiduationInfo)] -> Rule -> ResiduationInfo -- We assume that all external operations do not residuate if all -- arguments are non-residuating and ground. -- This is true for all known standard external operations. -- If this does not hold for some unusual operation, -- it must be specified here. nrFuncRule _ farity _ (External _) = NoResiduateIf [1 .. farity] nrFuncRule _ _ calledFuncs (Rule args rhs) = nrExp (map (\i -> (i, NoResiduateIf [i])) args) rhs where -- Analyze residuation behavior of an expression. -- The first argument maps variables to their non-residuating conditions -- if these variables are used in an expression. nrExp _ (Lit _) = NoResiduateIf [] nrExp amap (Var i) = maybe MayResiduate id (lookup i amap) nrExp amap (Comb ct g es) = case ct of FuncCall -> maybe NoResInfo checkNonResArgs (lookup g calledFuncs) FuncPartCall _ -> maybe NoResInfo checkNonResPartArgs (lookup g calledFuncs) _ -> if null es then NoResiduateIf [] else foldr1 lubNRI (map (nrExp amap) es) where checkNonResArgs NoResInfo = NoResInfo checkNonResArgs MayResiduate = MayResiduate checkNonResArgs (NoResiduateIf xs) = if null xs then NoResiduateIf [] else foldr1 lubNRI (map (\i -> nrExp amap (es!!(i-1))) xs) checkNonResPartArgs NoResInfo = NoResInfo checkNonResPartArgs MayResiduate = MayResiduate checkNonResPartArgs (NoResiduateIf xs) = let pxs = filter (<= length es) xs in if null pxs then NoResiduateIf [] else foldr1 lubNRI (map (\i -> nrExp amap (es!!(i-1))) pxs) nrExp amap (Case _ e bs) = foldr lubNRI nrcexp (map nrBranch bs) where nrcexp = nrExp amap e -- non-res. condition of discriminating expression nrBranch (Branch (LPattern _) be) = nrExp amap be nrBranch (Branch (Pattern _ xs) be) = nrExp (map (\x -> (x,nrcexp)) xs ++ amap) be nrExp amap (Free _ e) = nrExp amap e -- could be improved by sorting bindings by their variable dependencies -- (which seems already done by the front-end) nrExp amap (Let bindings e) = -- initialize all bound variables with `NoResInfo` which is meaningful -- for recursive bindings: let initamap = map (\ (v,_) -> (v,NoResInfo)) bindings ++ amap in nrExp (addBindings initamap bindings) e where addBindings amp [] = amp addBindings amp ((v,be):bs) = addBindings ((v, nrExp amp be) : amp) bs nrExp amap (Or e1 e2) = lubNRI (nrExp amap e1) (nrExp amap e2) nrExp amap (Typed e _) = nrExp amap e prelude :: String prelude = "Prelude" ------------------------------------------------------------------------------ curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/RightLinearity.curry000066400000000000000000000066521377556325500316630ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Right-linearity analysis: --- check whether functions are defined by right-linear rules. --- --- @author Michael Hanus --- @version April 2013 ------------------------------------------------------------------------------ module Analysis.RightLinearity (rlinAnalysis,hasRightLinearRules,linearExpr,showRightLinear) where import Analysis.Types import FlatCurry.Types import Data.Maybe import Data.List ------------------------------------------------------------------------------ --- The right-linearity analysis is a global function dependency analysis. --- It assigns to a function a flag which is True if this function --- is right-linear, i.e., defined by right-linear rules and depend only on --- functions defined by right-linear rules. rlinAnalysis :: Analysis Bool rlinAnalysis = dependencyFuncAnalysis "RightLinear" True rlFunc --- An operation is right-linear if it is defined by right-linear rules --- and depends only on right-linear operations. rlFunc :: FuncDecl -> [(QName,Bool)] -> Bool rlFunc func calledFuncs = hasRightLinearRules func && all snd calledFuncs -- Show right-linearity information as a string. showRightLinear :: AOutFormat -> Bool -> String showRightLinear _ True = "right-linear" showRightLinear AText False = "not defined by right-linear rules" showRightLinear ANote False = "" ------------------------------------------------------------------------------ -- The right-linearity analysis can also be applied to individual functions. -- It returns True for a function if it is defined by right-linear rules. hasRightLinearRules :: FuncDecl -> Bool hasRightLinearRules (Func _ _ _ _ rule) = isRightLinearRule rule isRightLinearRule :: Rule -> Bool isRightLinearRule (Rule _ e) = linearExpr e isRightLinearRule (External _) = True -------------------------------------------------------------------------- -- Check an expression for linearity: linearExpr :: Expr -> Bool linearExpr e = maybe False (const True) (linearVariables e) -- Return list of variables in an expression, if it is linear, -- otherwise: Nothing linearVariables :: Expr -> Maybe [Int] linearVariables (Var i) = Just [i] linearVariables (Lit _) = Just [] linearVariables (Comb _ f es) | f==("Prelude","?") && length es == 2 -- treat "?" as Or: = linearVariables (Or (head es) (head (tail es))) | otherwise = mapM linearVariables es >>= \esvars -> let vars = concat esvars in if nub vars == vars then Just vars else Nothing linearVariables (Free vs e) = linearVariables e >>= \evars -> Just (evars \\ vs) linearVariables (Let bs e) = mapM linearVariables (map snd bs) >>= \bsvars -> linearVariables e >>= \evars -> let vars = concat (evars : bsvars) in if nub vars == vars then Just (vars \\ (map fst bs)) else Nothing linearVariables (Or e1 e2) = linearVariables e1 >>= \e1vars -> linearVariables e2 >>= \e2vars -> Just (union e1vars e2vars) linearVariables (Case _ e bs) = linearVariables e >>= \evars -> mapM linearVariables (map (\ (Branch _ be) -> be) bs) >>= \bsvars -> let vars = foldr union [] (map (\ (branch,bsv) -> bsv \\ patternVars branch) (zip bs bsvars)) ++ evars in if nub vars == vars then Just vars else Nothing where patternVars (Branch (Pattern _ vs) _) = vs patternVars (Branch (LPattern _) _) = [] linearVariables (Typed e _) = linearVariables e curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/RootReplaced.curry000066400000000000000000000107761377556325500313120ustar00rootroot00000000000000------------------------------------------------------------------------------ --- RootReplaced analysis: --- This analysis returns for each function f all functions to which this can --- be replaced at the root. For instance, if there are the definitions: --- --- f x = g x --- g x = h x --- h x = k x : [] --- --- then the root replacements of f are [g,h]. --- --- This analysis could be useful to detect simple loops, e.g., if --- a function is in its root replacement. This is the purpose --- of the analysis `RootCyclic` which assigns `True` to some --- operation if this operation might cause a cyclic root replacement. --- --- @author Michael Hanus --- @version January 2017 ------------------------------------------------------------------------------ module Analysis.RootReplaced ( rootReplAnalysis, showRootRepl , rootCyclicAnalysis, showRootCyclic ) where import Analysis.Types import Analysis.ProgInfo import FlatCurry.Types import Data.List ------------------------------------------------------------------------------ --- Data type to represent root replacement information. --- Basically, it is the set (represented as a sorted list) of --- all function names to which a function can be replaced (directly --- or by several steps) at the root --- together with a list of arguments (which are numbered from 0) --- which might be projected into the result. --- The latter is necessary to compute the root replacement --- information for definitions like `look = id loop`. type RootReplaced = ([QName],[Int]) -- Show root-replacement information as a string. showRootRepl :: AOutFormat -> RootReplaced -> String showRootRepl AText ([],_) = "no root replacements" showRootRepl ANote ([],_) = "" showRootRepl AText (xs@(_:_),_) = "root replacements: " ++ intercalate "," (map (\ (mn,fn) -> mn++"."++fn) xs) showRootRepl ANote (xs@(_:_),_) = "[" ++ intercalate "," (map snd xs) ++ "]" --- Root replacement analysis. rootReplAnalysis :: Analysis RootReplaced rootReplAnalysis = dependencyFuncAnalysis "RootReplaced" ([],[]) rrFunc rrFunc :: FuncDecl -> [(QName,RootReplaced)] -> RootReplaced rrFunc (Func _ _ _ _ rule) calledFuncs = rrFuncRule calledFuncs rule rrFuncRule :: [(QName,RootReplaced)] -> Rule -> RootReplaced rrFuncRule _ (External _) = ([],[]) -- nothing known about external functions rrFuncRule calledFuncs (Rule args rhs) = rrOfExp rhs where rrOfExp exp = case exp of Var v -> maybe ([],[]) (\i -> ([],[i])) (elemIndex v args) Lit _ -> ([],[]) Comb ct g gargs -> if ct == FuncCall then maybe (error $ "Abstract value of " ++ show g ++ " not found!") (\ (grrs,gps) -> foldr lub (if g `elem` grrs then grrs else insertBy (<=) g grrs, []) (map (\pi -> rrOfExp (gargs!!pi)) gps)) (lookup g calledFuncs) else ([],[]) Typed e _ -> rrOfExp e Free _ e -> rrOfExp e Let _ e -> rrOfExp e Or e1 e2 -> lub (rrOfExp e1) (rrOfExp e2) Case _ e bs -> foldr lub (rrOfExp e) (map (\ (Branch _ be) -> rrOfExp be) bs) lub (rr1,p1) (rr2,p2) = (sort (union rr1 rr2), sort (union p1 p2)) ------------------------------------------------------------------------------ -- Show root-cyclic information as a string. showRootCyclic :: AOutFormat -> Bool -> String showRootCyclic AText False = "no cycles at the root" showRootCyclic ANote False = "" showRootCyclic AText True = "possible cyclic root replacement" showRootCyclic ANote True = "root-cyclic" --- Root cyclic analysis. rootCyclicAnalysis :: Analysis Bool rootCyclicAnalysis = combinedSimpleFuncAnalysis "RootCyclic" rootReplAnalysis rcFunc rcFunc :: ProgInfo RootReplaced -> FuncDecl -> Bool -- we assume that external functions are not root cyclic: rcFunc _ (Func _ _ _ _ (External _)) = False -- otherwise we check whether the operation is in its set of root replacements: rcFunc rrinfo (Func qf _ _ _ (Rule _ _)) = maybe True -- no information, but this case should not occur (\rrfuncs -> qf `elem` (fst rrfuncs) -- direct cycle -- or cycle in some root-replacement: || any (\rrf -> maybe True (\fs -> rrf `elem` (fst fs)) (lookupProgInfo rrf rrinfo)) (fst rrfuncs)) (lookupProgInfo qf rrinfo) ------------------------------------------------------------------------------ curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/SensibleTypes.curry000066400000000000000000000063241377556325500315120ustar00rootroot00000000000000------------------------------------------------------------------------ --- A type is sensible if there exists at least one value of this type. --- This module contains an analysis which associates to each type --- constructor the following information: --- * sensible, i.e., there is always some value of this type --- * parametric sensible, i.e., it is sensible of all type arguments --- are instantiated with sensible types --- * not sensible, i.e., maybe not sensible ------------------------------------------------------------------------ module Analysis.SensibleTypes ( Sensible(..), showSensible, sensibleType ) where import Analysis.Types import Analysis.ProgInfo import FlatCurry.Types import FlatCurry.Goodies import Data.Maybe --- Datatype to represent sensible type information. data Sensible = NotSensible | PSensible | Sensible deriving (Show, Read, Eq) -- Show higher-order information as a string. showSensible :: AOutFormat -> Sensible -> String showSensible _ Sensible = "sensible" showSensible _ PSensible = "parametric sensible" showSensible _ NotSensible = "not sensible" lubSens :: Sensible -> Sensible -> Sensible lubSens Sensible _ = Sensible lubSens PSensible Sensible = Sensible lubSens PSensible PSensible = PSensible lubSens PSensible NotSensible = PSensible lubSens NotSensible x = x ------------------------------------------------------------------------ -- Analysis of sensible types sensibleType :: Analysis Sensible sensibleType = dependencyTypeAnalysis "SensibleType" NotSensible sensOfType -- predefined sensible data types predefinedSensibles :: [QName] predefinedSensibles = [pre "Int", pre "Float", pre "Char", pre "IO"] where pre tc = ("Prelude",tc) sensOfType :: TypeDecl -> [(QName,Sensible)] -> Sensible sensOfType (TypeSyn _ _ _ typeExpr) usedtypes = sensOfTypeExpr usedtypes typeExpr sensOfType (TypeNew _ _ _ (NewCons _ _ typeExpr)) usedtypes = sensOfTypeExpr usedtypes typeExpr sensOfType (Type tc _ _ conDecls) usedtypes | tc `elem` predefinedSensibles = Sensible | otherwise = foldr lubSens NotSensible (map sensOfConsDecl conDecls) where sensOfConsDecl (Cons _ _ _ typeExprs) | all (== Sensible) senstargs = Sensible | all (/= NotSensible) senstargs = PSensible | otherwise = NotSensible where senstargs = map (sensOfTypeExpr usedtypes) typeExprs -- Compute the sensibility of a type expression which depends on the -- information about type cosntructors. sensOfTypeExpr :: [(QName,Sensible)] -> TypeExpr -> Sensible sensOfTypeExpr _ (TVar _) = PSensible sensOfTypeExpr _ (FuncType _ _) = NotSensible -- we do not know which functions -- of some type exists... sensOfTypeExpr usedtypes (TCons tc typeExprs) | senstc == Sensible || (senstc == PSensible && all (==Sensible) senstargs) = Sensible | senstc == PSensible && all (/=NotSensible) senstargs = PSensible | otherwise = NotSensible where senstc = maybe NotSensible id (lookup tc usedtypes) senstargs = map (sensOfTypeExpr usedtypes) typeExprs sensOfTypeExpr usedtypes (ForallType _ texp) = sensOfTypeExpr usedtypes texp ----------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/SolutionCompleteness.curry000066400000000000000000000045351377556325500331210ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Analysis for solution completeness: --- check whether functions are solution complete, i.e., calls only --- non-rigid functions --- --- @author Michael Hanus --- @version April 2013 ------------------------------------------------------------------------------ module Analysis.SolutionCompleteness(solcompAnalysis,showSolComplete) where import Analysis.Types import FlatCurry.Types import Data.List ------------------------------------------------------------------------------ --- The completeness analysis is a global function dependency analysis. --- It assigns to a function a flag which is True if this function --- is operationally complete, i.e., does not call (explicitly or implicitly) --- a rigid function. solcompAnalysis :: Analysis Bool solcompAnalysis = dependencyFuncAnalysis "SolComplete" True scFunc --- An operation is solution complete if it is defined with flexible --- rules and depends only on solution complete operations. scFunc :: FuncDecl -> [(QName,Bool)] -> Bool scFunc func calledFuncs = isFlexDefined func && all snd calledFuncs -- (isFlexDefined fundecl): -- Is a function defined by a flexible rule? isFlexDefined :: FuncDecl -> Bool isFlexDefined (Func _ _ _ _ (Rule _ e)) = isFlexExpr e isFlexDefined (Func f _ _ _ (External _)) = f `elem` map pre ["=:=","success","&","&>","return"] -- Checks whether an expression is flexible, i.e., can only suspend -- because of calls to other possibly rigid functions. isFlexExpr :: Expr -> Bool isFlexExpr (Var _) = True isFlexExpr (Lit _) = True isFlexExpr (Comb _ f args) = f/=(pre "apply") -- apply suspends if arg 1 is unbound && f/=(pre "commit") && all isFlexExpr args isFlexExpr (Free _ e) = isFlexExpr e isFlexExpr (Let bs e) = all isFlexExpr (map snd bs) && isFlexExpr e isFlexExpr (Or e1 e2) = isFlexExpr e1 && isFlexExpr e2 isFlexExpr (Case ctype e bs) = ctype==Flex && all isFlexExpr (e : map (\(Branch _ be)->be) bs) isFlexExpr (Typed e _) = isFlexExpr e -- Show solution completeness information as a string. showSolComplete :: AOutFormat -> Bool -> String showSolComplete _ True = "solution complete" showSolComplete _ False = "maybe suspend" pre :: String -> QName pre n = ("Prelude",n) -- end of SolutionCompleteness curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/Termination.curry000066400000000000000000000204651377556325500312140ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Termination analysis: --- checks whether an operation is terminating, i.e., --- whether all evaluations on ground argument terms are finite. --- The method used here checks whether the arguments in all recursive --- calls of an operation are smaller than the arguments passed to --- the operation. --- --- @author Michael Hanus --- @version February 2017 ------------------------------------------------------------------------------ module Analysis.Termination ( terminationAnalysis, showTermination , productivityAnalysis, showProductivity, Productivity(..) ) where import Analysis.Types import Analysis.ProgInfo import Analysis.RootReplaced (rootCyclicAnalysis) import Data.Char (isDigit) import Data.List import FlatCurry.Types import FlatCurry.Goodies import Data.SCC (scc) ------------------------------------------------------------------------------ -- The termination analysis is a global function dependency analysis. -- It assigns to a FlatCurry function definition a flag which is True -- if this operation is terminating, i.e., whether all evaluations terminationAnalysis :: Analysis Bool terminationAnalysis = dependencyFuncAnalysis "Terminating" False isTerminating -- Show termination information as a string. showTermination :: AOutFormat -> Bool -> String showTermination AText True = "terminating" showTermination ANote True = "" showTermination AText False = "possibly non-terminating" showTermination ANote False = "maybe not term." -- An operation is functionally defined if its definition is not -- non-deterministic (no overlapping rules, no extra variables) and -- it depends only on functionally defined operations. isTerminating :: FuncDecl -> [(QName,Bool)] -> Bool isTerminating (Func qfunc _ _ _ rule) calledFuncs = hasTermRule rule where hasTermRule (Rule args e) = hasTermExp (map (\a -> (a,[])) args) e -- we assume that all externally defined operations are terminating: hasTermRule (External _) = True hasTermExp _ (Var _) = True hasTermExp _ (Lit _) = True hasTermExp _ (Free _ _) = False -- could be improved if the domain is finite hasTermExp args (Let bs e) = -- compute strongly connected components of local let declarationss -- in order to check for recursive lets let sccs = scc ((:[]) . fst) (allVars . snd) bs in if any (\scc -> any (`elem` concatMap allVars (map snd scc)) (map fst scc)) sccs then False -- non-terminating due to recursive let else all (hasTermExp args) (e : map snd bs) hasTermExp args (Or e1 e2) = hasTermExp args e1 && hasTermExp args e2 hasTermExp args (Case _ e bs) = hasTermExp args e && all (\ (Branch pt be) -> hasTermExp (addSmallerArgs args e pt) be) bs hasTermExp args (Typed e _) = hasTermExp args e hasTermExp args (Comb ct qf es) = case ct of ConsCall -> all (hasTermExp args) es ConsPartCall _ -> all (hasTermExp args) es _ -> (if qf == qfunc -- is this a recursive call? then any isSmallerArg (zip args es) else maybe False id (lookup qf calledFuncs)) && all (hasTermExp args) es isSmallerArg ((_,sargs),exp) = case exp of Var v -> v `elem` sargs _ -> False -- compute smaller args w.r.t. a given discriminating expression and -- branch pattern addSmallerArgs :: [(Int, [Int])] -> Expr -> Pattern -> [(Int, [Int])] addSmallerArgs args de pat = case de of Var v -> maybe args (\argpos -> let (av,vs) = args!!argpos in replace (av, varsOf pat ++ vs) argpos args) (findIndex (isInArg v) args) _ -> args -- other expression, no definite smaller expressions where varsOf (LPattern _) = [] varsOf (Pattern _ pargs) = pargs isInArg v (argv,svs) = v==argv || v `elem` svs ------------------------------------------------------------------------------ -- The productivity analysis is a global function dependency analysis -- which depends on the termination analysis. -- An operation is considered as being productive if it cannot -- perform an infinite number of steps without producing -- outermost constructors. -- It assigns to a FlatCurry function definition an abstract value -- indicating whether the function is looping or productive. --- Data type to represent productivity status of an operation. data Productivity = NoInfo | Terminating -- definitely terminating operation | DCalls [QName] -- possible direct (top-level) calls to operations that may -- not terminate, which corresponds to being productive | Looping -- possibly looping deriving (Eq, Ord, Show, Read) productivityAnalysis :: Analysis Productivity productivityAnalysis = combinedDependencyFuncAnalysis "Productive" terminationAnalysis NoInfo isProductive -- Show productivity information as a string. showProductivity :: AOutFormat -> Productivity -> String showProductivity _ NoInfo = "no info" showProductivity _ Terminating = "terminating" showProductivity _ (DCalls qfs) = "productive / calls: " ++ "[" ++ intercalate ", " (map snd qfs) ++ "]" showProductivity _ Looping = "possibly looping" lubProd :: Productivity -> Productivity -> Productivity lubProd Looping _ = Looping lubProd (DCalls _ ) Looping = Looping lubProd (DCalls xs) (DCalls ys) = DCalls (sort (union xs ys)) lubProd (DCalls xs) Terminating = DCalls xs lubProd (DCalls xs) NoInfo = DCalls xs lubProd Terminating p = if p==NoInfo then Terminating else p lubProd NoInfo p = p -- An operation is productive if its recursive calls are below -- a constructor (except for calls to terminating operations so that -- this property is also checked). isProductive :: ProgInfo Bool -> FuncDecl -> [(QName,Productivity)] -> Productivity isProductive terminfo (Func qf _ _ _ rule) calledFuncs = hasProdRule rule where -- we assume that all externally defined operations are terminating: hasProdRule (External _) = Terminating hasProdRule (Rule _ e) = case hasProdExp False e of DCalls fs -> if qf `elem` fs then Looping else DCalls fs prodinfo -> prodinfo -- first argument: True if we are below a constructor hasProdExp _ (Var _) = Terminating hasProdExp _ (Lit _) = Terminating hasProdExp bc (Free _ e) = -- could be improved for finite domains: lubProd (DCalls []) (hasProdExp bc e) hasProdExp bc (Let bs e) = -- compute strongly connected components of local let declarationss -- in order to check for recursive lets let sccs = scc ((:[]) . fst) (allVars . snd) bs in if any (\scc -> any (`elem` concatMap allVars (map snd scc)) (map fst scc)) sccs then Looping -- improve: check for variable occs under constructors else foldr lubProd (hasProdExp bc e) (map (\ (_,be) -> hasProdExp bc be) bs) hasProdExp bc (Or e1 e2) = lubProd (hasProdExp bc e1) (hasProdExp bc e2) hasProdExp bc (Case _ e bs) = foldr lubProd (hasProdExp bc e) (map (\ (Branch _ be) -> hasProdExp bc be) bs) hasProdExp bc (Typed e _) = hasProdExp bc e hasProdExp bc (Comb ct qg es) = case ct of ConsCall -> cprodargs ConsPartCall _ -> cprodargs FuncCall -> if qg == ("Prelude","?") then fprodargs -- equivalent to Or else funCallInfo FuncPartCall _ -> funCallInfo where cprodargs = foldr lubProd NoInfo (map (hasProdExp True) es) fprodargs = foldr lubProd NoInfo (map (hasProdExp bc ) es) funCallInfo = let prodinfo = if fprodargs <= Terminating then if maybe False id (lookupProgInfo qg terminfo) then Terminating else lubProd (DCalls [qg]) (maybe Looping id (lookup qg calledFuncs)) else Looping -- worst case assumption, could be improved... in if not bc then prodinfo else case prodinfo of DCalls _ -> DCalls [] _ -> prodinfo ------------------------------------------------------------------------------ curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/TotallyDefined.curry000066400000000000000000000135141377556325500316270ustar00rootroot00000000000000----------------------------------------------------------------------------- --- Pattern completeness and totally definedness analysis for Curry programs --- --- This analysis checks for each function in a Curry program whether --- this function is completely defined, i.e., reducible on all ground --- constructor terms --- --- @author Johannes Koj, Michael Hanus --- @version April 2018 ----------------------------------------------------------------------------- module Analysis.TotallyDefined ( siblingCons, showSibling, Completeness(..), showComplete, showTotally , patCompAnalysis, totalAnalysis ) where import Analysis.ProgInfo import Analysis.Types import FlatCurry.Types import FlatCurry.Goodies import Data.List (delete) ----------------------------------------------------------------------- --- An analysis to compute the sibling constructors (belonging to the --- same data type) for a data constructor. --- Shows the result of the sibling constructors analysis, i.e., --- shows a list of constructor names together with their arities. showSibling :: AOutFormat -> [(QName,Int)] -> String showSibling _ = show siblingCons :: Analysis [(QName,Int)] siblingCons = simpleConstructorAnalysis "SiblingCons" consNamesArOfType where -- get all constructor names and arities of a datatype declaration consNamesArOfType cdecl (Type _ _ _ consDecls) = map (\cd -> (consName cd, consArity cd)) (filter (\cd -> consName cd /= consName cdecl) consDecls) consNamesArOfType _ (TypeSyn _ _ _ _) = [] consNamesArOfType _ (TypeNew _ _ _ _) = [] ------------------------------------------------------------------------------ -- The completeness analysis assigns to an operation a flag indicating -- whether this operation is completely defined on its input types, -- i.e., reducible for all ground data terms. -- The possible outcomes of the completeness analysis: data Completeness = Complete -- completely defined | InComplete -- incompletely defined | InCompleteOr -- incompletely defined in each branch of an "Or" deriving (Eq, Show, Read) --- A function is totally defined if it is pattern complete and depends --- only on totally defined functions. totalAnalysis :: Analysis Bool totalAnalysis = combinedDependencyFuncAnalysis "Total" patCompAnalysis True analyseTotally analyseTotally :: ProgInfo Completeness -> FuncDecl -> [(QName,Bool)] -> Bool analyseTotally pcinfo fdecl calledfuncs = (maybe False (\c->c==Complete) (lookupProgInfo (funcName fdecl) pcinfo)) && all snd calledfuncs -- Shows the result of the totally-defined analysis. showTotally :: AOutFormat -> Bool -> String showTotally AText True = "totally defined" showTotally ANote True = "" showTotally _ False = "partially defined" ------------------------------------------------------------------------------ --- Pattern completeness analysis patCompAnalysis :: Analysis Completeness patCompAnalysis = combinedSimpleFuncAnalysis "PatComplete" siblingCons analysePatComplete -- Shows the result of the completeness analysis. showComplete :: AOutFormat -> Completeness -> String showComplete AText Complete = "complete" showComplete ANote Complete = "" showComplete _ InComplete = "incomplete" showComplete _ InCompleteOr = "incomplete in each disjunction" analysePatComplete :: ProgInfo [(QName,Int)] -> FuncDecl -> Completeness analysePatComplete consinfo fdecl = anaFun fdecl where anaFun (Func _ _ _ _ (Rule _ e)) = isComplete consinfo e anaFun (Func _ _ _ _ (External _)) = Complete isComplete :: ProgInfo [(QName,Int)] -> Expr -> Completeness isComplete _ (Var _) = Complete isComplete _ (Lit _) = Complete isComplete consinfo (Comb _ f es) = if f==("Prelude","commit") && length es == 1 then isComplete consinfo (head es) else Complete isComplete _ (Free _ _) = Complete isComplete _ (Let _ _) = Complete isComplete consinfo (Or e1 e2) = combineOrResults (isComplete consinfo e1) (isComplete consinfo e2) -- if there is no branch, it is incomplete: isComplete _ (Case _ _ []) = InComplete -- for literal branches we assume that not all alternatives are provided: isComplete _ (Case _ _ (Branch (LPattern _) _ : _)) = InComplete isComplete consinfo (Case _ _ (Branch (Pattern cons _) bexp : ces)) = combineAndResults (checkAllCons (maybe [] (map fst) (lookupProgInfo cons consinfo)) ces) (isComplete consinfo bexp) where -- check for occurrences of all constructors in each case branch: checkAllCons [] _ = Complete checkAllCons (_:_) [] = InComplete checkAllCons (_:_) (Branch (LPattern _) _ : _) = InComplete -- should not occur checkAllCons (c:cs) (Branch (Pattern i _) e : ps) = combineAndResults (checkAllCons (delete i (c:cs)) ps) (isComplete consinfo e) isComplete consinfo (Typed e _) = isComplete consinfo e -- Combines the completeness results in different Or branches. combineOrResults :: Completeness -> Completeness -> Completeness combineOrResults Complete _ = Complete combineOrResults InComplete Complete = Complete combineOrResults InComplete InComplete = InCompleteOr combineOrResults InComplete InCompleteOr = InCompleteOr combineOrResults InCompleteOr Complete = Complete combineOrResults InCompleteOr InComplete = InCompleteOr combineOrResults InCompleteOr InCompleteOr = InCompleteOr -- Combines the completeness results in different case branches. combineAndResults :: Completeness -> Completeness -> Completeness combineAndResults InComplete _ = InComplete combineAndResults Complete Complete = Complete combineAndResults Complete InComplete = InComplete combineAndResults Complete InCompleteOr = InCompleteOr combineAndResults InCompleteOr Complete = InCompleteOr combineAndResults InCompleteOr InComplete = InComplete combineAndResults InCompleteOr InCompleteOr = InCompleteOr curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/TypeUsage.curry000066400000000000000000000043321377556325500306240ustar00rootroot00000000000000------------------------------------------------------------------------ --- Analysis of properties related to the usage and occurrences of types. --- --- @author Michael Hanus --- @version February 2017 ------------------------------------------------------------------------ module Analysis.TypeUsage(showTypeNames,typesInValuesAnalysis) where import Analysis.Types import FlatCurry.Types import Data.List (intercalate) ------------------------------------------------------------------------ -- This analysis associates to each type the types which might occur -- in values of this type. If a type occurs in its associated types, -- it is a recursive type. typesInValuesAnalysis :: Analysis [QName] typesInValuesAnalysis = dependencyTypeAnalysis "TypesInValues" [] typesInTypeDecl -- Show a list of type constructor names as a string. showTypeNames :: AOutFormat -> [QName] -> String showTypeNames _ tcs = intercalate ", " $ map (\ (mn,fn) -> mn ++ "." ++ fn) tcs typesInTypeDecl :: TypeDecl -> [(QName,[QName])] -> [QName] typesInTypeDecl (Type _ _ _ conDecls) usedtypes = foldr join [] $ map typesInConsDecl conDecls where typesInConsDecl (Cons _ _ _ typeExprs) = foldr join [] $ map (typesInTypeExpr usedtypes) typeExprs typesInTypeDecl (TypeSyn _ _ _ typeExpr) usedtypes = typesInTypeExpr usedtypes typeExpr typesInTypeDecl (TypeNew _ _ _ (NewCons _ _ typeExpr)) usedtypes = typesInTypeExpr usedtypes typeExpr -- Computes all type constructors occurring in a type expression. typesInTypeExpr :: [(QName,[QName])] -> TypeExpr -> [QName] typesInTypeExpr _ (TVar _) = [] typesInTypeExpr usedtypes (FuncType t1 t2) = join (typesInTypeExpr usedtypes t1) (typesInTypeExpr usedtypes t2) typesInTypeExpr usedtypes (TCons tc texps) = foldr join (join [tc] (maybe [] id (lookup tc usedtypes))) (map (typesInTypeExpr usedtypes) texps) typesInTypeExpr usedtypes (ForallType _ t) = typesInTypeExpr usedtypes t join :: [QName] -> [QName] -> [QName] join tcs1 tcs2 = foldr insert tcs2 tcs1 where insert x [] = [x] insert x (y:ys) | x == y = y : ys | x < y = x : y : ys | otherwise = y : insert x ys ----------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/Types.curry000066400000000000000000000335341377556325500300300ustar00rootroot00000000000000------------------------------------------------------------------------- --- This module contains the datatypes, constructors, and other --- operations to create and process analyses used in the --- generic analysis system. --- --- Each analysis has a name which is used to identify the analysis --- stored in files, when passing analysis information between workers etc. --- --- **Important:** Use the constructor operations to define new analyses --- (instead of the data constructors). --- --- @author Heiko Hoffmann, Michael Hanus --- @version June 2018 ------------------------------------------------------------------------- module Analysis.Types ( Analysis(..) , simpleFuncAnalysis, simpleTypeAnalysis, simpleConstructorAnalysis , dependencyFuncAnalysis, dependencyTypeAnalysis , combinedSimpleFuncAnalysis, combined2SimpleFuncAnalysis , combinedSimpleTypeAnalysis , combinedDependencyFuncAnalysis, combinedDependencyTypeAnalysis , simpleModuleAnalysis, dependencyModuleAnalysis , isSimpleAnalysis, isCombinedAnalysis, isFunctionAnalysis , analysisName, baseAnalysisNames, startValue , AOutFormat(..) ) where import FlatCurry.Types ( Prog, ConsDecl, FuncDecl, TypeDecl, QName ) import FlatCurry.Goodies ( progImports ) import Analysis.ProgInfo ( ProgInfo, combineProgInfo, lookupProgInfo ) import Analysis.Files ( getImports, loadCompleteAnalysis, getInterfaceInfos ) --- Datatype representing a program analysis to be used in the --- generic analysis system. The datatype is abstract so that --- one has to use one of the constructor operations to create --- an analysis. data Analysis a = SimpleFuncAnalysis String (FuncDecl -> a) | SimpleTypeAnalysis String (TypeDecl -> a) | SimpleConstructorAnalysis String (ConsDecl -> TypeDecl -> a) | DependencyFuncAnalysis String a (FuncDecl -> [(QName,a)] -> a) | DependencyTypeAnalysis String a (TypeDecl -> [(QName,a)] -> a) | CombinedSimpleFuncAnalysis [String] String Bool (String -> IO (FuncDecl -> a)) | CombinedSimpleTypeAnalysis [String] String Bool (String -> IO (TypeDecl -> a)) | CombinedDependencyFuncAnalysis [String] String Bool a (String -> IO (FuncDecl -> [(QName,a)] -> a)) | CombinedDependencyTypeAnalysis [String] String Bool a (String -> IO (TypeDecl -> [(QName,a)] -> a)) | SimpleModuleAnalysis String (Prog -> a) | DependencyModuleAnalysis String (Prog -> [(String,a)] -> a) --- A simple analysis for functions takes an operation that computes --- some information from a given function declaration. simpleFuncAnalysis :: String -> (FuncDecl -> a) -> Analysis a simpleFuncAnalysis anaName anaFunc = SimpleFuncAnalysis anaName anaFunc --- A simple analysis for types takes an operation that computes --- some information from a given type declaration. simpleTypeAnalysis :: String -> (TypeDecl -> a) -> Analysis a simpleTypeAnalysis anaName anaFunc = SimpleTypeAnalysis anaName anaFunc --- A simple analysis for data constructors takes an operation that computes --- some information for a constructor declaration and its type declaration --- to which it belongs. simpleConstructorAnalysis :: String -> (ConsDecl -> TypeDecl -> a) -> Analysis a simpleConstructorAnalysis anaName anaFunc = SimpleConstructorAnalysis anaName anaFunc --- Construct a function analysis with dependencies. --- The analysis has a name, a start value (representing "no initial --- information") and an operation to process a function declaration --- with analysis information --- for the operations directly called in this function declaration. --- The analysis will be performed by a fixpoint iteration --- starting with the given start value. dependencyFuncAnalysis :: String -> a -> (FuncDecl -> [(QName,a)] -> a) -> Analysis a dependencyFuncAnalysis anaName startval anaFunc = DependencyFuncAnalysis anaName startval anaFunc --- Construct a type analysis with dependencies. --- The analysis has a name, a start value (representing "no initial --- information") and an operation to process a type declaration --- with analysis information --- for the type constructors occurring in the type declaration. --- The analysis will be performed by a fixpoint iteration --- starting with the given start value. dependencyTypeAnalysis :: String -> a -> (TypeDecl -> [(QName,a)] -> a) -> Analysis a dependencyTypeAnalysis anaName startval anaType = DependencyTypeAnalysis anaName startval anaType --- A simple combined analysis for functions. --- The analysis is based on an operation that computes --- some information from a given function declaration --- and information provided by some base analysis. --- The base analysis is provided as the second argument. combinedSimpleFuncAnalysis :: Read b => String -> Analysis b -> (ProgInfo b -> FuncDecl -> a) -> Analysis a combinedSimpleFuncAnalysis ananame baseAnalysis anaFunc = CombinedSimpleFuncAnalysis [analysisName baseAnalysis] ananame True (runWithBaseAnalysis baseAnalysis anaFunc) --- A simple combined analysis for functions. --- The analysis is based on an operation that computes --- some information from a given function declaration --- and information provided by two base analyses. --- The base analyses are provided as the second and third argument. combined2SimpleFuncAnalysis :: (Read b, Read c) => String -> Analysis b -> Analysis c -> (ProgInfo b -> ProgInfo c -> FuncDecl -> a) -> Analysis a combined2SimpleFuncAnalysis ananame baseAnalysisA baseAnalysisB anaFunc = CombinedSimpleFuncAnalysis [analysisName baseAnalysisA, analysisName baseAnalysisB] ananame True (runWith2BaseAnalyses baseAnalysisA baseAnalysisB anaFunc) --- A simple combined analysis for types. --- The analysis is based on an operation that computes --- some information from a given type declaration --- and information provided by some base analysis. --- The base analysis is provided as the second argument. combinedSimpleTypeAnalysis :: Read b => String -> Analysis b -> (ProgInfo b -> TypeDecl -> a) -> Analysis a combinedSimpleTypeAnalysis ananame baseAnalysis anaFunc = CombinedSimpleTypeAnalysis [analysisName baseAnalysis] ananame True (runWithBaseAnalysis baseAnalysis anaFunc) --- A combined analysis for functions with dependencies. --- The analysis is based on an operation that computes --- from information provided by some base analysis --- for each function declaration and information about its --- directly called operation some information for the declared function. --- The analysis will be performed by a fixpoint iteration --- starting with the given start value (fourth argument). --- The base analysis is provided as the second argument. combinedDependencyFuncAnalysis :: Read b => String -> Analysis b -> a -> (ProgInfo b -> FuncDecl -> [(QName,a)] -> a) -> Analysis a combinedDependencyFuncAnalysis ananame baseAnalysis startval anaFunc = CombinedDependencyFuncAnalysis [analysisName baseAnalysis] ananame True startval (runWithBaseAnalysis baseAnalysis anaFunc) --- A combined analysis for types with dependencies. --- The analysis is based on an operation that computes --- from information provided by some base analysis --- for each type declaration and information about its --- directly used types some information for the declared type. --- The analysis will be performed by a fixpoint iteration --- starting with the given start value (fourth argument). --- The base analysis is provided as the second argument. combinedDependencyTypeAnalysis :: Read b => String -> Analysis b -> a -> (ProgInfo b -> TypeDecl -> [(QName,a)] -> a) -> Analysis a combinedDependencyTypeAnalysis ananame baseAnalysis startval anaType = CombinedDependencyTypeAnalysis [analysisName baseAnalysis] ananame True startval (runWithBaseAnalysis baseAnalysis anaType) --- Construct a simple analysis for entire modules. --- The analysis has a name and takes an operation that computes --- some information from a given module. simpleModuleAnalysis :: String -> (Prog -> a) -> Analysis a simpleModuleAnalysis anaName anaFunc = SimpleModuleAnalysis anaName anaFunc --- Construct a module analysis which uses analysis information on --- imported modules. --- The analysis has a name and an operation to analyze a module. --- The analysis operation could use already computed information --- of imported modules, represented as a list of module name/information pairs. --- Note that a fixpoint iteration is not necessary --- since module dependencies must be acyclic. dependencyModuleAnalysis :: String -> (Prog -> [(String,a)] -> a) -> Analysis a dependencyModuleAnalysis anaName anaFunc = DependencyModuleAnalysis anaName anaFunc ------------------------------------------------------------------------- --- Is the analysis a simple analysis? --- Otherwise, it is a dependency analysis which requires a fixpoint --- computation to compute the results. isSimpleAnalysis :: Analysis a -> Bool isSimpleAnalysis analysis = case analysis of SimpleFuncAnalysis _ _ -> True SimpleTypeAnalysis _ _ -> True SimpleConstructorAnalysis _ _ -> True CombinedSimpleFuncAnalysis _ _ _ _ -> True CombinedSimpleTypeAnalysis _ _ _ _ -> True _ -> False --- Is the analysis a combined analysis? isCombinedAnalysis :: Analysis a -> Bool isCombinedAnalysis analysis = case analysis of CombinedSimpleFuncAnalysis _ _ _ _ -> True CombinedSimpleTypeAnalysis _ _ _ _ -> True CombinedDependencyFuncAnalysis _ _ _ _ _ -> True CombinedDependencyTypeAnalysis _ _ _ _ _ -> True _ -> False --- Is the analysis a function analysis? --- Otherwise, it is a type or constructor analysis. isFunctionAnalysis :: Analysis a -> Bool isFunctionAnalysis analysis = case analysis of SimpleFuncAnalysis _ _ -> True DependencyFuncAnalysis _ _ _ -> True CombinedSimpleFuncAnalysis _ _ _ _ -> True CombinedDependencyFuncAnalysis _ _ _ _ _ -> True _ -> False --- Name of the analysis to be used in server communication and --- analysis files. analysisName :: Analysis a -> String analysisName (SimpleFuncAnalysis name _ ) = name analysisName (SimpleTypeAnalysis name _ ) = name analysisName (SimpleConstructorAnalysis name _ ) = name analysisName (DependencyFuncAnalysis name _ _) = name analysisName (DependencyTypeAnalysis name _ _) = name analysisName (CombinedSimpleFuncAnalysis _ nameB _ _) = nameB analysisName (CombinedSimpleTypeAnalysis _ nameB _ _) = nameB analysisName (CombinedDependencyFuncAnalysis _ nameB _ _ _) = nameB analysisName (CombinedDependencyTypeAnalysis _ nameB _ _ _) = nameB analysisName (SimpleModuleAnalysis name _) = name analysisName (DependencyModuleAnalysis name _) = name --- Names of the base analyses of a combined analysis. baseAnalysisNames :: Analysis a -> [String] baseAnalysisNames ana = case ana of CombinedSimpleFuncAnalysis bnames _ _ _ -> bnames CombinedSimpleTypeAnalysis bnames _ _ _ -> bnames CombinedDependencyFuncAnalysis bnames _ _ _ _ -> bnames CombinedDependencyTypeAnalysis bnames _ _ _ _ -> bnames _ -> [] --- Start value of a dependency analysis. startValue :: Analysis a -> a startValue ana = case ana of DependencyFuncAnalysis _ startval _ -> startval DependencyTypeAnalysis _ startval _ -> startval CombinedDependencyFuncAnalysis _ _ _ startval _ -> startval CombinedDependencyTypeAnalysis _ _ _ startval _ -> startval _ -> error "Internal error in Analysis.startValue" ------------------------------------------------------------------------- --- The desired kind of output of an analysis result. --- `AText` denotes a standard textual representation. --- `ANote` denotes a short note that is empty in case of irrelevant --- information. For instance, this is used in the CurryBrowser --- to get a quick overview of the analysis results of all operations --- in a module. data AOutFormat = AText | ANote deriving Eq ------------------------------------------------------------------------- --- Loads the results of the base analysis and put it as the first --- argument of the main analysis operation which is returned. runWithBaseAnalysis :: Read a => Analysis a -> (ProgInfo a -> (input -> b)) -> String -> IO (input -> b) runWithBaseAnalysis baseAnalysis analysisFunction moduleName = do importedModules <- getImports moduleName let baseananame = analysisName baseAnalysis impbaseinfos <- getInterfaceInfos baseananame importedModules mainbaseinfos <- loadCompleteAnalysis baseananame moduleName let baseinfos = combineProgInfo impbaseinfos mainbaseinfos return (analysisFunction baseinfos) --- Loads the results of the base analysis and put it as the first --- argument of the main analysis operation which is returned. runWith2BaseAnalyses :: (Read a, Read b) => Analysis a -> Analysis b -> (ProgInfo a -> ProgInfo b -> (input -> c)) -> String -> IO (input -> c) runWith2BaseAnalyses baseanaA baseanaB analysisFunction moduleName = do importedModules <- getImports moduleName let baseananameA = analysisName baseanaA baseananameB = analysisName baseanaB impbaseinfosA <- getInterfaceInfos baseananameA importedModules mainbaseinfosA <- loadCompleteAnalysis baseananameA moduleName impbaseinfosB <- getInterfaceInfos baseananameB importedModules mainbaseinfosB <- loadCompleteAnalysis baseananameB moduleName let baseinfosA = combineProgInfo impbaseinfosA mainbaseinfosA baseinfosB = combineProgInfo impbaseinfosB mainbaseinfosB return (analysisFunction baseinfosA baseinfosB) curry-tools-v3.3.0/optimize/.cpm/packages/cass-analysis/src/Analysis/UnsafeModule.curry000066400000000000000000000034721377556325500313110ustar00rootroot00000000000000------------------------------------------------------------------------ --- An analysis which returns information whether a module is unsafe, i.e., --- it imports directly or indirectly the module `Unsafe`. --- --- @author Michael Hanus --- @version November 2020 ------------------------------------------------------------------------ module Analysis.UnsafeModule ( showUnsafe, unsafeModuleAnalysis ) where import Data.List ( isInfixOf, nub ) import Analysis.Types import FlatCurry.Goodies ( progImports, progName ) import FlatCurry.Types ------------------------------------------------------------------------ --- This analysis associates to a module the list of the names of all --- modules which directly imports the module `Unsafe`. --- Such modules might hide dangerous operations in --- purely functional operations. --- Thus, a module is safe if the analysis result is the empty list. unsafeModuleAnalysis :: Analysis [String] unsafeModuleAnalysis = dependencyModuleAnalysis "UnsafeModule" importsUnsafe -- Show a list of type constructor names as a string. showUnsafe :: AOutFormat -> [String] -> String showUnsafe _ [] = "safe" showUnsafe ANote (_:_) = "unsafe" showUnsafe AText [mod] = "unsafe (due to module " ++ mod ++ ")" showUnsafe AText ms@(_:_:_) = "unsafe (due to modules " ++ unwords ms ++ ")" -- Does the module import the module `Unsafe` or any other unsafe module? -- TODO: to be real safe, one also has to check external operations! importsUnsafe :: Prog -> [(String,[String])] -> [String] importsUnsafe prog impinfos = let unsafemods = (if any ("Unsafe" `isInfixOf`) (progImports prog) then [progName prog] else []) ++ concatMap snd impinfos in nub unsafemods ----------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/cass/000077500000000000000000000000001377556325500214335ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/cass/LICENSE000066400000000000000000000027351377556325500224470ustar00rootroot00000000000000Copyright (c) 2017, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/cass/Protocol.txt000066400000000000000000000026111377556325500237750ustar00rootroot00000000000000Protocol to communicate with the analysis server ================================================ Server commands: ---------------- GetAnalysis SetCurryPath ::... StopServer AnalyzeModule AnalyzeInterface AnalyzeFunction AnalyzeDataConstructor AnalyzeTypeConstructor Server answers: --------------- error ... ok \n (here denotes the number of lines in ) The answer to the command `GetAnalysis` is a list of all available analyses. The list has the form " ". For instance, a communication could be: > GetAnalysis < ok 5 < Deterministic CurryTerm < Deterministic Text < Deterministic XML < HigherOrder CurryTerm < DependsOn CurryTerm Further examples for server requests: > AnalyzeModule Deterministic CurryTerm SolverServer > AnalyzeModule Deterministic Text SolverServer > AnalyzeModule Deterministic XML SolverServer > AnalyzeFunction Deterministic XML SolverServer main > AnalyzeDataConstructor HigherOrder CurryTerm Prelude Just > AnalyzeFunction DependsOn CurryTerm SolverServer main curry-tools-v3.3.0/optimize/.cpm/packages/cass/README.md000066400000000000000000000043411377556325500227140ustar00rootroot00000000000000CASS: The Curry Analysis Server System ====================================== This directory contains the implementation of CASS, a generic and distributed analysis system for Curry programs. The analysis system is structured as a worker/server application where the workers are triggered by the main server to analyse individual modules. The analysis system can also be used as a client from other application programs by a socket interface. The protocol of this interface is described in `Protocol.txt`. The server is explicitly started by the program `cass` (generated via `make`) or implicitly by application programs that use of the operation `Configuration.getServerPortNumber` to find out the port number to connect to the analysis server. The port number can either be explicitly specified the starting the main server program via cass -p or a free port number is chosen when the analysis server is started. The current port and process numbers of a running analysis server are temporarily stored in the file `$HOME/.curryanalysis.port` (in the tuple format `(port,pid)`). The program `cass` can also be started on a console with arguments: cass In this case, the analysis with the specified name is applied to the specified module without the use of the server protocol and the output is shown on stdout. Run the command cass --help to get a description of the arguments and a list of registered analysis names. The analysis system can be configured in the file `$HOME/.curryanalysisrc` which is installed after the first run of the system. The implementations of the individual analysis are usually defined in the package `cass-analysis`). Description of some Curry modules: ---------------------------------- * `CASS.Registry`: All available analyses must be registered here. * `CASS.Server`: The main module implementing the use of the server. * `CASS.ServerFormats`: Definition and implementation of output formats. * `CASS.WorkerFunctions`: Implementation of the analysis workers (in particular, alternative fixpoint iterations to compute dependency analyses, see option `fixpoint` in the configuration file, must be inserted here). Contact: [Michael Hanus](http://www.informatik.uni-kiel.de/~mh) curry-tools-v3.3.0/optimize/.cpm/packages/cass/curryanalysisrc000066400000000000000000000022151377556325500246130ustar00rootroot00000000000000# The initial default path when the system is started: # (this path is added at the end of an existing CURRYPATH value) path= # The number of workers (if value=0, no further processes are started): numberOfWorkers=0 # The method to compute the fixpoint in dependency analyses. Possible values: # simple : simple fixpoint iteration # wlist : fixpoint iteration with working lists # wlistscc : fixpoint iteration with working lists where strongly connected # components are computed to guide the individual iterations fixpoint=wlist # The command to be used to wrap the server when the system is started # in server mode: terminalCommand=gnome-terminal -e # The debugging level (between 0 and 4) to show informative debugging infos. # Meaning of the debug level: # 0 : show nothing # 1 : show worker activity, e.g., timings # 2 : show server communication # 3 : ...and show read/store information # 4 : ...show also stored/computed analysis data debugLevel=0 # Should the prelude be analyzed? Usually, it should be "yes". # The value "no" is only reasonable for experimental purposes # (e.g., to test new analyses on small programs). prelude=yes curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/000077500000000000000000000000001377556325500223635ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/Demand.md000066400000000000000000000003411377556325500240730ustar00rootroot00000000000000Demand analysis --------------- This analysis assigns to each operation a list of argument positions (e.g., [1] for the first argument) which are demanded in order to reduce this operation to some constructor-rooted value. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/Deterministic.md000066400000000000000000000013151377556325500255100ustar00rootroot00000000000000Analysis of deterministic operations ------------------------------------ This analysis checks whether an operation is deterministically defined. Intuitively, an operation is deterministic if the evaluation of this operation applied to ground terms does not cause any non-determinism. The determinism analysis returns `nondeterministic` for a given operation if its definition contains overlapping left-hand sides or free variables, or if it depends on some non-deterministic operation. If calls to non-deterministic operations are encapsulated (by the use of set functions or operations from module `AllSolutions`), then it is classified as deterministic since the non-determinism does not occur at the top-level. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/Functional.md000066400000000000000000000011711377556325500250070ustar00rootroot00000000000000Analysis of functionally defined operations ------------------------------------------- This analysis checks whether an operation is defined in a pure functional manner. An operation is functionally defined if its definition does not contain overlapping left-hand sides or free variables, and it depends only on functionally defined operations. This analysis is stronger than the `Deterministic` analysis, since the latter classifies an operation as deterministic if calls to possibly non-deterministic operations are wrapped with encapsulated search operators, whereas this analysis does not allow the use of any logic features. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/Groundness.md000066400000000000000000000006321377556325500250350ustar00rootroot00000000000000Groundness analysis ------------------- This analysis assigns to each operation the conditions under which a ground (non-free) result is computed. The analysis results can be "always ground result", "possibly non-ground result", or "ground if arguments x1,..,xn are ground". The idea and details of this analysis can be found in the [ICLP'05 paper](http://www.informatik.uni-kiel.de/~mh/papers/ICLP05.html). curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/HiOrderConstr.md000066400000000000000000000003421377556325500254310ustar00rootroot00000000000000Higher-order constructor analysis --------------------------------- This analysis is a simple analysis for data constructors. It associates to each data constructor a flag indicating whether some argument contains functions. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/HiOrderFunc.md000066400000000000000000000004331377556325500250550ustar00rootroot00000000000000Higher-order property analysis ------------------------------ This analysis analyzes the higher-order status of an operation. It classifies an operations as higher-order since if it has functional arguments or results, or or it processes data structures with functional components. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/HiOrderType.md000066400000000000000000000003241377556325500251020ustar00rootroot00000000000000Higher-order type analysis -------------------------- This analysis analyzes the higher-order status of type constructors, i.e., it shows whether some constructor of a type constructor has functional arguments. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/Indeterministic.md000066400000000000000000000005431377556325500260410ustar00rootroot00000000000000Indeterminism analysis ---------------------- This analysis assigns to each operation a flag which is `True` if this operation might be indeterministic, i.e., calls directly or indirectly a select or committed choice operation. Thus, an indeterministic is not referentially transparent since it might deliver different results on different program runs. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/NDEffect.md000066400000000000000000000012471377556325500243270ustar00rootroot00000000000000Groundness/non-determinism effect analysis ------------------------------------------ This analysis assigns to each operation the conditions under which the evaluation of this operation might perform non-deterministic steps. The non-deterministic steps might be due to a `choice` (overlapping rules) or narrowing steps, where the latter might depend on the non-groundness of particular arguments. For instance, the operation not True = False not False = True is performs non-deterministic steps if the first argument is non-ground. The idea and details of this analysis can be found in the [ICLP'05 paper](http://www.informatik.uni-kiel.de/~mh/papers/ICLP05.html). curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/NonDetAllDeps.md000066400000000000000000000025321377556325500253430ustar00rootroot00000000000000Analysis of dependencies on all non-deterministic operations ------------------------------------------------------------ This analysis is useful if some operation has a non-deterministic behavior and one wants to find the reason for this behavior. For this purpose, the analysis computes for each operation the set of operations with a non-deterministic definition that might be called by this operation. An operation has a non-deterministic definition if its definition contains overlapping left-hand sides or free variables. If the non-determinism of an operation is encapsulated by a set function or an encapsulated search operation of the module `AllSolutions`, it is considered as deterministic. For instance, consider the operations last xs | _ ++ [x] == xs = x where x free coin = 0 ? 1 lastCoin = id (last [coin]) Then the operation `lastCoin` depends on the non-deterministic operations `last` and `coin`. Now consider the operations f x = x ? lastCoin g x = f x Then the operation `g` depends on the non-deterministic operation `f`, and also on the non-deterministic operations `last` and `coin`. In the long analysis output (produced by CASS in batch mode), the non-deterministic operations are shown together with the sequence of operations (limited to a length of 10) which calls the non-deterministic operation. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/NonDetDeps.md000066400000000000000000000030221377556325500247050ustar00rootroot00000000000000Analysis of dependencies on non-deterministic operations -------------------------------------------------------- This analysis is useful if some operation has a non-deterministic behavior and one wants to find the reason for this behavior. For this purpose, the analysis computes for each operation the set of operations with a non-deterministic definition that might be called by this operation. An operation has a non-deterministic definition if its definition contains overlapping left-hand sides or free variables. Non-deterministic operations that are called by other non-deterministic operations are ignored so that only the first (w.r.t. the call sequence) non-deterministic operations are returned. Moreover, if the non-determinism of an operation is encapsulated by a set function or an encapsulated search operation of the module `AllSolutions`, it is considered as deterministic. For instance, consider the operations last xs | _ ++ [x] == xs = x where x free coin = 0 ? 1 lastCoin = id (last [coin]) Then the operation `lastCoin` depends on the non-deterministic operations `last` and `coin`. Now consider the operations f x = x ? lastCoin g x = f x Then the operation `g` depends on the non-deterministic operation `f`, but the dependency on the non-deterministic operations `last` and `coin` is not reported. In the long analysis output (produced by CASS in batch mode), the non-deterministic operations are shown together with the operation which directly calls the non-deterministic operation. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/Overlapping.md000066400000000000000000000006411377556325500251740ustar00rootroot00000000000000Overlapping rule analysis ------------------------- The overlapping rule analysis checks whether an individual operation is defined by overlapping left-hand sides. For instance, the operation not True = False not False = True is not overlapping, whereas coin = 0 coin = 1 is overlapping. Note that f = coin is not overlapping, although it calls an operation defined by overlapping rules. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/PatComplete.md000066400000000000000000000015151377556325500251240ustar00rootroot00000000000000Pattern completeness analysis ----------------------------- This analysis analyzes an operation for a pattern-complete definition. An operation is pattern complete if each pattern match is defined for all constructors. For instance, the operation not True = False not False = True is pattern complete, whereas the operation head (x:_) = x is incomplete. If an operation is defined by overlapping rules, it is complete if there is one alternative with complete pattern matching. For instance, the operation por True x = True por x True = True por False False = False is not complete, since it corresponds to the following definition: por x y = por1 x y ? por2 x y por1 True _ = True por1 False False = True por2 _ True = True Hence, each alternative is incomplete. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/Productive.md000066400000000000000000000013001377556325500250230ustar00rootroot00000000000000Productivity analysis --------------------- This analysis computes some information about the termination or productivity of an operation. An operation is considered as being productive if it cannot perform an infinite number of steps without producing outermost constructors. This analysis assigns to an operation an abstract value indicating whether the function is terminating, looping, or productive. In the latter case, the abstract value contains the top-level calls, i.e., operations that are called at the top-level without an outermost constructor. For instance, consider the operations loop = id loop ones = 1 : ones `loop` is classified as looping whereas `ones` is productive. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/README.txt000066400000000000000000000004111377556325500240550ustar00rootroot00000000000000This directory contains some documention for the Curry Analysis Server System: manual.tex: A short description to be included in the main manual of the Curry system. .md: The documentation of the analysis registered with name in markdown syntax. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/RequiredValue.md000066400000000000000000000022351377556325500254640ustar00rootroot00000000000000Required value analysis ----------------------- This analysis checks for each operation in a Curry program whether the arguments must have a particular shape in order to compute some value. For instance, the negation operation `not` defined by not True = False not False = True requires the argument value `False` in order to compute the result `True` and it requires the argument `True` to compute the result `False`. This property is expressed by the following abstract type: not : (True -> False) | (False -> True) Hence, each abstract type is a constructor which represents all expressions rooted by this constructor. Moreover, the abstract type `cons` denotes any constructor-rooted expression and the abstract type `any` denotes any expression. The abstract type `_|_` denotes an impossible required type, i.e., an argument which is required but for which no applicable value exists. For instance, the operation f x = solve (x && not x) has the required value typing f: (_|_ -> {True}) A detailed description of this analysis and its application can be found in the [LOPSTR'15 paper](http://www.informatik.uni-kiel.de/~mh/papers/LOPSTR15.html). curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/RequiredValues.md000066400000000000000000000021571377556325500256520ustar00rootroot00000000000000Required values analysis ------------------------ This analysis checks for each operation in a Curry program whether the arguments must have a particular shape in order to compute some value. For instance, the negation operation `not` defined by not True = False not False = True requires the argument value `False` in order to compute the result `True` and it requires the argument `True` to compute the result `False`. This property is expressed by the following abstract type: not : ({True} -> {False}) | ({False} -> {True}) Hence, each abstract type is a set of constructors which represents all expressions rooted by one of the constructors in this set. Moreover, the abstract type `any` denotes any expression. The empty list denotes an impossible required type, i.e., an argument which is required but for which no applicable value exists. For instance, the operation f x = solve (x && not x) has the required value typing f: ({} -> True) A detailed description of this analysis and its application can be found in the [LOPSTR'15 paper](http://www.informatik.uni-kiel.de/~mh/papers/LOPSTR15.html). curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/Residuation.md000066400000000000000000000024001377556325500251670ustar00rootroot00000000000000Residuation analysis -------------------- This analysis checks whether a function does not residuate and yields, if it successfully evaluates to some value, a ground value provided that the function is called with some ground values as arguments. To bemore precise, the analysis associates to each function one of the following results: * `NoResiduateIf xs` (does not residuate if arguments `xs` are ground): If the operation is called where the arguments in the index list `xs` are ground values (where arguments are numbered from 1), then the evaluation does not residuate and yields a ground value. For instance, the operation const :: a -> b -> a const x _ = x has the residuation behavior `NoResiduateIf [1]`, and the list concatenation `++` has the residuation behavior `NoResiduateIf [1,2]`. * `MayResiduate` (possible residuation or non-ground result): The operation might residuate or yields a non-ground value, independent of the arguments. For instance, this is the case for the operations f x = x + ensureNotFree unknown g x = (x,y) where y free * `NoResInfo` (unknown residuation behavior): The residuation behavior of this function cannot be determined. This might occur when complex recursive `let`s are involved. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/RightLinear.md000066400000000000000000000006521377556325500251200ustar00rootroot00000000000000Right-linearity analysis ------------------------ This analysis checks whether an operation is right-linear, i.e., whether its evaluation does not duplicate any argument. Hence, this analysis returns `right-linear` for a given operation if it is defined by right-linear rules (i.e., rules that does not contain multiple occurrences of argument variables in its right-hand sides) and depends only on right-linear operations. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/RootCyclic.md000066400000000000000000000005441377556325500247620ustar00rootroot00000000000000Root cyclic analysis -------------------- This analysis assigns `True` to an operation `f` if its evaluation might result in an expression rooted by `f`. Hence, this analysis is useful to detect simple loops. f x = g x g x = h x h x = id (f x) id x = x Then `f`, `g`, and `h` are root-cyclic whereas `id` is not root-cyclic. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/RootReplaced.md000066400000000000000000000007241377556325500252730ustar00rootroot00000000000000Root replacement analysis ------------------------- This analysis returns for each function `f` all functions into which `f` can be replaced at the root. For instance, if there are the definitions: f x = g x g x = h x h x = k x : [] k x = x then the root replacements of `f` are `[g,h]` and the root replacements of `g` are `[h]`. This analysis could be useful to detect simple loops, e.g., if a function is in its own root replacement. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/SensibleType.md000066400000000000000000000024101377556325500253100ustar00rootroot00000000000000Sensible types analysis ----------------------- The `SensibleType` analysis is a type analysis which checks whether a type is sensible, i.e., whether there exists at least one value of this type. This analysis associates to each type constructor the following information: * sensible, i.e., there is exists some value of this type * parametric sensible, i.e., it is parametric type which is sensible if all type arguments are instantiated with sensible types * not sensible, i.e., there may be no values of this type For instance, the list type constructor "[]" is sensible and the pair type constructor "(,)" is parametric sensible. For further examples, consider the following type declarations: type Pair = (Int,Int) data RTree a = RTree a [RTree a] data ITree a = ITree a (ITree a) type IntRTree = RTree Int type IntITree = ITree Int type ITreeRTree = RTree (ITree Int) Then this analysis computes the following information: Pair : sensible RTree : parametric sensible ITree : not sensible IntRTree : sensible IntITree : not sensible ITreeRTree : not sensible Note that function types are classified as not sensible since it is not known whether some operation of this type exists. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/SiblingCons.md000066400000000000000000000005211377556325500251150ustar00rootroot00000000000000Sibling constructor analysis ---------------------------- This analysis associates to each data constructor the list of sibling constructors, i.e., the qualified name and arity of all constructors of the same type without this data constructor. For instance, the sibling constructors of `Prelude.True` are `[(("Prelude","False"),0)]`. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/SolComplete.md000066400000000000000000000007141377556325500251350ustar00rootroot00000000000000Solution completeness analysis ------------------------------ This analysis assigns to a function a flag which is `True` if this function is operationally complete, i.e., does not call (explicitly or implicitly) a rigid function. For instance, the operation not True = False not False = True is `solution complete`, whereas the prelude operation `putChar` is not solution complete but may suspend if it is called with a free variable as argument. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/Terminating.md000066400000000000000000000015661377556325500251760ustar00rootroot00000000000000Termination analysis -------------------- This analysis assigns `True` to an operation `f` if all its evaluations on ground argument terms are finite. The current method used in this analysis is quite simple. It checks whether the arguments in all recursive calls of an operation are smaller than the arguments passed to the operation. Indirect calls are not considered. Therefore, the operation length [] = 0 length (x:xs) = 1 + length xs is classified as terminating, whereas the semantically equivalent operation length [] = 0 length (x:xs) = incLength xs incLength xs = 1 + length xs is classified as possibly non-terminating. Operations containing free variables in their definitions are also classified as possibly non-terminating since a free variable might reduce to arbitrarily large constructor terms (in case of recursive data types). curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/Total.md000066400000000000000000000005201377556325500237650ustar00rootroot00000000000000Totally definedness analysis ---------------------------- This analysis assigns to each operation a flag which is `True` if this operation is completely defined on its input types, i.e., reducible for all ground data terms. Thus, an operation is totally defined if it is pattern complete and depends only on totally defined functions. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/TypesInValues.md000066400000000000000000000016531377556325500254650ustar00rootroot00000000000000Analyzing types occurring in values ----------------------------------- The `TypesInValues` analysis is a type analysis which assigns to each data type defined in a program the list of data types (type constructors) which might occur in value arguments of this type. For instance, no type constructors are associated to `Bool` since Boolean values have no arguments. The type constructor `[]` is associated to the `[]` since a list occurs in the second argument of a non-empty list. Thus, this analysis can be used to check for recursive types: if a type constructor is associated to itself, the type is recursive, i.e., can have values of arbitrary size. For instance, consider the following type declarations: data List a = Empty | Cons a (List a) data Tree a = Leaf | Node (List (Tree a)) Then this analysis computes the following information: List : List Tree : List, Tree Hence, both types are recursive. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/UnsafeModule.md000066400000000000000000000007501377556325500252760ustar00rootroot00000000000000Analyzing module for importing `Unsafe` module ---------------------------------------------- The `UnsafeModule` analysis returns information whether a module is unsafe, i.e., it imports directly or indirectly the module `Unsafe`. Such modules might hide dangerous operations in purely functional operations. The result of this analysis is the list of the names of all modules which directly imports the module `Unsafe`. Thus, a module is safe if the analysis result is the empty list. curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/main.tex000066400000000000000000000036101377556325500240310ustar00rootroot00000000000000\documentclass[11pt,fleqn]{article} \usepackage[T1]{fontenc} \usepackage{latexsym} \usepackage{url} \usepackage{xspace} \usepackage{graphicx} \setlength{\textwidth}{16.5cm} \setlength{\textheight}{23cm} \renewcommand{\baselinestretch}{1.1} \setlength{\topmargin}{-1cm} \setlength{\oddsidemargin}{0cm} \setlength{\evensidemargin}{0cm} \setlength{\marginparwidth}{0.0cm} \setlength{\marginparsep}{0.0cm} \newlength{\figurewidth} \setlength{\figurewidth}{\textwidth} \addtolength{\figurewidth}{-0.4cm} % font for program texts \renewcommand{\tt}{\usefont{OT1}{cmtt}{m}{n}\selectfont} \newcommand{\codefont}{\small\tt} \usepackage{listings} \lstset{aboveskip=1.5ex, belowskip=1.5ex, showstringspaces=false, % no special string space mathescape=true, flexiblecolumns=false, xleftmargin=2ex, basewidth=0.52em, basicstyle=\small\ttfamily} \lstset{literate={->}{{$\rightarrow{}\!\!\!$}}3 } \lstnewenvironment{curry}{}{} \lstnewenvironment{currynomath}{\lstset{mathescape=false}}{} % Curry w/o math \newcommand{\listline}{\vrule width0pt depth1.75ex} % program text in normal text \newcommand{\code}[1]{\mbox{\codefont #1}} % program text in normal text with apostrophs \newcommand{\ccode}[1]{``\code{#1}''} \newcommand{\pindex}[1]{\index{#1@{\tt #1}}} % program elements in index \newcommand{\CYS}{Curry\xspace} % name of the Curry system described here \newcommand{\cyshome}{\mbox{\textit{curryhome}}\xspace} % symbolic installation directory \begin{document} \sloppy \input{manual.tex} % Bibliography \begin{thebibliography}{10} \bibitem{HanusSkrlac14} M.~Hanus and F.~Skrlac. \newblock A modular and generic analysis server system for functional logic programs. \newblock In {\em Proc. of the ACM SIGPLAN 2014 Workshop on Partial Evaluation and Program Manipulation (PEPM'14)}, pages 181--188. ACM Press, 2014. \end{thebibliography} \end{document} curry-tools-v3.3.0/optimize/.cpm/packages/cass/docs/manual.tex000066400000000000000000000362431377556325500243720ustar00rootroot00000000000000\section{CASS: A Generic Curry Analysis Server System} \label{sec-cass} CASS\index{CASS}\index{analyzing programs}\index{program!analysis} (Curry Analysis Server System) is a tool for the analysis of Curry programs. CASS is generic so that various kinds of analyses (e.g., groundness, non-determinism, demanded arguments) can be easily integrated into CASS. In order to analyze larger applications consisting of dozens or hundreds of modules, CASS supports a modular and incremental analysis of programs. Moreover, it can be used by different programming tools, like documentation generators, analysis environments, program optimizers, as well as Eclipse-based development environments. For this purpose, CASS can also be invoked as a server system to get a language-independent access to its functionality. CASS is completely implemented Curry as a master/worker architecture to exploit parallel or distributed execution environments. The general design and architecture of CASS is described in \cite{HanusSkrlac14}. In the following, CASS is presented from a perspective of a programmer who is interested to analyze Curry programs. \subsection{Installation} The current implementation of CASS is a package managed by the Curry Package Manager CPM. Thus, to install the newest version of CASS, use the following commands: % \begin{curry} > cypm update > cypm install cass \end{curry} % This downloads the newest package, compiles it, and places the executable \code{cass} into the directory \code{\$HOME/.cpm/bin}. Hence it is recommended to add this directory to your path in order to execute CASS as described below. \subsection{Using CASS to Analyze Programs} CASS is intended to analyze various operational properties of Curry programs. Currently, it contains more than a dozen program analyses for various properties. Since most of these analyses are based on abstract interpretations, they usually approximate program properties. To see the list of all available analyses, use the help option of CASS: \begin{curry} > cass -h Usage: $\ldots$ $\vdots$ Registered analyses names: $\ldots$ Demand : Demanded arguments Deterministic : Deterministic operations $\vdots$ \end{curry} More information about the meaning of the various analyses can be obtained by adding the short name of the analysis: \begin{curry} > cass -h Deterministic $\ldots$ \end{curry} For instance, consider the following Curry module \code{Rev.curry}: \begin{curry} append :: [a] -> [a] -> [a] append [] ys = ys append (x:xs) ys = x : append xs ys rev :: [a] -> [a] rev [] = [] rev (x:xs) = append (rev xs) [x] main :: Int -> Int -> [Int] main x y = rev [x .. y] \end{curry} % CASS supports three different usage modes to analyze this program. \subsubsection{Batch Mode} In the batch mode, CASS is started as a separate application via the shell command \code{cass}, where the analysis name and the name of the module to be analyzed must be provided:\footnote{More output is generated when the parameter \code{debugLevel} is changed in the configuration file \code{.curryanalysisrc} which is installed in the user's home directory when CASS is started for the first time.} \begin{curry} > cass Demand Rev append : demanded arguments: 1 main : demanded arguments: 1,2 rev : demanded arguments: 1 \end{curry} The \code{Demand} analysis shows the list of argument positions (e.g., 1 for the first argument) which are demanded in order to reduce an application of the operation to some constructor-rooted value. Here we can see that both arguments of \code{main} are demanded whereas only the first argument of \code{append} is demanded. This information could be used in a Curry compiler to produce more efficient target code. The batch mode is useful to test a new analysis and get the information in human-readable form so that one can experiment with different abstractions or analysis methods. \subsubsection{API Mode} The API mode is intended to use analysis information in some application implemented in Curry. Since CASS is implemented in Curry, one can import the modules of the CASS implementation and use the CASS interface operations to start an analysis and use the computed results. For instance, CASS provides an operation (defined in the module \code{AnalysisServer}) \begin{curry} analyzeGeneric :: Analysis a -> String -> IO (Either (ProgInfo a) String) \end{curry} to apply an analysis (first argument) to some module (whose name is given in the second argument). The result is either the analysis information computed for this module or an error message in case of some execution error. The modules of the CASS implementation are stored in the directory \code{\cyshome/currytools/CASS} and the modules implementing the various program analyses are stored in \code{\cyshome/currytools/analysis}. Hence, one should add these directories to the Curry load path when using CASS in API mode. The CASS module \code{GenericProgInfo} contains operations to access the analysis information computed by CASS. For instance, the operation \begin{curry} lookupProgInfo:: QName -> ProgInfo a -> Maybe a \end{curry} returns the information about a given qualified name in the analysis information, if it exists. As a simple example, consider the demand analysis which is implemented in the module \code{Demandedness} by the following operation: \begin{curry} demandAnalysis :: Analysis DemandedArgs \end{curry} \code{DemendedArgs} is just a type synonym for \code{[Int]}. We can use this analysis in the following simple program: \begin{currynomath} import AnalysisServer (analyzeGeneric) import GenericProgInfo (lookupProgInfo) import Demandedness (demandAnalysis) demandedArgumentsOf :: String -> String -> IO [Int] demandedArgumentsOf modname fname = do deminfo <- analyzeGeneric demandAnalysis modname >>= return . either id error return $ maybe [] id (lookupProgInfo (modname,fname) deminfo) \end{currynomath} %$ Of course, in a realistic program, the program analysis is performed only once and the computed information \code{deminfo} is passed around to access it several times. Nevertheless, we can use this simple program to compute the demanded arguments of \code{Rev.main}: \begin{curry} $\ldots$> demandedArgumentsOf "Rev" "main" [1,2] \end{curry} \subsubsection{Server Mode} The server mode of CASS can be used in an application implemented in some language that does not have a direct interface to Curry. In this case, one can connect to CASS via some socket using a simple communication protocol that is specified in the file \code{\cyshome/currytools/CASS/Protocol.txt} and sketched below. To start CASS in the server mode, one has to execute the command \begin{curry} > cass --server [ -p ] \end{curry} where an optional port number for the communication can be provided. Otherwise, a free port number is chosen and shown. In the server mode, CASS understands the following commands: \begin{curry} GetAnalysis SetCurryPath ::... AnalyzeModule AnalyzeInterface AnalyzeFunction AnalyzeDataConstructor AnalyzeTypeConstructor StopServer \end{curry} The output type can be \code{Text}, \code{CurryTerm}, or \code{XML}. The answer to each request can have two formats: \begin{curry} error \end{curry} if an execution error occured, or \begin{curry} ok \end{curry} where \code{} is the number of lines of the result text. For instance, the answer to the command \code{GetAnalysis} is a list of all available analyses. The list has the form \begin{curry} \end{curry} For instance, a communication could be: \begin{curry} > GetAnalysis < ok 5 < Deterministic CurryTerm < Deterministic Text < Deterministic XML < HigherOrder CurryTerm < DependsOn CurryTerm \end{curry} The command \code{SetCurryPath} instructs CASS to use the given directories to search for modules to be analyzed. This is necessary since the CASS server might be started in a different location than its client. Complete modules are analyzed by \code{AnalyzeModule}, whereas \code{AnalyzeInterface} returns only the analysis information of exported entities. Furthermore, the analysis results of individual functions, data or type constructors are returned with the remaining analysis commands. Finally, \code{StopServer} terminates the CASS server. For instance, if we start CASS by \begin{curry} > cass --server -p 12345 \end{curry} we can communicate with CASS as follows (user inputs are prefixed by \ccode{>}); \begin{curry} > telnet localhost 12345 Connected to localhost. > GetAnalysis ok 57 Overlapping XML Overlapping CurryTerm Overlapping Text Deterministic XML ... > AnalyzeModule Demand Text Rev ok 3 append : demanded arguments: 1 main : demanded arguments: 1,2 rev : demanded arguments: 1 > AnalyzeModule Demand CurryTerm Rev ok 1 [(("Rev","append"),"demanded arguments: 1"),(("Rev","main"),"demanded arguments: 1,2"),(("Rev","rev"),"demanded arguments: 1")] > AnalyzeModule Demand XML Rev ok 19 Rev append demanded arguments: 1 Rev main demanded arguments: 1,2 Rev rev demanded arguments: 1 > StopServer ok 0 Connection closed by foreign host. \end{curry} \subsection{Implementing Program Analyses} Each program analysis accessible by CASS must be registered in the CASS module \code{Registry}. The registered analysis must contain an operation of type \begin{curry} Analysis a \end{curry} where \code{a} denotes the type of analysis results. For instance, the \code{Overlapping} analysis is implemented as a function \begin{curry} overlapAnalysis :: Analysis Bool \end{curry} where the Boolean analysis result indicates whether a Curry operation is defined by overlapping rules. In order to add a new analysis to CASS, one has to implement a corresponding analysis operation, registering it in the module \code{Registry} (in the constant \code{registeredAnalysis}) and compile the modified CASS implementation. An analysis is implemented as a mapping from Curry programs represented in FlatCurry into the analysis result. Hence, to implement the \code{Overlapping} analysis, we define the following operation on function declarations in FlatCurry format: \begin{curry} import FlatCurry.Types $\ldots$ isOverlappingFunction :: FuncDecl -> Bool isOverlappingFunction (Func _ _ _ _ (Rule _ e)) = orInExpr e isOverlappingFunction (Func f _ _ _ (External _)) = f==("Prelude","?") -- Check an expression for occurrences of Or: orInExpr :: Expr -> Bool orInExpr (Var _) = False orInExpr (Lit _) = False orInExpr (Comb _ f es) = f==(pre "?") || any orInExpr es orInExpr (Free _ e) = orInExpr e orInExpr (Let bs e) = any orInExpr (map snd bs) || orInExpr e orInExpr (Or _ _) = True orInExpr (Case _ e bs) = orInExpr e || any orInBranch bs where orInBranch (Branch _ be) = orInExpr be orInExpr (Typed e _) = orInExpr e \end{curry} % In order to enable the inclusion of different analyses in CASS, CASS offers several constructor operations for the abstract type \ccode{Analysis a} (defined in the CASS module \code{Analysis}). Each analysis has a name provided as a first argument to these constructors. The name is used to store the analysis information persistently and to pass specific analysis tasks to analysis workers. For instance, a simple function analysis which depends only on a given function definition can be defined by the analysis constructor \begin{curry} simpleFuncAnalysis :: String -> (FuncDecl -> a) -> Analysis a \end{curry} The arguments are the analysis name and the actual analysis function. Hence, the ``overlapping rules'' analysis can be specified as \begin{curry} import Analysis $\ldots$ overlapAnalysis :: Analysis Bool overlapAnalysis = simpleFuncAnalysis "Overlapping" isOverlappingFunction \end{curry} Another analysis constructor supports the definition of a function analysis with dependencies (which is implemented via a fixpoint computation): \begin{curry} dependencyFuncAnalysis :: String -> a -> (FuncDecl -> [(QName,a)] -> a) -> Analysis a \end{curry} Here, the second argument specifies the start value of the fixpoint analysis, i.e., the bottom element of the abstract domain. For instance, a determinism analysis could be based on an abstract domain described by the data type \begin{curry} data Deterministic = NDet | Det \end{curry} Here, \code{Det} is interpreted as ``the operation always evaluates in a deterministic manner on ground constructor terms.'' However, \code{NDet} is interpreted as ``the operation \emph{might} evaluate in different ways for given ground constructor terms.'' The apparent imprecision is due to the approximation of the analysis. For instance, if the function \code{f} is defined by overlapping rules and the function \code{g} \emph{might} call \code{f}, then \code{g} is judged as non-deterministic (since it is generally undecidable whether \code{f} is actually called by \code{g} in some run of the program). The determinism analysis requires to examine the current function as well as all directly or indirectly called functions for overlapping rules. Due to recursive function definitions, this analysis cannot be done in one shot---it requires a fixpoint computation. CASS provides such fixpoint computations and requires only the implementation of an operation of type \begin{curry} FuncDecl -> [(QName,a)] -> a \end{curry} where \ccode{a} denotes the type of abstract values. The second argument of type \code{[(QName,a)]} represents the currently known analysis values for the functions \emph{directly} used in this function declaration. In our example, the determinism analysis can be implemented by the following operation: \begin{curry} detFunc :: FuncDecl -> [(QName,Deterministic)] -> Deterministic detFunc (Func f _ _ _ (Rule _ e)) calledFuncs = if orInExpr e || freeVarInExpr e || any (==NDet) (map snd calledFuncs) then NDet else Det \end{curry} Thus, it computes the abstract value \code{NDet} if the function itself is defined by overlapping rules or contains free variables that might cause non-deterministic guessing (we omit the definition of \code{freeVarInExpr} since it is quite similar to \code{orInExpr}), or if it depends on some non-deterministic function. The complete determinism analysis can be specified as \begin{curry} detAnalysis :: Analysis Deterministic detAnalysis = dependencyFuncAnalysis "Deterministic" Det detFunc \end{curry} This definition is sufficient to execute the analysis with CASS since the analysis system takes care of computing fixpoints, calling the analysis functions with appropriate values, analyzing imported modules, etc. Nevertheless, the analysis must be defined so that the fixpoint computation always terminates. This can be achieved by using an abstract domain with finitely many values and ensuring that the analysis function is monotone w.r.t.\ some ordering on the values. curry-tools-v3.3.0/optimize/.cpm/packages/cass/examples/000077500000000000000000000000001377556325500232515ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/cass/examples/NonDetTest.curry000066400000000000000000000010661377556325500263710ustar00rootroot00000000000000-- Tests for the non-determinism dependency analysis `NonDetDeps`. -- -- Runt test with: -- > cass NonDetDeps NonDetTest.curry last xs | _ ++ [x] == xs = x where x free lastfp (_ ++ [x]) = x printLast = do print $ last [1..7] print $ lastfp [1..42] coin = 0 ? 1 lastCoin = id (last [coin]) --> last, coin f x = x ? lastCoin g x = f x -- For this operation, the NonDetDeps analysis reports that the -- non-determinism depends on `f`. -- However, the analysis NonDetAllDeps reports also the dependency -- on the non-deterministic operations coin, last,... curry-tools-v3.3.0/optimize/.cpm/packages/cass/examples/ResiduationStats.curry000066400000000000000000000037311377556325500276500ustar00rootroot00000000000000--- Analyzing the residuation behavior of a module and returns --- some statistical information. import Data.List ( intercalate, partition ) import FlatCurry.Types ( QName ) import CASS.Server ( analyzeGeneric ) import Analysis.ProgInfo ( progInfo2Lists ) import Analysis.Residuation -- ( demandAnalysis ) residuationInfoOf :: String -> IO ([(QName,ResiduationInfo)],[(QName,ResiduationInfo)]) residuationInfoOf modname = do analyzeGeneric residuationAnalysis modname >>= return . either progInfo2Lists error countResOps :: String -> IO [String] countResOps mname = do putStrLn $ "Analyzing module " ++ mname ++ "..." (pubres,privres) <- residuationInfoOf mname let (resops,nonresops) = partition (\(_,i) -> i==MayResiduate || i==NoResInfo) (pubres ++ privres) return [mname, show (length resops), show (length nonresops)] printCountResOps :: [String] -> IO () printCountResOps mname = do stats <- mapIO countResOps mname putStrLn $ "Module | Residuating | Non-residuating" mapIO_ (\row -> putStrLn (intercalate "|" row)) stats main :: IO () main = printCountResOps baseModules baseModules :: [String] baseModules = ["Prelude","List","Char"] allBaseModules :: [String] allBaseModules = ["AllSolutions" ,"AnsiCodes" ,"Char" ,"Combinatorial" ,"CPNS" ,"Debug" ,"Dequeue" ,"Directory" ,"Distribution" ,"Either" ,"ErrorState" ,"FileGoodies" ,"FilePath" ,"Findall" ,"FiniteMap" ,"Float" ,"Format" ,"Function" ,"FunctionInversion" ,"GetOpt" ,"Global" ,"Integer" ,"IO" ,"IOExts" ,"List" ,"Maybe" ,"NamedSocket" ,"Nat" ,"Prelude" ,"Profile" ,"PropertyFile" ,"Random" ,"Read" ,"ReadNumeric" ,"ReadShowTerm" ,"RedBlackTree" ,"SearchTree" ,"SearchTreeGenerators" ,"SearchTreeTraversal" ,"SetFunctions" ,"SetRBT" ,"ShowS" ,"Socket" ,"Sort" ,"State" ,"System" ,"TableRBT" ,"Time" ,"Traversal" ,"Unsafe" ,"ValueSequence" ] curry-tools-v3.3.0/optimize/.cpm/packages/cass/examples/Rev.curry000066400000000000000000000003171377556325500250740ustar00rootroot00000000000000append :: [a] -> [a] -> [a] append [] ys = ys append (x:xs) ys = x : append xs ys rev :: [a] -> [a] rev [] = [] rev (x:xs) = append (rev xs) [x] main :: Int -> Int -> [Int] main x y = rev [x .. y] curry-tools-v3.3.0/optimize/.cpm/packages/cass/examples/RootReplacedTest.curry000066400000000000000000000005151377556325500275630ustar00rootroot00000000000000-- Tests for the RootReplaced analysis -- -- Runt test with: -- > cass RootReplaced RootReplacedTest.curry loop = loop --> root replacements: [loop] --> indicates infinite loop f x = g x --> root replacements: [g,h] g x = h x --> root replacements: [h] h x = k x : [] --> root replacements: [] k x = x --> root replacements: [] curry-tools-v3.3.0/optimize/.cpm/packages/cass/examples/UsingCASS.curry000066400000000000000000000010611377556325500260740ustar00rootroot00000000000000--- A simple program to show the usage of the API mode of CASS --- to access the demanded values of the operation Rev.rev: import CASS.Server ( analyzeGeneric ) import Analysis.ProgInfo ( lookupProgInfo ) import Analysis.Demandedness ( demandAnalysis ) demandedArgumentsOf :: String -> String -> IO [Int] demandedArgumentsOf modname fname = do deminfo <- analyzeGeneric demandAnalysis modname >>= return . either id error return $ maybe [] id (lookupProgInfo (modname,fname) deminfo) main :: IO [Int] main = demandedArgumentsOf "Rev" "rev" curry-tools-v3.3.0/optimize/.cpm/packages/cass/package.json000066400000000000000000000027141377556325500237250ustar00rootroot00000000000000{ "name": "cass", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "CASS: the Curry Analysis Server System", "category": [ "Analysis" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "cass-analysis" : ">= 3.0.0, < 4.0.0", "containers" : ">= 3.0.0, < 4.0.0", "currypath" : ">= 3.0.0, < 4.0.0", "directory" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0", "flatcurry" : ">= 3.0.0, < 4.0.0", "global" : ">= 3.0.0, < 4.0.0", "io-extra" : ">= 3.0.0, < 4.0.0", "process" : ">= 3.0.0, < 4.0.0", "propertyfile" : ">= 3.0.0, < 4.0.0", "read-legacy" : ">= 3.0.0, < 4.0.0", "redblacktree" : ">= 3.0.0, < 4.0.0", "scc" : ">= 3.0.0, < 4.0.0", "socket" : ">= 3.0.0, < 4.0.0", "xml" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "configModule": "CASS.PackageConfig", "executable": { "name": "cass", "main": "CASS.Main" }, "documentation": { "src-dir": "docs", "main": "main.tex" }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/cass.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/000077500000000000000000000000001377556325500222225ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/000077500000000000000000000000001377556325500227535ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/Configuration.curry000066400000000000000000000222451377556325500266550ustar00rootroot00000000000000-------------------------------------------------------------------------- --- This module supports the configuration of the analysis system --- and provides access to some values in Config file. --- --- It also provides an operation to get the port number of --- the analysis server (which is implicitly started if necessary). --- --- @author Michael Hanus --- @version December 2020 -------------------------------------------------------------------------- module CASS.Configuration ( systemBanner, baseDir, docDir, executableName , getServerAddress, updateRCFile, updateCurrentProperty , getFPMethod, getWithPrelude , storeServerPortNumber, removeServerPortNumber, getServerPortNumber , getDefaultPath, waitTime, numberOfWorkers ) where import Curry.Compiler.Distribution ( curryCompiler ) import Data.List ( sort ) import Numeric ( readInt ) import System.Environment ( getEnv ) import System.FilePath ( FilePath, (), (<.>) ) import System.Process import System.Directory import Global import ReadShowTerm import Analysis.Logging ( debugMessage, setDebugLevel ) import CASS.PackageConfig ( packagePath, packageExecutable, packageVersion ) import Data.PropertyFile ( readPropertyFile, updatePropertyFile ) systemBanner :: String systemBanner = let bannerText = "CASS: Curry Analysis Server System (Version " ++ packageVersion ++ " of 27/12/2020 for " ++ curryCompiler ++ ")" bannerLine = take (length bannerText) (repeat '=') in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine --- The base directory of the analysis tool containing all programs --- and documentations. --- It is used to copy the configuration file, to the find executables --- of the server and the workers, and to find the documentation --- of the various analyses. baseDir :: String baseDir = packagePath --- The directory containing the documentations of the various analyses. docDir :: String docDir = baseDir "docs" --- The name of the main executable. Used to start workers in `CASS.Server`. executableName :: String executableName = packageExecutable --- The address of the server when it is connected from the worker clients. getServerAddress :: IO String getServerAddress = return "127.0.0.1" -- run only on local machine -------------------------------------------------------------------------- -- Name of user property file: propertyFileName :: IO String propertyFileName = getHomeDirectory >>= return . ( ".curryanalysisrc") defaultPropertyFileName :: String defaultPropertyFileName = baseDir "curryanalysisrc" --- Install user property file if it does not exist. installPropertyFile :: IO () installPropertyFile = do fname <- propertyFileName pfexists <- doesFileExist fname if pfexists then return () else do copyFile defaultPropertyFileName fname putStrLn ("New analysis configuration file '"++fname++"' installed.") --- Reads the rc file (and try to install a user copy of it if it does not --- exist) and compares the definitions with the default property file --- of the CASS distribution. If the set of variables is different, --- update the rc file of the user with the distribution --- but keep the user's definitions. updateRCFile :: IO () updateRCFile = do hashomedir <- getHomeDirectory >>= doesDirectoryExist if not hashomedir then readPropertiesAndStoreLocally >> return () else do installPropertyFile userprops <- readPropertiesAndStoreLocally distprops <- readPropertyFile defaultPropertyFileName if (rcKeys userprops == rcKeys distprops) then return () else do rcName <- propertyFileName putStrLn $ "Updating \"" ++ rcName ++ "\"..." renameFile rcName $ rcName <.> "bak" copyFile defaultPropertyFileName rcName mapM_ (\ (n, v) -> maybe (return ()) (\uv -> if uv==v then return () else updatePropertyFile rcName n uv) (lookup n userprops)) distprops rcKeys :: [(String, String)] -> [String] rcKeys = sort . map fst --- Reads the user property file or, if it does not exist, --- the default property file of CASS, --- and store the properties in a global variable for next access. readPropertiesAndStoreLocally :: IO [(String,String)] readPropertiesAndStoreLocally = do userpfn <- propertyFileName hasuserpfn <- doesFileExist userpfn props <- readPropertyFile (if hasuserpfn then userpfn else defaultPropertyFileName) writeGlobal currProps (Just props) updateDebugLevel props return props --- Reads the user property file (which must be installed!) --- and store the properties in a global variable for next access. getProperties :: IO [(String,String)] getProperties = readGlobal currProps >>= maybe readPropertiesAndStoreLocally return --- Updates the debug level from the current properties. updateDebugLevel :: [(String,String)] -> IO () updateDebugLevel properties = do let number = lookup "debugLevel" properties case number of Just value -> do case readInt value of [(dl,_)] -> setDebugLevel dl _ -> return () Nothing -> return () --- Global variable to store the current properties. currProps :: Global (Maybe [(String,String)]) currProps = global Nothing Temporary -- Updates a current property. updateCurrentProperty :: String -> String -> IO () updateCurrentProperty pn pv = do currprops <- getProperties let newprops = replaceKeyValue pn pv currprops writeGlobal currProps (Just newprops) updateDebugLevel newprops replaceKeyValue :: Eq a => a -> b -> [(a,b)] -> [(a,b)] replaceKeyValue k v [] = [(k,v)] replaceKeyValue k v ((k1,v1):kvs) = if k==k1 then (k,v):kvs else (k1,v1) : replaceKeyValue k v kvs -------------------------------------------------------------------------- --- Gets the name of file containing the current server port and pid --- ($HOME has to be set) getServerPortFileName :: IO String getServerPortFileName = do homeDir <- getHomeDirectory return $ homeDir++"/.curryanalysis.port" --- Stores the current server port number together with the pid of --- the server process. storeServerPortNumber :: Int -> IO () storeServerPortNumber portnum = do mypid <- getPID serverPortFileName <- getServerPortFileName writeQTermFile serverPortFileName (portnum,mypid) --- Removes the currently stored server port number. removeServerPortNumber :: IO () removeServerPortNumber = getServerPortFileName >>= removeFile readServerPortPid :: IO (Int,Int) readServerPortPid = getServerPortFileName >>= readQTermFile --- Reads the current server port number. If the server is not running, --- it is also started. getServerPortNumber :: IO Int getServerPortNumber = do serverPortFileName <- getServerPortFileName exfile <- doesFileExist serverPortFileName if exfile then do (portnum,pid) <- readServerPortPid flag <- system ("ps -p "++show pid++" > /dev/null") if flag==0 then return portnum else do removeFile serverPortFileName getServerPortNumber else do debugMessage 2 "Starting analysis server..." tcmd <- getTerminalCommand let serverCmd = baseDir++"/cass" if all isSpace tcmd then system ("\""++serverCmd++"\" > /dev/null 2>&1 &") else system (tcmd++" \""++baseDir++"/cass\" &") sleep 1 waitForServerPort serverPortFileName where waitForServerPort serverPortFileName = do exfile <- doesFileExist serverPortFileName if exfile then readServerPortPid >>= return . fst else do debugMessage 2 "Waiting for server start..." sleep 1 waitForServerPort serverPortFileName -------------------------------------------------------------------------- -- Get terminalCommand from Config file getTerminalCommand :: IO String getTerminalCommand = do properties <- getProperties let tcmd = lookup "terminalCommand" properties return (maybe "" id tcmd) -- Get the fixpoint computation method from Config file getFPMethod :: IO String getFPMethod = getProperties >>= return . maybe "simple" id . lookup "fixpoint" -- Get the option to analyze also the prelude from Config file getWithPrelude :: IO String getWithPrelude = getProperties >>= return . maybe "yes" id . lookup "prelude" -- timeout for network message passing: -1 is wait time infinity waitTime :: Int waitTime = -1 -- Default number of workers (if the number is not found in the -- configuration file). defaultWorkers :: Int defaultWorkers=0 --- Gets the default load path from the property file (added at the end --- of CURRYPATH). getDefaultPath :: IO String getDefaultPath = do currypath <- getEnv "CURRYPATH" properties <- getProperties let proppath = lookup "path" properties return $ case proppath of Just value -> if all isSpace value then currypath else if null currypath then value else currypath++':':value Nothing -> currypath -- number of worker threads running at the same time numberOfWorkers :: IO Int numberOfWorkers = do properties <- getProperties let number = lookup "numberOfWorkers" properties case number of Just value -> do case readInt value of [(int,_)] -> return int _ -> return defaultWorkers Nothing -> return defaultWorkers curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/Dependencies.curry000066400000000000000000000216011377556325500264270ustar00rootroot00000000000000----------------------------------------------------------------------- --- Operations to handle dependencies of analysis files. --- --- @author Heiko Hoffmann, Michael Hanus --- @version January 2017 ----------------------------------------------------------------------- module CASS.Dependencies(getModulesToAnalyze,reduceDependencies) where import FlatCurry.Types import FlatCurry.Goodies (progImports) import ReadShowTerm (readQTerm) import System.Directory (doesFileExist,getModificationTime) import Data.Maybe (fromMaybe) import Data.List (delete) import Data.Time(ClockTime) import Analysis.Logging ( debugMessage ) import Analysis.Types import Analysis.ProgInfo import Analysis.Files import CASS.Configuration ( getWithPrelude ) ----------------------------------------------------------------------- --- Compute the modules and their imports which must be analyzed --- w.r.t. a given analysis and main module. --- If the first argument is true, then the analysis is enforced --- (even if analysis information exists). getModulesToAnalyze :: Bool -> Analysis a -> String -> IO [(String,[String])] getModulesToAnalyze enforce analysis moduleName = if isSimpleAnalysis analysis then do ananewer <- isAnalysisFileNewer ananame moduleName return (if ananewer && not enforce then [] else [(moduleName,[])]) else do valid <- isAnalysisValid ananame moduleName if valid && not enforce then do debugMessage 3 ("Analysis file for '"++moduleName++"' up-to-date") return [] else do moduleList <- getDependencyList [moduleName] [] debugMessage 3 ("Complete module list: "++ show moduleList) let impmods = map fst moduleList storeImportModuleList moduleName impmods sourceTimeList <- mapM getSourceFileTime impmods fcyTimeList <- mapM getFlatCurryFileTime impmods anaTimeList <- mapM (getAnaFileTime ananame) impmods let (modulesToDo,modulesUpToDate) = findModulesToAnalyze moduleList anaTimeList sourceTimeList fcyTimeList ([],[]) --debugMessage 3 ("Modules up-to-date: "++ show modulesUpToDate) withprelude <- getWithPrelude let modulesToAnalyze = if enforce then moduleList else if withprelude=="no" then let reduced = reduceDependencies modulesToDo (modulesUpToDate ++ ["Prelude"]) in case reduced of (("Prelude",_):remaining) -> remaining _ -> reduced else reduceDependencies modulesToDo modulesUpToDate debugMessage 3 ("Modules to analyze: " ++ show modulesToAnalyze) return modulesToAnalyze where ananame = analysisName analysis -- Checks whether the analysis file is up-to-date. -- Returns True if the analysis file is newer than the source file -- and the FlatCurry file (if is exists). isAnalysisFileNewer :: String -> String -> IO Bool isAnalysisFileNewer ananame modname = do atime <- getAnaFileTime ananame modname stime <- getSourceFileTime modname ftime <- getFlatCurryFileTime modname return (isAnalysisFileTimeNewer (snd atime) (Just (snd stime)) (snd ftime)) -- Is the analysis file time up-to-date w.r.t. the file times of -- the source file and the FlatCurry file? -- Returns True if the analysis file is newer than the source file -- and the FlatCurry file (if is exists). isAnalysisFileTimeNewer :: Maybe ClockTime -> Maybe ClockTime -> Maybe ClockTime -> Bool isAnalysisFileTimeNewer anatime srctime fcytime = anatime >= srctime && anatime >= fcytime -- Read current import dependencies and checks whether the current analysis -- file is valid, i.e., it is newer than the source and FlatCurry files -- of all (directly and indirectly) imported modules. isAnalysisValid :: String -> String -> IO Bool isAnalysisValid ananame modname = getImportModuleListFile modname >>= maybe (return False) (\importListFile -> do itime <- getModificationTime importListFile stime <- getSourceFileTime modname >>= return . snd if itime>=stime then do implist <- readFile importListFile >>= return . readQTerm sourceTimeList <- mapM getSourceFileTime implist fcyTimeList <- mapM getFlatCurryFileTime implist anaTimeList <- mapM (getAnaFileTime ananame) implist return (all (\ (x,y,z) -> isAnalysisFileTimeNewer x y z) (zip3 (map snd anaTimeList) (map (Just . snd) sourceTimeList) (map snd fcyTimeList))) else return False) --- Gets the list of all modules required by the first module. --- The result is sorted according to their dependencies --- (Prelude first, main module last) getDependencyList :: [String] -> [(String,[String])] -> IO [(String,[String])] getDependencyList [] moddeps = return moddeps getDependencyList (mname:mods) moddeps = maybe (do --debugMessage 3 ("Getting imports of "++ mname) --debugMessage 3 ("Still to do: "++ show mods) imports <- getImports mname getDependencyList (addNewMods mods imports) ((mname,imports):moddeps)) (\ (newmoddeps,imps) -> getDependencyList (addNewMods mods imps) newmoddeps) (lookupAndReorder mname [] moddeps) -- add new modules if they are not already there: addNewMods :: [String] -> [String] -> [String] addNewMods oldmods newmods = oldmods ++ filter (`notElem` oldmods) newmods lookupAndReorder :: String -> [(String, [String])] -> [(String, [String])] -> Maybe ([(String, [String])], [String]) lookupAndReorder _ _ [] = Nothing lookupAndReorder mname list1 ((amod,amodimports):rest) | mname==amod = Just ((amod,amodimports):reverse list1++rest, amodimports) | otherwise = lookupAndReorder mname ((amod,amodimports):list1) rest -- get timestamp of analysis file getAnaFileTime :: String -> String -> IO (String,Maybe ClockTime) getAnaFileTime anaName moduleName = do fileName <- getAnalysisPublicFile moduleName anaName fileExists <- doesFileExist fileName if fileExists then do time <- getModificationTime fileName return (moduleName,Just time) else return (moduleName,Nothing) -- check if analysis result of a module can be loaded or needs to be -- newly analyzed findModulesToAnalyze :: [(String,[String])] -> [(String,Maybe ClockTime)] -> [(String,ClockTime)] -> [(String,Maybe ClockTime)] -> ([(String,[String])],[String]) -> ([(String,[String])],[String]) findModulesToAnalyze [] _ _ _ (modulesToDo,modulesUpToDate) = (reverse modulesToDo, modulesUpToDate) findModulesToAnalyze (m@(mod,imports):ms) anaTimeList sourceTimeList fcyTimeList (modulesToDo,modulesUpToDate) = case (lookup mod anaTimeList) of Just Nothing -> findModulesToAnalyze ms anaTimeList sourceTimeList fcyTimeList ((m:modulesToDo),modulesUpToDate) Just (Just time) -> if checkTime mod time imports anaTimeList sourceTimeList fcyTimeList modulesToDo then findModulesToAnalyze ms anaTimeList sourceTimeList fcyTimeList (modulesToDo,(mod:modulesUpToDate)) else findModulesToAnalyze ms anaTimeList sourceTimeList fcyTimeList ((m:modulesToDo),modulesUpToDate) Nothing -> error "Internal error in AnalysisDependencies.findModulesToAnalyz" -- function to check if result file is up-to-date -- compares timestamp of analysis result file with module source/FlatCurry file -- and with timpestamp of result files of all imported modules checkTime :: String -> ClockTime -> [String] -> [(String,Maybe ClockTime)] -> [(String,ClockTime)] -> [(String,Maybe ClockTime)] -> [(String,[String])] -> Bool checkTime mod time1 [] _ sourceTimeList fcyTimeList _ = isAnalysisFileTimeNewer (Just time1) (lookup mod sourceTimeList) (fromMaybe Nothing (lookup mod fcyTimeList)) checkTime mod time1 (impt:impts) anaTimeList sourceTimeList fcyTimeList resultList = (lookup impt resultList) == Nothing && (Just time1) >= (fromMaybe Nothing (lookup impt anaTimeList)) && checkTime mod time1 impts anaTimeList sourceTimeList fcyTimeList resultList ----------------------------------------------------------------------- -- Remove the module analysis dependencies (first argument) w.r.t. -- a list of modules that are already analyzed (second argument). reduceDependencies :: [(String,[String])] -> [String] -> [(String,[String])] reduceDependencies modulesToDo [] = modulesToDo reduceDependencies modulesToDo (mod:mods) = let modulesToDo2 = map (\ (m,list) -> (m,(delete mod list))) modulesToDo in reduceDependencies modulesToDo2 mods curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/Doc.curry000066400000000000000000000021251377556325500245460ustar00rootroot00000000000000-------------------------------------------------------------------------- --- This module contains operations to deal with the documentation --- of analyses registered in CASS. --- --- @author Michael Hanus --- @version July 2016 -------------------------------------------------------------------------- module CASS.Doc(getAnalysisDoc) where import System.Directory (doesFileExist) import System.FilePath ((), (<.>)) import CASS.Configuration (docDir) -------------------------------------------------------------------------- --- Gets the documentation of an analysis with a registered name. --- Returns `Nothing` if no documentation exist. --- The documentation of an analysis with name AN is usually stored --- in the file `/docs/AN.md`. getAnalysisDoc :: String -> IO (Maybe String) getAnalysisDoc aname = do let docfilename = docDir aname <.> "md" docfileexists <- doesFileExist docfilename if docfileexists then readFile docfilename >>= return . Just else return Nothing -------------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/FlatCurryDependency.curry000066400000000000000000000054431377556325500277610ustar00rootroot00000000000000----------------------------------------------------------------------------- --- A few base functions for analysing type dependencies in FlatCurry programs. --- --- @author Heiko Hoffmann, Michael Hanus --- @version Junes 2017 ----------------------------------------------------------------------------- module CASS.FlatCurryDependency(dependsDirectlyOnTypes,callsDirectly) where import FlatCurry.Types import Data.List ( nub ) import Prelude hiding (empty) import Data.Set.RBTree ( SetRBT, empty, insert, toList, union) --- Return the type constructors occurring in a type declaration. dependsDirectlyOnTypes :: TypeDecl -> [QName] dependsDirectlyOnTypes (Type _ _ _ consDeclList) = nub (concatMap (\ (Cons _ _ _ typeExprs) -> concatMap tconsOf typeExprs) consDeclList) dependsDirectlyOnTypes (TypeSyn _ _ _ typeExpr) = nub (tconsOf typeExpr) dependsDirectlyOnTypes (TypeNew _ _ _ (NewCons _ _ typeExpr)) = nub (tconsOf typeExpr) tconsOf :: TypeExpr -> [QName] tconsOf (TVar _) = [] tconsOf (FuncType a b) = tconsOf a ++ tconsOf b tconsOf (TCons qName texps) = qName : concatMap tconsOf texps tconsOf (ForallType _ te) = tconsOf te ----------------------------------------------------------------------------- -- list of direct dependencies for a function callsDirectly :: FuncDecl -> [QName] callsDirectly fun = toList (snd (directlyDependent fun)) -- set of direct dependencies for a function directlyDependent :: FuncDecl -> (QName,SetRBT QName) directlyDependent (Func f _ _ _ (Rule _ e)) = (f,funcSetOfExpr e) directlyDependent (Func f _ _ _ (External _)) = (f,emptySet) -- Gets the set of all functions (including partially applied functions) -- called in an expression: funcSetOfExpr :: Expr -> SetRBT QName funcSetOfExpr (Var _) = emptySet funcSetOfExpr (Lit _) = emptySet funcSetOfExpr (Comb ct f es) = if isConstructorComb ct then unionMap funcSetOfExpr es else insert f (unionMap funcSetOfExpr es) funcSetOfExpr (Free _ e) = funcSetOfExpr e funcSetOfExpr (Let bs e) = union (unionMap (funcSetOfExpr . snd) bs) (funcSetOfExpr e) funcSetOfExpr (Or e1 e2) = union (funcSetOfExpr e1) (funcSetOfExpr e2) funcSetOfExpr (Case _ e bs) = union (funcSetOfExpr e) (unionMap funcSetOfBranch bs) where funcSetOfBranch (Branch _ be) = funcSetOfExpr be funcSetOfExpr (Typed e _) = funcSetOfExpr e isConstructorComb :: CombType -> Bool isConstructorComb ct = case ct of ConsCall -> True ConsPartCall _ -> True _ -> False unionMap :: (a -> SetRBT QName) -> [a] -> SetRBT QName unionMap f = foldr union emptySet . map f emptySet :: SetRBT QName emptySet = empty leqQName leqQName :: QName -> QName -> Bool leqQName (m1,n1) (m2,n2) = m1++('.':n1) <= m2++('.':n2) curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/Main.curry000066400000000000000000000173721377556325500247370ustar00rootroot00000000000000-------------------------------------------------------------------------- --- This is the main module to start the executable of the analysis system. --- --- @author Michael Hanus --- @version December 2018 -------------------------------------------------------------------------- module CASS.Main ( main ) where import Data.Char ( toLower ) import Data.List ( isPrefixOf, sort ) import Control.Monad ( when, unless ) import System.FilePath ( (), (<.>) ) import System.Process ( exitWith ) import System.Environment ( getArgs ) import System.Console.GetOpt import Numeric ( readNat ) import ReadShowTerm ( readQTerm ) import Analysis.Files ( deleteAllAnalysisFiles ) import Analysis.Logging ( debugMessage ) import CASS.Doc ( getAnalysisDoc ) import CASS.Server import CASS.Configuration import CASS.Registry import CASS.Worker ( startWorker ) import System.CurryPath ( stripCurrySuffix ) --- Main function to start the analysis system. --- With option -s or --server, the server is started on a socket. --- Otherwise, it is started in batch mode to analyze a single module. main :: IO () main = do argv <- getArgs let (funopts, args, opterrors) = getOpt Permute options argv let opts = foldl (flip id) defaultOptions funopts unless (null opterrors) (putStr (unlines opterrors) >> putStr usageText >> exitWith 1) initializeAnalysisSystem when (optHelp opts) (printHelp args >> exitWith 1) when (optDelete opts) (deleteFiles args) when ((optServer opts && not (null args)) || (not (optServer opts) && length args /= 2)) (error "Illegal arguments (try `-h' for help)" >> exitWith 1) when (optWorker opts && length args /= 2) (error "Illegal arguments (try `-h' for help)" >> exitWith 1) mapM_ (\ (k,v) -> updateCurrentProperty k v) (optProp opts) let verb = optVerb opts when (verb >= 0) (updateCurrentProperty "debugLevel" (show verb)) debugMessage 1 systemBanner if optServer opts then mainServer (let p = optPort opts in if p == 0 then Nothing else Just p) else if optWorker opts then startWorker (head args) (readQTerm (args!!1)) else do let [ananame,mname] = args fullananame <- checkAnalysisName ananame putStrLn $ "Computing results for analysis `" ++ fullananame ++ "'" analyzeModuleAsText fullananame (stripCurrySuffix mname) (optAll opts) (optReAna opts) >>= putStrLn where deleteFiles args = case args of [aname] -> do fullaname <- checkAnalysisName aname putStrLn $ "Deleting files for analysis `" ++ fullaname ++ "'" deleteAllAnalysisFiles fullaname exitWith 0 [] -> error "Missing analysis name!" _ -> error "Too many arguments (only analysis name should be given)!" -- Checks whether a given analysis name is a unique abbreviation -- of a registered analysis name and return the registered name. -- Otherwise, raise an error. checkAnalysisName :: String -> IO String checkAnalysisName aname = case matchedNames of [] -> error $ "Unknown analysis name `"++ aname ++ "' " ++ tryCmt [raname] -> return raname (_:_:_) -> error $ "Analysis name `"++ aname ++ "' not unique " ++ tryCmt ++ ":\nPossible names are: " ++ unwords matchedNames where matchedNames = filter (isPrefixOf (map toLower aname) . map toLower) registeredAnalysisNames tryCmt = "(try `-h' for help)" -------------------------------------------------------------------------- -- Representation of command line options. data Options = Options { optHelp :: Bool -- print help? , optVerb :: Int -- verbosity level , optServer :: Bool -- start CASS in server mode? , optWorker :: Bool -- start CASS in worker mode? , optPort :: Int -- port number (if used in server mode) , optAll :: Bool -- show analysis results for all operations? , optReAna :: Bool -- force re-analysis? , optDelete :: Bool -- delete analysis files? , optProp :: [(String,String)] -- property (of ~/.curryanalsisrc) to be set } -- Default command line options. defaultOptions :: Options defaultOptions = Options { optHelp = False , optVerb = -1 , optServer = False , optWorker = False , optPort = 0 , optAll = False , optReAna = False , optDelete = False , optProp = [] } -- Definition of actual command line options. options :: [OptDescr (Options -> Options)] options = [ Option "h?" ["help"] (NoArg (\opts -> opts { optHelp = True })) "print help and exit" , Option "q" ["quiet"] (NoArg (\opts -> opts { optVerb = 0 })) "run quietly (no output)" , Option "v" ["verbosity"] (ReqArg (safeReadNat checkVerb) "") "verbosity/debug level:\n0: quiet (same as `-q')\n1: show worker activity, e.g., timings\n2: show server communication\n3: ...and show read/store information\n4: ...show also stored/computed analysis data\n(default: see debugLevel in ~/.curryanalysisrc)" , Option "a" ["all"] (NoArg (\opts -> opts { optAll = True })) "show-analysis results for all operations\n(i.e., also for non-exported operations)" , Option "r" ["reanalyze"] (NoArg (\opts -> opts { optReAna = True })) "force re-analysis \n(i.e., ignore old analysis information)" , Option "d" ["delete"] (NoArg (\opts -> opts { optDelete = True })) "delete existing analysis results" , Option "s" ["server"] (NoArg (\opts -> opts { optServer = True })) "start analysis system in server mode" , Option "w" ["worker"] (NoArg (\opts -> opts { optWorker = True })) "start analysis system in worker mode" , Option "p" ["port"] (ReqArg (safeReadNat (\n opts -> opts { optPort = n })) "") "port number for communication\n(only for server mode;\n if omitted, a free port number is selected)" , Option "D" [] (ReqArg checkSetProperty "name=v") "set property (of ~/.curryanalysisrc)\n`name' as `v'" ] where safeReadNat opttrans s opts = case readNat s of [(n,"")] -> opttrans n opts _ -> error "Illegal number argument (try `-h' for help)" checkVerb n opts = if n>=0 && n<5 then opts { optVerb = n } else error "Illegal verbosity level (try `-h' for help)" checkSetProperty s opts = let (key,eqvalue) = break (=='=') s in if null eqvalue then error "Illegal property setting (try `-h' for help)" else opts { optProp = optProp opts ++ [(key,tail eqvalue)] } -------------------------------------------------------------------------- -- Printing help: printHelp :: [String] -> IO () printHelp args = if null args then putStrLn $ systemBanner ++ "\n" ++ usageText else do aname <- checkAnalysisName (head args) getAnalysisDoc aname >>= maybe (putStrLn $ "Sorry, no documentation for analysis `" ++ aname ++ "'") putStrLn -- Help text usageText :: String usageText = usageInfo ("Usage: curry analyze \n" ++ " or: curry analyze [-s|--server]\n" ++ " or: curry analyze [-w|--worker] \n") options ++ unlines ("" : "Registered analyses names:" : "(use option `-h ' for more documentation)" : "" : map showAnaInfo (sort registeredAnalysisInfos)) where maxName = foldr1 max (map (length . fst) registeredAnalysisInfos) + 1 showAnaInfo (n,t) = n ++ take (maxName - length n) (repeat ' ') ++ ": " ++ t -------------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/PackageConfig.curry000066400000000000000000000010711377556325500265210ustar00rootroot00000000000000module CASS.PackageConfig where import Curry.Compiler.Distribution ( installDir ) import System.FilePath ( () ) --- Package version as a string. packageVersion :: String packageVersion = "3.0.0" --- Package location. packagePath :: String packagePath = installDir "currytools" "optimize" ".cpm" "packages" "cass" --- Location of the executable installed by this package. packageExecutable :: String packageExecutable = "" --- Load path for the package (if it is the main package). packageLoadPath :: String packageLoadPath = "" curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/Registry.curry000066400000000000000000000276111377556325500256600ustar00rootroot00000000000000-------------------------------------------------------------------- --- This module collects all analyses in the analysis system. --- --- Each analysis available in the analysis system must be --- registered in the top part of this module. --- --- @author Heiko Hoffmann, Michael Hanus --- @version September 2018 -------------------------------------------------------------------- module CASS.Registry ( functionAnalysisInfos, registeredAnalysisNames, registeredAnalysisInfos , lookupRegAnaWorker, runAnalysisWithWorkers, analyzeMain ) where import FlatCurry.Types import FlatCurry.Goodies(progImports) import System.IO import System.IOExts import Control.Monad import XML import Analysis.Logging (debugMessage) import Analysis.Files (getImports, loadCompleteAnalysis) import Analysis.ProgInfo import Analysis.Types import CASS.Configuration(numberOfWorkers) import CASS.Dependencies(getModulesToAnalyze) import CASS.ServerFunctions(masterLoop) import CASS.WorkerFunctions(analysisClient) -------------------------------------------------------------------- -- Configurable part of this module. -------------------------------------------------------------------- import Analysis.Demandedness import Analysis.Deterministic import Analysis.Groundness import Analysis.HigherOrder import Analysis.Indeterministic import Analysis.RequiredValue import qualified Analysis.RequiredValues as RVS import Analysis.RightLinearity import Analysis.Residuation import Analysis.RootReplaced import Analysis.SensibleTypes import Analysis.SolutionCompleteness import Analysis.Termination import Analysis.TotallyDefined import Analysis.TypeUsage import Analysis.UnsafeModule -------------------------------------------------------------------- --- Each analysis used in our tool must be registered in this list --- together with an operation to show the analysis result as a string. registeredAnalysis :: [RegisteredAnalysis] registeredAnalysis = [cassAnalysis "Functionally defined" functionalAnalysis showFunctional ,cassAnalysis "Overlapping rules" overlapAnalysis showOverlap ,cassAnalysis "Deterministic operations" nondetAnalysis showDet ,cassAnalysis "Depends on non-deterministic operations" nondetDepAnalysis showNonDetDeps ,cassAnalysis "Depends on all non-deterministic operations" nondetDepAllAnalysis showNonDetDeps ,cassAnalysis "Right-linear operations" rlinAnalysis showRightLinear ,cassAnalysis "Solution completeness" solcompAnalysis showSolComplete ,cassAnalysis "Pattern completeness" patCompAnalysis showComplete ,cassAnalysis "Totally defined operations" totalAnalysis showTotally ,cassAnalysis "Indeterministic operations" indetAnalysis showIndet ,cassAnalysis "Demanded arguments" demandAnalysis showDemand ,cassAnalysis "Groundness" groundAnalysis showGround ,cassAnalysis "Non-determinism effects" ndEffectAnalysis showNDEffect ,cassAnalysis "Higher-order datatypes" hiOrdType showOrder ,cassAnalysis "Higher-order constructors" hiOrdCons showOrder ,cassAnalysis "Higher-order functions" hiOrdFunc showOrder ,cassAnalysis "Productive operations" productivityAnalysis showProductivity ,cassAnalysis "Sensible types" sensibleType showSensible ,cassAnalysis "Sibling constructors" siblingCons showSibling ,cassAnalysis "Required value" reqValueAnalysis showAFType ,cassAnalysis "Required value sets" RVS.reqValueAnalysis RVS.showAFType ,cassAnalysis "Residuating operations" residuationAnalysis showResInfo ,cassAnalysis "Root cyclic replacements" rootCyclicAnalysis showRootCyclic ,cassAnalysis "Root replacements" rootReplAnalysis showRootRepl ,cassAnalysis "Terminating operations" terminationAnalysis showTermination ,cassAnalysis "Types in values" typesInValuesAnalysis showTypeNames ,cassAnalysis "Unsafe module" unsafeModuleAnalysis showUnsafe ] -------------------------------------------------------------------- -- Static part of this module follows below -------------------------------------------------------------------- --- This auxiliary operation creates a new program analysis to be used --- by the server/client analysis tool from a given analysis and --- analysis show function. The first argument is a short title for the --- analysis. cassAnalysis :: (Read a, Show a, Eq a) => String -> Analysis a -> (AOutFormat -> a -> String) -> RegisteredAnalysis cassAnalysis title analysis showres = RegAna (analysisName analysis) (isFunctionAnalysis analysis) title (analyzeAsString analysis showres) (analysisClient analysis) --- The type of all registered analysis. --- The components are as follows: --- * the name of the analysis --- * is this a function analysis? --- * a long meaningful title of the analysis --- * the operation used by the server to distribute analysis work --- to the clients --- * the worker operation to analyze a list of modules data RegisteredAnalysis = RegAna String Bool String (String -> Bool -> [Handle] -> Maybe AOutFormat -> IO (Either (ProgInfo String) String)) ([String] -> IO ()) regAnaName :: RegisteredAnalysis -> String regAnaName (RegAna n _ _ _ _) = n regAnaInfo :: RegisteredAnalysis -> (String,String) regAnaInfo (RegAna n _ t _ _) = (n,t) regAnaFunc :: RegisteredAnalysis -> Bool regAnaFunc (RegAna _ fa _ _ _) = fa regAnaServer :: RegisteredAnalysis -> (String -> Bool -> [Handle] -> Maybe AOutFormat -> IO (Either (ProgInfo String) String)) regAnaServer (RegAna _ _ _ a _) = a regAnaWorker :: RegisteredAnalysis -> ([String] -> IO ()) regAnaWorker (RegAna _ _ _ _ a) = a --- Names of all registered analyses. registeredAnalysisNames :: [String] registeredAnalysisNames = map regAnaName registeredAnalysis --- Names and titles of all registered analyses. registeredAnalysisInfos :: [(String,String)] registeredAnalysisInfos = map regAnaInfo registeredAnalysis --- Names and titles of all registered function analyses. functionAnalysisInfos :: [(String,String)] functionAnalysisInfos = map regAnaInfo (filter regAnaFunc registeredAnalysis) lookupRegAna :: String -> [RegisteredAnalysis] -> Maybe RegisteredAnalysis lookupRegAna _ [] = Nothing lookupRegAna aname (ra@(RegAna raname _ _ _ _) : ras) = if aname==raname then Just ra else lookupRegAna aname ras -- Look up a registered analysis server with a given analysis name. lookupRegAnaServer :: String -> (String -> Bool -> [Handle] -> Maybe AOutFormat -> IO (Either (ProgInfo String) String)) lookupRegAnaServer aname = maybe (\_ _ _ _ -> return (Right ("unknown analysis: "++aname))) regAnaServer (lookupRegAna aname registeredAnalysis) -- Look up a registered analysis worker with a given analysis name. lookupRegAnaWorker :: String -> ([String] -> IO ()) lookupRegAnaWorker aname = maybe (const (return ())) regAnaWorker (lookupRegAna aname registeredAnalysis) -------------------------------------------------------------------- -- Run an analysis with a given name on a given module with a list -- of workers identified by their handles and return the analysis results. runAnalysisWithWorkers :: String -> AOutFormat -> Bool -> [Handle] -> String -> IO (Either (ProgInfo String) String) runAnalysisWithWorkers ananame aoutformat enforce handles moduleName = (lookupRegAnaServer ananame) moduleName enforce handles (Just aoutformat) -- Run an analysis with a given name on a given module with a list -- of workers identified by their handles but do not load analysis results. runAnalysisWithWorkersNoLoad :: String -> [Handle] -> String -> IO () runAnalysisWithWorkersNoLoad ananame handles moduleName = () <$ (lookupRegAnaServer ananame) moduleName False handles Nothing --- Generic operation to analyze a module. --- The parameters are the analysis, the show operation for analysis results, --- the name of the main module to be analyzed, --- a flag indicating whether the (re-)analysis should be enforced, --- the handles for the workers, --- and a flag indicating whether the analysis results should be loaded --- and returned (if the flag is false, the result contains the empty --- program information). --- An error occurred during the analysis is returned as `(Right ...)`. analyzeAsString :: (Read a, Show a) => Analysis a -> (AOutFormat->a->String) -> String -> Bool -> [Handle] -> Maybe AOutFormat -> IO (Either (ProgInfo String) String) analyzeAsString analysis showres modname enforce handles mbaoutformat = do analyzeMain analysis modname handles enforce (mbaoutformat /= Nothing) >>= return . either (Left . mapProgInfo (showres aoutformat)) Right where aoutformat = maybe AText id mbaoutformat --- Generic operation to analyze a module. --- The parameters are the analysis, the name of the main module --- to be analyzed, the handles for the workers, --- a flag indicating whether the (re-)analysis should be enforced, --- and a flag indicating whether the analysis results should be loaded --- and returned (if the flag is false, the result contains the empty --- program information). --- An error occurred during the analysis is returned as `(Right ...)`. analyzeMain :: (Read a, Show a) => Analysis a -> String -> [Handle] -> Bool -> Bool -> IO (Either (ProgInfo a) String) analyzeMain analysis modname handles enforce load = do let ananame = analysisName analysis debugMessage 2 ("Start analysis: "++modname++"/"++ananame) modulesToDo <- getModulesToAnalyze enforce analysis modname let numModules = length modulesToDo workresult <- if numModules==0 then return Nothing else do when (numModules>1) $ debugMessage 1 ("Number of modules to be analyzed: " ++ show numModules) prepareCombinedAnalysis analysis modname (map fst modulesToDo) handles numworkers <- numberOfWorkers if numworkers>0 then do debugMessage 2 "Starting master loop" masterLoop handles [] ananame modname modulesToDo [] else analyzeLocally ananame (map fst modulesToDo) result <- maybe (if load then do debugMessage 3 ("Reading analysis of: "++modname) loadCompleteAnalysis ananame modname >>= return . Left else return (Left emptyProgInfo)) (return . Right) workresult debugMessage 4 ("Result: " ++ either showProgInfo id result) return result -- Analyze a module and all its imports locally without worker processes. analyzeLocally :: String -> [String] -> IO (Maybe String) analyzeLocally ananame modules = do debugMessage 3 ("Local analysis of: "++ananame++"/"++show modules) (lookupRegAnaWorker ananame) modules -- run client return Nothing -- Perform the first analysis part of a combined analysis -- so that their results are available for the main analysis. prepareCombinedAnalysis:: Analysis a -> String -> [String] -> [Handle] -> IO () prepareCombinedAnalysis analysis moduleName depmods handles = if isCombinedAnalysis analysis then if isSimpleAnalysis analysis then do -- the directly imported interface information might be required... importedModules <- getImports moduleName mapM_ (\basename -> mapM_ (runAnalysisWithWorkersNoLoad basename handles) (importedModules++[moduleName])) baseAnaNames else -- for a dependency analysis, the information of all implicitly -- imported modules might be required: mapM_ (\baseaname -> mapM_ (runAnalysisWithWorkersNoLoad baseaname handles) depmods) baseAnaNames else return () where baseAnaNames = baseAnalysisNames analysis -------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/Server.curry000066400000000000000000000334401377556325500253130ustar00rootroot00000000000000-------------------------------------------------------------------------- --- This is the main module of the analysis server. --- It provides operations to initialize the server system, --- start the server on a socket, or use the analysis server --- by other Curry applications. --- --- @author Heiko Hoffmann, Michael Hanus --- @version December 2020 -------------------------------------------------------------------------- module CASS.Server (mainServer, initializeAnalysisSystem, analyzeModuleAsText , analyzeModuleForBrowser, analyzeFunctionForBrowser , analyzeGeneric, analyzePublic, analyzeInterface ) where import Numeric ( readNat ) import ReadShowTerm ( readQTerm, showQTerm ) import Data.Char ( isSpace ) import Control.Monad ( unless ) import System.CurryPath ( runModuleAction ) import System.Directory import System.FilePath import System.IO import System.Process ( system, sleep ) import System.Environment import Analysis.Logging ( debugMessage ) import Analysis.ProgInfo import Analysis.Types ( Analysis, AOutFormat(..) ) import FlatCurry.Types ( QName ) import Network.Socket ( Socket(..), listenOn, listenOnFresh , close, waitForSocketAccept ) import CASS.Configuration import CASS.Registry import CASS.ServerFormats import CASS.ServerFunctions(WorkerMessage(..)) -- Messages to communicate with the analysis server from external programs. data AnalysisServerMessage = GetAnalysis | AnalyzeModule String String String Bool | AnalyzeEntity String String String String | StopServer | SetCurryPath String | ParseError --- Initializations to be done when the system is started. initializeAnalysisSystem :: IO () initializeAnalysisSystem = updateRCFile --- Start the analysis server on a socket. mainServer :: Maybe Int -> IO () mainServer mbport = do putStrLn "Start Server" (port1,socket1) <- maybe listenOnFresh (\p -> listenOn p >>= \s -> return (p,s)) mbport putStrLn ("Server Port: "++show port1) storeServerPortNumber port1 getDefaultPath >>= setEnv "CURRYPATH" numworkers <- numberOfWorkers if numworkers>0 then do serveraddress <- getServerAddress (workerport,workersocket) <- listenOnFresh debugMessage 2 ("SERVER: port to workers: "++show workerport) handles <- startWorkers numworkers workersocket serveraddress workerport [] serverLoop socket1 handles close workersocket else serverLoop socket1 [] --- Run the analysis system and show the analysis results in standard textual --- representation. --- If the third argument is true, all operations are shown, --- otherwise only the interface operations. --- The fourth argument is a flag indicating whether the --- (re-)analysis should be enforced. --- Note that, before its first use, the analysis system must be initialized --- by 'initializeAnalysisSystem'. analyzeModuleAsText :: String -> String -> Bool -> Bool -> IO String analyzeModuleAsText ananame mname optall enforce = analyzeProgram ananame enforce AText mname >>= return . formatResult mname "Text" Nothing (not optall) --- Run the analysis system to show the analysis results in the BrowserGUI. --- Note that, before its first use, the analysis system must be initialized --- by 'initializeAnalysisSystem'. analyzeModuleForBrowser :: String -> String -> AOutFormat -> IO [(QName,String)] analyzeModuleForBrowser ananame mname aoutformat = analyzeProgram ananame False aoutformat mname >>= return . either pinfo2list (const []) where pinfo2list pinfo = let (pubinfo,privinfo) = progInfo2Lists pinfo in pubinfo++privinfo --- Run the analysis system to show the analysis result of a single function --- in the BrowserGUI. --- Note that before its first use, the analysis system must be initialized --- by 'initializeAnalysisSystem'. analyzeFunctionForBrowser :: String -> QName -> AOutFormat -> IO String analyzeFunctionForBrowser ananame qn@(mname,_) aoutformat = do analyzeProgram ananame False aoutformat mname >>= return . either (maybe "" id . lookupProgInfo qn) (const "") --- Analyze a given program (i.e., a module possibly prefixed with a --- directory name) for a given analysis result format. --- The third argument is a flag indicating whether the --- (re-)analysis should be enforced. --- Note that before its first use, the analysis system must be initialized --- by 'initializeAnalysisSystem'. analyzeProgram :: String -> Bool -> AOutFormat -> String -> IO (Either (ProgInfo String) String) analyzeProgram ananame enforce aoutformat progname = runModuleAction (analyzeModule ananame enforce aoutformat) progname --- Analyze a complete module for a given analysis result format. --- The second argument is a flag indicating whether the --- (re-)analysis should be enforced. --- Note that before its first use, the analysis system must be initialized --- by 'initializeAnalysisSystem'. analyzeModule :: String -> Bool -> AOutFormat -> String -> IO (Either (ProgInfo String) String) analyzeModule ananame enforce aoutformat modname = do getDefaultPath >>= setEnv "CURRYPATH" numworkers <- numberOfWorkers if numworkers>0 then do serveraddress <- getServerAddress (port,socket) <- listenOnFresh handles <- startWorkers numworkers socket serveraddress port [] result <- runAnalysisWithWorkers ananame aoutformat enforce handles modname stopWorkers handles close socket return result else runAnalysisWithWorkers ananame aoutformat enforce [] modname --- Start the analysis system with a particular analysis. --- The analysis must be a registered one if workers are used. --- If it is a combined analysis, the base analysis must be also --- a registered one. --- Returns either the analysis information or an error message. analyzeGeneric :: (Read a, Show a) => Analysis a -> String -> IO (Either (ProgInfo a) String) analyzeGeneric analysis moduleName = do initializeAnalysisSystem let (mdir,mname) = splitFileName moduleName getDefaultPath >>= setEnv "CURRYPATH" curdir <- getCurrentDirectory unless (mdir==".") $ setCurrentDirectory mdir numworkers <- numberOfWorkers aresult <- if numworkers>0 then do serveraddress <- getServerAddress (port,socket) <- listenOnFresh handles <- startWorkers numworkers socket serveraddress port [] result <- analyzeMain analysis mname handles False True stopWorkers handles close socket return result else analyzeMain analysis mname [] False True setCurrentDirectory curdir return aresult --- Start the analysis system with a given analysis to compute properties --- of a module interface. --- The analysis must be a registered one if workers are used. --- If it is a combined analysis, the base analysis must be also --- a registered one. --- Returns either the analysis information or an error message. analyzePublic :: (Read a, Show a) => Analysis a -> String -> IO (Either (ProgInfo a) String) analyzePublic analysis moduleName = analyzeGeneric analysis moduleName >>= return . either (Left . publicProgInfo) Right --- Start the analysis system with a given analysis to compute properties --- of a module interface. --- The analysis must be a registered one if workers are used. --- If it is a combined analysis, the base analysis must be also --- a registered one. analyzeInterface :: (Read a, Show a) => Analysis a -> String -> IO (Either [(QName,a)] String) analyzeInterface analysis moduleName = analyzeGeneric analysis moduleName >>= return . either (Left . publicListFromProgInfo) Right -------------------------------------------------------------------------- -- start a number of workers at server start startWorkers:: Int -> Socket -> String -> Int -> [Handle] -> IO [Handle] startWorkers number workersocket serveraddress workerport handles = do if number>0 then do debugMessage 4 ("Number:"++(show number)) let command = unwords [ executableName, " --worker " , serveraddress, show workerport, "&" ] debugMessage 4 ("system command: "++command) system command debugMessage 4 ("Wait for socket accept for client "++show number) connection <- waitForSocketAccept workersocket waitTime debugMessage 4 ("Socket accept for client "++show number) case connection of Just (_,handle) -> do startWorkers (number-1) workersocket serveraddress workerport (handle:handles) Nothing -> do putStrLn ("startWorkers: connection error worker "++(show number)) startWorkers (number-1) workersocket serveraddress workerport handles else return handles -- stop all workers at server stop stopWorkers :: [Handle] -> IO () stopWorkers [] = return () stopWorkers (handle:whandles) = do hPutStrLn handle (showQTerm StopWorker) hClose handle stopWorkers whandles -------------------------------------------------------------------------- -- server loop to answer analysis requests over network serverLoop :: Socket -> [Handle] -> IO () serverLoop socket1 whandles = do --debugMessage 3 "SERVER: serverLoop" connection <- waitForSocketAccept socket1 waitTime case connection of Just (_,handle) -> serverLoopOnHandle socket1 whandles handle Nothing -> do putStrLn "serverLoop: connection error: time out in waitForSocketAccept" sleep 1 serverLoop socket1 whandles --- Reads a line from an input handle and returns it. hGetLineUntilEOF :: Handle -> IO String hGetLineUntilEOF h = do eof <- hIsEOF h if eof then return "" else do c <- hGetChar h if c=='\n' then return "" else do cs <- hGetLineUntilEOF h return (c:cs) serverLoopOnHandle :: Socket -> [Handle] -> Handle -> IO () serverLoopOnHandle socket1 whandles handle = do eof <- hIsEOF handle if eof then do hClose handle debugMessage 2 "SERVER connection: eof" serverLoop socket1 whandles else do string <- hGetLineUntilEOF handle debugMessage 2 ("SERVER got message: "++string) let force = False case parseServerMessage string of ParseError -> do sendServerError handle ("Illegal message received: "++string) serverLoopOnHandle socket1 whandles handle GetAnalysis -> do sendServerResult handle showAnalysisNamesAndFormats serverLoopOnHandle socket1 whandles handle AnalyzeModule ananame outForm modname public -> catch (runAnalysisWithWorkers ananame AText force whandles modname >>= return . formatResult modname outForm Nothing public >>= sendResult) sendAnalysisError AnalyzeEntity ananame outForm modname functionName -> catch (runAnalysisWithWorkers ananame AText force whandles modname >>= return . formatResult modname outForm (Just functionName) False >>= sendResult) sendAnalysisError SetCurryPath path -> do setEnv "CURRYPATH" path changeWorkerPath path whandles sendServerResult handle "" serverLoopOnHandle socket1 whandles handle StopServer -> do stopWorkers whandles sendServerResult handle "" hClose handle close socket1 putStrLn "Stop Server" removeServerPortNumber where sendResult resultstring = do debugMessage 4 ("formatted result:\n"++resultstring) sendServerResult handle resultstring serverLoopOnHandle socket1 whandles handle sendAnalysisError err = do sendServerError handle ("ERROR in analysis server: "++ show err) serverLoopOnHandle socket1 whandles handle -- Send a server result in the format "ok \n" where -- is the number of lines of the . sendServerResult :: Handle -> String -> IO () sendServerResult handle resultstring = do let resultlines = lines resultstring hPutStrLn handle ("ok " ++ show (length resultlines)) hPutStr handle (unlines resultlines) hFlush handle -- Send a server error in the format "error \n". sendServerError :: Handle -> String -> IO () sendServerError handle errstring = do debugMessage 1 errstring hPutStrLn handle ("error "++errstring) hFlush handle -- Inform the worker threads about a given changed library search path changeWorkerPath :: String -> [Handle] -> IO () changeWorkerPath _ [] = return () changeWorkerPath path (handle:whandles) = do hPutStrLn handle (showQTerm (ChangePath path)) changeWorkerPath path whandles -- parse incoming message for type of request parseServerMessage :: String -> AnalysisServerMessage parseServerMessage message = case words message of [] -> ParseError w:ws -> case w of "GetAnalysis" -> GetAnalysis "AnalyzeModule" -> case ws of s1:s2:s3:[] -> checkFormat s2 $ AnalyzeModule s1 s2 s3 False _ -> ParseError "AnalyzeInterface" -> case ws of s1:s2:s3:[] -> checkFormat s2 $ AnalyzeModule s1 s2 s3 True _ -> ParseError "AnalyzeFunction" -> case ws of s1:s2:s3:s4:[] -> checkFormat s2 $ AnalyzeEntity s1 s2 s3 s4 _ -> ParseError "AnalyzeTypeConstructor" -> case ws of s1:s2:s3:s4:[] -> checkFormat s2 $ AnalyzeEntity s1 s2 s3 s4 _ -> ParseError "AnalyzeDataConstructor" -> case ws of s1:s2:s3:s4:[] -> checkFormat s2 $ AnalyzeEntity s1 s2 s3 s4 _ -> ParseError "SetCurryPath" -> case ws of s:[] -> SetCurryPath s _ -> ParseError "StopServer" -> StopServer _ -> ParseError where checkFormat fmt msg = if fmt `elem` serverFormats then msg else ParseError --- Show all analysis names and formats. showAnalysisNamesAndFormats :: String showAnalysisNamesAndFormats = unlines (concatMap (\an -> map ((an++" ")++) serverFormats) registeredAnalysisNames) curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/ServerFormats.curry000066400000000000000000000053341377556325500266500ustar00rootroot00000000000000-------------------------------------------------------------------- --- This module defines the various output formats offered by the --- anlysis server. --- --- @author Heiko Hoffmann, Michael Hanus --- @version January 2017 -------------------------------------------------------------------- module CASS.ServerFormats(serverFormats,formatResult) where import Analysis.ProgInfo import FlatCurry.Types ( QName, showQNameInModule ) import Data.List ( sortBy ) import XML -------------------------------------------------------------------- --- The supported formats of the analysis server: serverFormats :: [String] serverFormats = ["XML","CurryTerm","Text"] --- Format an analysis result in different formats. --- The arguments are the module name, the output format (see 'serverFormats'), --- `(Just n)` if not the complete module but the result for entity `n` --- should only be shown, and a flag which is true if only the interface --- information should be shown. formatResult :: String -> String -> Maybe String -> Bool -> (Either (ProgInfo String) String) -> String formatResult _ outForm _ _ (Right err) = let errMsg = "ERROR in analysis: " ++ err in if outForm == "XML" then showXmlDoc (xml "error" [xtxt errMsg]) else errMsg -- Format a single program entity result: formatResult moduleName outForm (Just name) _ (Left pinfo) = let lookupResult = lookupProgInfo (moduleName,name) pinfo in case lookupResult of Nothing -> ("ERROR "++name++" not found in "++moduleName) Just value -> case outForm of "CurryTerm" -> value "Text" -> value "XML" -> showXmlDoc (xml "result" [xtxt value]) _ -> error "Internal error ServerFormats.formatResult" -- Format a complete module: formatResult moduleName outForm Nothing public (Left pinfo) = case outForm of "CurryTerm" -> show entities "Text" -> formatAsText moduleName entities "XML" -> let (pubxml,privxml) = progInfo2XML pinfo in showXmlDoc (xml "results" (pubxml ++ if public then [] else privxml)) _ -> error "Internal error ServerFormats.formatResult" where entities = let (pubents,privents) = progInfo2Lists pinfo in if public then pubents else sortBy (\ (qf1,_) (qf2,_) -> qf1<=qf2) (pubents++privents) -- Format a list of analysis results as a string (lines of analysis results). formatAsText :: String -> [(QName,String)] -> String formatAsText moduleName = unlines . map (\ (qf,r) -> showQNameInModule moduleName qf ++ " : " ++ r) -------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/ServerFunctions.curry000066400000000000000000000121071377556325500272010ustar00rootroot00000000000000------------------------------------------------------------------------ --- Implementation of the analysis computations on the server side --- --- @author Heiko Hoffmann, Michael Hanus --- @version December 2018 ------------------------------------------------------------------------ -- analysis computations on the server side module CASS.ServerFunctions where import System.IO ( Handle(..), hClose, hFlush, hGetLine, hPutStrLn , hWaitForInput, hWaitForInputs ) import System.Process ( system, sleep ) import System.Directory ( doesFileExist, getModificationTime ) import Data.Maybe ( fromMaybe ) import Data.List ( delete ) import Data.Time ( ClockTime ) import XML ( showXmlDoc, xml ) import ReadShowTerm ( readQTerm, showQTerm ) import FlatCurry.Types ( QName ) import FlatCurry.Goodies ( progImports ) import Analysis.Logging ( debugMessage ) import Analysis.Types import Analysis.ProgInfo import CASS.Dependencies import CASS.Configuration ( waitTime ) data WorkerMessage = Task String String | ChangePath String | StopWorker -- Master loop for communication with workers -- Argument 1: handles for workers that are currently free -- Argument 2: handles for workers that are currently busy -- Argument 3: the analysis name -- Argument 4: the name of the main module -- Argument 5: the modules to be analyzed (with their dependencies) -- Argument 6: names of modules that are ready be to analyzed (since their -- imports are already analyzed) -- Result: Nothing (in case of successful work) or (Just ) masterLoop :: [Handle] -> [Handle] -> String -> String -> [(String,[String])] -> [String] -> IO (Maybe String) masterLoop _ [] _ _ [] [] = do debugMessage 2 "Master loop: terminated" return Nothing masterLoop _ (b:busyWorker) ananame mainModule [] [] = do debugMessage 2 "Master loop: waiting for worker result" inputHandle <- hWaitForInputs (b:busyWorker) waitTime if inputHandle/=0 then return (Just "No input from any worker received") else do let handle = b input <- hGetLine handle debugMessage 2 ("Master loop: got message: "++input) let Task ananame2 moduleName2 = readQTerm input if ananame==ananame2 && moduleName2==mainModule then return Nothing else return (Just "Received analysis does not match requested analysis") masterLoop idleWorker busyWorker ananame mainModule modulesToDo@(_:_) [] = do debugMessage 3 ("Master loop: modules to do: "++(showQTerm modulesToDo)) let modulesToDo2 = filter ((not . null) . snd) modulesToDo waitList = map fst (filter (null . snd) modulesToDo) if null waitList then do debugMessage 2 "Master loop: waiting for workers to finish" inputHandle <- hWaitForInputs busyWorker waitTime if inputHandle<0 then return (Just "No input from any worker received") else do let handle = busyWorker !! inputHandle input <- hGetLine handle debugMessage 2 ("Master loop: got message: "++input) let Task ananame2 moduleName2 = readQTerm input if ananame==ananame2 then do let modulesToDo3 = reduceDependencies modulesToDo2 [moduleName2] busyWorker2= deleteIndex inputHandle busyWorker masterLoop (handle:idleWorker) busyWorker2 ananame mainModule modulesToDo3 waitList else return (Just "Received analysis does not match requested analysis type") else masterLoop idleWorker busyWorker ananame mainModule modulesToDo2 waitList masterLoop (handle:idleWorker) busyWorker ananame mainModule modulesToDo (modName:waitList) = do debugMessage 2 "Master loop: worker available, send task to a worker..." let newTask = showQTerm (Task ananame modName) hPutStrLn handle newTask hFlush handle debugMessage 2 ("Master loop: send message: "++newTask) masterLoop idleWorker (handle:busyWorker) ananame mainModule modulesToDo waitList masterLoop [] busyWorker ananame mainModule modulesToDo waits@(modName:waitList) = do debugMessage 2 $ "Waiting for worker to analyze modules: "++show waits inputHandle <- hWaitForInputs busyWorker waitTime if inputHandle<0 then return (Just "No input from any worker received") else do let handle = busyWorker !! inputHandle input <- hGetLine handle debugMessage 2 ("Master loop: got message: "++input) let Task _ finishedmodule = readQTerm input newTask = showQTerm (Task ananame modName) hPutStrLn handle newTask hFlush handle debugMessage 2 ("Master loop: send message: "++newTask) let modulesToDo2 = reduceDependencies modulesToDo [finishedmodule] masterLoop [] busyWorker ananame mainModule modulesToDo2 waitList deleteIndex :: Int -> [a] -> [a] deleteIndex _ [] = [] deleteIndex n (x:xs) | n==0 = xs | otherwise = x : deleteIndex (n-1) xs ----------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/Worker.curry000066400000000000000000000040751377556325500253200ustar00rootroot00000000000000------------------------------------------------------------------------ --- Implementation of a worker client to analyze a module --- --- @author Heiko Hoffmann, Michael Hanus --- @version December 2018 ------------------------------------------------------------------------ module CASS.Worker(main, startWorker) where import System.IO ( Handle, hClose, hFlush, hWaitForInput , hPutStrLn, hGetLine ) import System.Environment ( getArgs, setEnv ) import ReadShowTerm ( readQTerm ) import Analysis.Logging ( debugMessage ) import Network.Socket ( connectToSocket ) import CASS.Configuration ( waitTime, getDefaultPath ) import CASS.Registry ( lookupRegAnaWorker ) import CASS.ServerFunctions ( WorkerMessage(..) ) main :: IO () main = do args <- getArgs if length args /= 2 then error "Analysis worker program started with illegal arguments" else startWorker (head args) (readQTerm (args!!1)) startWorker :: String -> Int -> IO () startWorker host port = do debugMessage 2 ("start analysis worker on port " ++ show port) getDefaultPath >>= setEnv "CURRYPATH" handle <- connectToSocket host port worker handle -- communication loop worker :: Handle -> IO () worker handle = do gotInput <- hWaitForInput handle waitTime if gotInput then do input <- hGetLine handle debugMessage 3 ("input: "++input) case readQTerm input of Task ananame moduleName -> do debugMessage 1 ("Start task: "++ananame++" for "++moduleName) -- Run the analysis worker for the given analysis and module: (lookupRegAnaWorker ananame) [moduleName] debugMessage 1 ("Finished task: "++ananame++" for "++moduleName) debugMessage 3 ("Output: "++input) hPutStrLn handle input hFlush handle worker handle ChangePath path -> do setEnv "CURRYPATH" path worker handle StopWorker -> do debugMessage 2 "Stop worker" hClose handle return () else return () curry-tools-v3.3.0/optimize/.cpm/packages/cass/src/CASS/WorkerFunctions.curry000066400000000000000000000436641377556325500272200ustar00rootroot00000000000000-------------------------------------------------------------------------- --- Operations to implement the client workers. --- In particular, it contains some simple fixpoint computations. --- --- @author Heiko Hoffmann, Michael Hanus --- @version November 2020 -------------------------------------------------------------------------- module CASS.WorkerFunctions where import Prelude import Data.List ( partition ) import Data.Maybe ( fromJust ) import System.CPUTime ( getCPUTime ) import System.IOExts import Analysis.Files import Analysis.Logging ( debugMessage, debugString ) import Analysis.Types ( Analysis(..), isSimpleAnalysis, isCombinedAnalysis , analysisName, startValue) import Analysis.ProgInfo ( ProgInfo, combineProgInfo, emptyProgInfo , publicProgInfo, lookupProgInfo, lists2ProgInfo , equalProgInfo, publicListFromProgInfo, showProgInfo ) import Data.Map as Map import FlatCurry.Types import FlatCurry.Files import FlatCurry.Goodies import Data.SCC ( scc ) import Data.Set.RBTree as Set ( SetRBT, member, empty, insert, null ) import CASS.Configuration import CASS.FlatCurryDependency ( callsDirectly, dependsDirectlyOnTypes ) ----------------------------------------------------------------------- -- Datatype to store already read ProgInfos for modules. type ProgInfoStore a = [(String,ProgInfo a)] newProgInfoStoreRef :: IO (IORef (ProgInfoStore _)) newProgInfoStoreRef = newIORef [] ----------------------------------------------------------------------- --- Analyze a list of modules (in the given order) with a given analysis. --- The analysis results are stored in the corresponding analysis result files. analysisClient :: (Eq a, Show a, Read a) => Analysis a -> [String] -> IO () analysisClient analysis modnames = do store <- newIORef [] fpmethod <- getFPMethod mapM_ (analysisClientWithStore store analysis fpmethod) modnames analysisClientWithStore :: (Eq a, Show a, Read a) => IORef (ProgInfoStore a) -> Analysis a -> String -> String -> IO () analysisClientWithStore store analysis fpmethod moduleName = do prog <- readNewestFlatCurry moduleName withprelude <- getWithPrelude let progimports = progImports prog importList = if withprelude=="no" then filter (/="Prelude") progimports else progimports ananame = analysisName analysis importInfos <- if isSimpleAnalysis analysis then return emptyProgInfo else getInterfaceInfosWS store (analysisName analysis) importList debugString 1 $ "Analysis time for " ++ ananame ++ "/" ++ moduleName ++ ": " starttime <- getCPUTime startvals <- getStartValues analysis prog result <- if isCombinedAnalysis analysis then execCombinedAnalysis analysis prog importInfos startvals moduleName fpmethod else runAnalysis analysis prog importInfos startvals fpmethod storeAnalysisResult ananame moduleName result stoptime <- getCPUTime debugMessage 1 $ show (stoptime-starttime) ++ " msecs" loadinfos <- readIORef store writeIORef store ((moduleName,publicProgInfo result):loadinfos) -- Loads analysis results for a list of modules where already read results -- are stored in an IORef. getInterfaceInfosWS :: Read a => IORef (ProgInfoStore a) -> String -> [String] -> IO (ProgInfo a) getInterfaceInfosWS _ _ [] = return emptyProgInfo getInterfaceInfosWS store anaName (mod:mods) = do loadinfos <- readIORef store modInfo <- maybe (loadAndStoreAnalysis loadinfos) return (Prelude.lookup mod loadinfos) modsInfo <- getInterfaceInfosWS store anaName mods return (combineProgInfo modInfo modsInfo) where loadAndStoreAnalysis loadinfos = do info <- loadPublicAnalysis anaName mod writeIORef store ((mod,info):loadinfos) return info ----------------------------------------------------------------------- --- Compute the start (bottom) values for a dependency analysis. getStartValues :: Analysis a -> Prog -> IO [(QName,a)] getStartValues analysis prog = if isSimpleAnalysis analysis then return [] else do let startvals = case analysis of DependencyFuncAnalysis _ _ _ -> map (\func->(funcName func,startValue analysis)) (progFuncs prog) CombinedDependencyFuncAnalysis _ _ _ _ _ -> map (\func->(funcName func,startValue analysis)) (progFuncs prog) DependencyTypeAnalysis _ _ _ -> map (\typeDecl->(typeName typeDecl,startValue analysis)) (progTypes prog) CombinedDependencyTypeAnalysis _ _ _ _ _ -> map (\typeDecl->(typeName typeDecl,startValue analysis)) (progTypes prog) _ -> error "Internal error in WorkerFunctions.getStartValues" return startvals --- Compute a ProgInfo from a given list of infos for each function name w.r.t. --- a given program. funcInfos2ProgInfo :: Prog -> [(QName,a)] -> ProgInfo a funcInfos2ProgInfo prog infos = lists2ProgInfo $ map2 (\fdecl -> let fname = funcName fdecl in (fname, fromJust (Prelude.lookup fname infos))) (partition isVisibleFunc (progFuncs prog)) --- Compute a ProgInfo from a given list of infos for each type name w.r.t. --- a given program. typeInfos2ProgInfo :: Prog -> [(QName,a)] -> ProgInfo a typeInfos2ProgInfo prog infos = lists2ProgInfo $ map2 (\tdecl -> let tname = typeName tdecl in (tname, fromJust (Prelude.lookup tname infos))) (partition isVisibleType (progTypes prog)) map2 :: (a -> b) -> ([a], [a]) -> ([b], [b]) map2 f (xs,ys) = (map f xs, map f ys) --- Update a given value list (second argument) w.r.t. new values given --- in the first argument list. updateList :: Eq a => [(a,b)] -> [(a,b)] -> [(a,b)] updateList [] oldList = oldList updateList ((key,newValue):newList) oldList = updateList newList (updateValue (key,newValue) oldList) updateValue :: Eq a => (a,b) -> [(a,b)] -> [(a,b)] updateValue _ [] = [] updateValue (key1,newValue) ((key2,value2):list) = if key1==key2 then (key1,newValue):list else (key2,value2):(updateValue (key1,newValue) list) ----------------------------------------------------------------------- execCombinedAnalysis :: Eq a => Analysis a -> Prog -> ProgInfo a -> [(QName,a)] -> String -> String -> IO (ProgInfo a) execCombinedAnalysis analysis prog importInfos startvals moduleName fpmethod = case analysis of CombinedSimpleFuncAnalysis _ ananame _ runWithBaseAna -> do anaFunc <- runWithBaseAna moduleName runAnalysis (SimpleFuncAnalysis ananame anaFunc) prog importInfos startvals fpmethod CombinedSimpleTypeAnalysis _ ananame _ runWithBaseAna -> do anaFunc <- runWithBaseAna moduleName runAnalysis (SimpleTypeAnalysis ananame anaFunc) prog importInfos startvals fpmethod CombinedDependencyFuncAnalysis _ ananame _ startval runWithBaseAna -> do anaFunc <- runWithBaseAna moduleName runAnalysis (DependencyFuncAnalysis ananame startval anaFunc) prog importInfos startvals fpmethod CombinedDependencyTypeAnalysis _ ananame _ startval runWithBaseAna -> do anaFunc <- runWithBaseAna moduleName runAnalysis (DependencyTypeAnalysis ananame startval anaFunc) prog importInfos startvals fpmethod _ -> error "Internal error in WorkerFunctions.execCombinedAnalysis" ----------------------------------------------------------------------- --- Run an analysis but load default values (e.g., for external operations) --- before and do not analyse the operations or types for these defaults. runAnalysis :: Eq a => Analysis a -> Prog -> ProgInfo a -> [(QName,a)] -> String -> IO (ProgInfo a) runAnalysis analysis prog importInfos startvals fpmethod = do deflts <- loadDefaultAnalysisValues (analysisName analysis) (progName prog) let defaultFuncs = updProgFuncs (filter (\fd -> funcName fd `elem` map fst deflts)) prog definedFuncs = updProgFuncs (filter (\fd -> funcName fd `notElem` map fst deflts)) prog defaultTypes = updProgTypes (filter (\fd -> typeName fd `elem` map fst deflts)) prog definedTypes = updProgTypes (filter (\fd -> typeName fd `notElem` map fst deflts)) prog let (progWithoutDefaults,defaultproginfo) = case analysis of SimpleFuncAnalysis _ _ -> (definedFuncs, funcInfos2ProgInfo defaultFuncs deflts) SimpleTypeAnalysis _ _ -> (definedTypes, typeInfos2ProgInfo defaultTypes deflts) SimpleConstructorAnalysis _ _ -> -- there are no external constructors if Prelude.null deflts then (prog,emptyProgInfo) else error "SimpleConstructorAnalysis with default values!" DependencyFuncAnalysis _ _ _ -> (definedFuncs, funcInfos2ProgInfo defaultFuncs deflts) DependencyTypeAnalysis _ _ _ -> (definedTypes, typeInfos2ProgInfo defaultTypes deflts) SimpleModuleAnalysis _ _ -> if Prelude.null deflts then (definedFuncs, emptyProgInfo) else error defaultNotEmptyError DependencyModuleAnalysis _ _ -> if Prelude.null deflts then (definedFuncs, emptyProgInfo) else error defaultNotEmptyError _ -> error "Internal error in WorkerFunctions.runAnalysis" let result = executeAnalysis analysis progWithoutDefaults (combineProgInfo importInfos defaultproginfo) startvals fpmethod return $ combineProgInfo defaultproginfo result where defaultNotEmptyError = "Default analysis information for analysis '" ++ analysisName analysis ++ "' and module '" ++ progName prog ++ "' not empty!" --- Executes an anlysis on a given program w.r.t. an imported ProgInfo --- and some start values (for dependency analysis). --- The fixpoint iteration method to be applied is passed as the last argument. executeAnalysis :: Eq a => Analysis a -> Prog -> ProgInfo a -> [(QName,a)] -> String -> ProgInfo a -- The results of a module analysis for module `m` are encoded as -- a `ProgInfo` with a single entry for the qualified name `m.m`. executeAnalysis (SimpleModuleAnalysis _ anaFunc) prog _ _ _ = let pname = progName prog in lists2ProgInfo ([((pname,pname), anaFunc prog)], []) executeAnalysis (DependencyModuleAnalysis _ anaFunc) prog impproginfos _ _ = let pname = progName prog importinfos = map (\ (qn,a) -> (fst qn,a)) (publicListFromProgInfo impproginfos) in lists2ProgInfo ([((pname,pname), anaFunc prog importinfos)], []) executeAnalysis (SimpleFuncAnalysis _ anaFunc) prog _ _ _ = (lists2ProgInfo . map2 (\func -> (funcName func, anaFunc func)) . partition isVisibleFunc . progFuncs) prog executeAnalysis (SimpleTypeAnalysis _ anaFunc) prog _ _ _ = (lists2ProgInfo . map2 (\typ -> (typeName typ,anaFunc typ)) . partition isVisibleType . progTypes) prog executeAnalysis (SimpleConstructorAnalysis _ anaFunc) prog _ _ _ = (lists2ProgInfo . map2 (\ (cdecl,tdecl) -> (consName cdecl, anaFunc cdecl tdecl)) . partition isVisibleCons . concatMap (\t -> map (\c -> (c,t)) (consDeclsOfType t)) . progTypes) prog where isVisibleCons (consDecl,_) = consVisibility consDecl == Public executeAnalysis (DependencyFuncAnalysis _ _ anaFunc) prog importInfos startvals fpmethod = case fpmethod of "simple" -> let declsWithDeps = map2 addCalledFunctions (partition isVisibleFunc (progFuncs prog)) startinfo = funcInfos2ProgInfo prog startvals in simpleIteration anaFunc funcName declsWithDeps importInfos startinfo "wlist" -> let declsWithDeps = map addCalledFunctions (progFuncs prog) in funcInfos2ProgInfo prog $ toList $ wlIteration anaFunc funcName declsWithDeps [] (Set.empty (<)) importInfos (fromList startvals) "wlistscc" -> let declsWithDeps = map addCalledFunctions (progFuncs prog) -- compute strongly connected components w.r.t. func dependencies: sccDecls = scc ((:[]) . funcName . fst) snd declsWithDeps in funcInfos2ProgInfo prog $ toList $ foldr (\scc sccstartvals -> wlIteration anaFunc funcName scc [] (Set.empty (<)) importInfos sccstartvals) (fromList startvals) (reverse sccDecls) _ -> error unknownFixpointMessage executeAnalysis (DependencyTypeAnalysis _ _ anaType) prog importInfos startvals fpmethod = case fpmethod of "simple" -> let declsWithDeps = map2 addUsedTypes (partition isVisibleType (progTypes prog)) startinfo = typeInfos2ProgInfo prog startvals in simpleIteration anaType typeName declsWithDeps importInfos startinfo "wlist" -> let declsWithDeps = map addUsedTypes (progTypes prog) in typeInfos2ProgInfo prog $ toList $ wlIteration anaType typeName declsWithDeps [] (Set.empty (<)) importInfos (fromList startvals) "wlistscc" -> let declsWithDeps = map addUsedTypes (progTypes prog) -- compute strongly connected components w.r.t. type dependencies: sccDecls = scc ((:[]) . typeName . fst) snd declsWithDeps in typeInfos2ProgInfo prog $ toList $ foldr (\scc sccstartvals -> wlIteration anaType typeName scc [] (Set.empty (<)) importInfos sccstartvals) (fromList startvals) (reverse sccDecls) _ -> error unknownFixpointMessage -- These cases are handled elsewhere: executeAnalysis (CombinedSimpleFuncAnalysis _ _ _ _) _ _ _ _ = error "Internal error in WorkerFunctions.executeAnalysis" executeAnalysis (CombinedSimpleTypeAnalysis _ _ _ _) _ _ _ _ = error "Internal error in WorkerFunctions.executeAnalysis" executeAnalysis (CombinedDependencyFuncAnalysis _ _ _ _ _) _ _ _ _ = error "Internal error in WorkerFunctions.executeAnalysis" executeAnalysis (CombinedDependencyTypeAnalysis _ _ _ _ _) _ _ _ _ = error "Internal error in WorkerFunctions.executeAnalysis" unknownFixpointMessage :: String unknownFixpointMessage = "Unknown value for 'fixpoint' in configuration file!" --- Add the directly called functions to each function declaration. addCalledFunctions :: FuncDecl -> (FuncDecl,[QName]) addCalledFunctions func = (func, callsDirectly func) --- Add the directly used type constructors to each type declaration. addUsedTypes :: TypeDecl -> (TypeDecl,[QName]) addUsedTypes tdecl = (tdecl, dependsDirectlyOnTypes tdecl) --- Gets all constructors of datatype declaration. consDeclsOfType :: TypeDecl -> [ConsDecl] consDeclsOfType (Type _ _ _ consDecls) = consDecls consDeclsOfType (TypeSyn _ _ _ _) = [] consDeclsOfType (TypeNew _ _ _ (NewCons qn vis te)) = [Cons qn 1 vis [te]] ----------------------------------------------------------------------- --- Fixpoint iteration to compute analysis information. The arguments are: --- * analysis operation --- * operation to get name of a declaration --- * list of public and private declarations together with their direct deps --- * ProgInfo for imported entities --- * current ProgInfo --- Result: fixpoint ProgInfo simpleIteration :: Eq a => (t -> [(QName,a)] -> a) -> (t -> QName) -> ([(t,[QName])],[(t,[QName])]) -> ProgInfo a -> ProgInfo a -> ProgInfo a simpleIteration analysis nameOf declsWithDeps importInfos currvals = let completeProgInfo = combineProgInfo currvals importInfos newvals = map2 (\ (decl,calls) -> (nameOf decl, analysis decl (map (\qn -> (qn,fromJust -- information must known! (lookupProgInfo qn completeProgInfo))) calls))) declsWithDeps newproginfo = lists2ProgInfo newvals in if equalProgInfo currvals newproginfo then currvals else simpleIteration analysis nameOf declsWithDeps importInfos newproginfo wlIteration :: (Eq a, Eq b) => (a -> [(QName,b)] -> b) -> (a -> QName) -> [(a,[QName])] -> [(a,[QName])] -> SetRBT QName -> ProgInfo b -> Map QName b -> Map QName b --wlIteration analysis nameOf declsToDo declsDone changedEntities -- importInfos currvals wlIteration analysis nameOf [] alldecls changedEntities importInfos currvals = if Set.null changedEntities then currvals -- no todos, no changed values, so we are done: else -- all declarations processed, compute todos for next round: let (declsToDo,declsDone) = partition (\ (_,calls) -> any (`Set.member` changedEntities) calls) alldecls in wlIteration analysis nameOf declsToDo declsDone (Set.empty (<)) importInfos currvals -- process a single declaration: wlIteration analysis nameOf (decldeps@(decl,calls):decls) declsDone changedEntities importInfos currvals = let decname = nameOf decl lookupVal qn = maybe (fromJust (Map.lookup qn currvals)) id (lookupProgInfo qn importInfos) oldval = lookupVal decname newval = analysis decl (map (\qn -> (qn, lookupVal qn)) calls) in if oldval==newval then wlIteration analysis nameOf decls (decldeps:declsDone) changedEntities importInfos currvals else wlIteration analysis nameOf decls (decldeps:declsDone) (Set.insert decname changedEntities) importInfos (Map.adjust (const newval) decname currvals) --------------------------------------------------------------------- -- Auxiliaries isVisibleFunc :: FuncDecl -> Bool isVisibleFunc funcDecl = funcVisibility funcDecl == Public isVisibleType :: TypeDecl -> Bool isVisibleType typeDecl = typeVisibility typeDecl == Public --------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/containers/000077500000000000000000000000001377556325500226475ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/containers/LICENSE000066400000000000000000000027351377556325500236630ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/containers/README.md000066400000000000000000000002711377556325500241260ustar00rootroot00000000000000containers ========== This package contains the library `Data.Map` implementing finite maps, i.e., efficient purely functional data structures to store a mapping from keys to values. curry-tools-v3.3.0/optimize/.cpm/packages/containers/package.json000066400000000000000000000015371377556325500251430ustar00rootroot00000000000000{ "name": "containers", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library implementing various datastructures", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base": ">= 3.0.0, < 4.0.0", "random": ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Data.Map", "Data.Set" ], "testsuite": [ { "src-dir": "src", "modules": [ "Data.Map", "Data.Set" ] }, { "src-dir": "test", "modules": [ "TestMap", "TestSet" ] } ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/containers.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/containers/src/000077500000000000000000000000001377556325500234365ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/containers/src/Data/000077500000000000000000000000001377556325500243075ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/containers/src/Data/Map.curry000066400000000000000000000515111377556325500261150ustar00rootroot00000000000000----------------------------------------------------------------------------- --- A finite map is an efficient purely functional data structure --- to store a mapping from keys to values. --- --- This version was ported from a corresponding Haskell library --- --- @author Frank Huch, Bernd Brassel --- @version March 2013 --- @category algorithm ----------------------------------------------------------------------------- module Data.Map ( Map, -- abstract type empty, singleton, fromList, insert, insertWith, insertList, insertListWith, delete, deleteAll, adjust, splitLookup, union, unionWith, difference, intersection, intersectionWith, foldrWithKey, mapWithKey, filterWithKey, size, null, member, lookup, findWithDefault, toList, keys, elems, sortWithMap, lookupMin, lookupMax, toPreOrderList ) where import Data.Maybe import Prelude hiding (empty) ----------------------------------------------- -- BUILDING finite maps ----------------------------------------------- --- The empty map. --- @result an empty map empty :: Map _ _ empty = Tip --- Construct a map with only a single element. --- @param k key of --- @param a the single element to form --- @result a finite map with only a single element singleton :: k -> a -> Map k a singleton k a = Bin k a 1 Tip Tip --- Builts a map from given list of tuples (key,element). --- For multiple occurences of key, the last corresponding --- element of the list is taken. fromList :: Ord k => [(k,a)] -> Map k a fromList xs = insertList xs empty ----------------------------------------------- -- ADDING AND DELETING ----------------------------------------------- --- Throws away any previous binding and stores the new one given. insert :: Ord k => k -> a -> Map k a -> Map k a insert k a m = insertWith (\ _ new -> new) k a m --- Instead of throwing away the old binding, --- insertWith combines the new element with the old one. --- @param combiner a function combining to elements --- @param k the key of the elements to be combined --- @param a the new element --- @param m a map --- @result a modified map insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a insertWith _ k a Tip = singleton k a insertWith combiner new_k new_a (Bin k a sizeM m_l m_r) = if new_k < k then mkBalBranch k a (insertWith combiner new_k new_a m_l) m_r else if new_k == k then Bin new_k (combiner a new_a) sizeM m_l m_r else mkBalBranch k a m_l (insertWith combiner new_k new_a m_r) --- Throws away any previous bindings and stores the new ones given. --- The items are added starting with the first one in the list insertList :: Ord k => [(k, a)] -> Map k a -> Map k a insertList k_a_pairs m = insertListWith (\ _ new -> new) k_a_pairs m --- Combine with a list of tuples (key, element), cf. insertWith insertListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> Map k a -> Map k a insertListWith combiner k_a_pairs m = foldl add m k_a_pairs -- foldl adds from the left where add m' (k, a) = insertWith combiner k a m' --- Deletes key from map. --- Deletion doesn't complain if you try to delete something --- which isn't there delete :: Ord k => k -> Map k a -> Map k a delete _ Tip = Tip delete del_k (Bin k a _ m_l m_r) = if del_k < k then mkBalBranch k a (delete del_k m_l) m_r else if del_k == k then glueBal m_l m_r else mkBalBranch k a m_l (delete del_k m_r) --- Deletes a list of keys from map. --- Deletion doesn't complain if you try to delete something --- which isn't there deleteAll :: Ord k => [k] -> Map k a -> Map k a deleteAll ks m = foldl (flip delete) m ks --- Applies a function to element bound to given key. adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a adjust _ _ Tip = Tip adjust f i (Bin k x h l r) | i == k = Bin k (f x) h l r | i < k = Bin k x h (adjust f i l) r | otherwise = Bin k x h l (adjust f i r) --- Combines delFrom and lookup. splitLookup :: Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a) splitLookup _ Tip = (Tip, Nothing, Tip) splitLookup i (Bin k a _ m_l m_r) | i == k = (m_l, Just a, m_r) | i < k = let (m_l', v, m_r') = splitLookup i m_l in (m_l', v, glueBal m_r' m_r) | otherwise = let (m_l', v, m_r') = splitLookup i m_r in (glueBal m_l m_l', v, m_r') ------------------------------------------------- -- COMBINING finite maps ------------------------------------------------- --- Efficiently add key/element mappings of two maps into a single one. --- CHANGED: Bindings in left argument shadow those in the right union :: Ord k => Map k a -> Map k a -> Map k a union Tip m2 = m2 union m1@(Bin _ _ _ _ _) Tip = m1 union (Bin split_key1 a1 _ left1 right1) m2@(Bin _ _ _ _ _) = mkVBalBranch split_key1 a1 (union left1 lts) (union right1 gts) where lts = splitLT m2 split_key1 gts = splitGT m2 split_key1 --- Efficiently combine key/element mappings of two maps into a single one, --- cf. insertWith unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a unionWith _ Tip m2 = m2 unionWith _ m1@(Bin _ _ _ _ _) Tip = m1 unionWith combiner (Bin split_key1 a1 _ left1 right1) m2@(Bin _ _ _ _ _) = mkVBalBranch split_key1 new_a (unionWith combiner left1 lts) (unionWith combiner right1 gts) where lts = splitLT m2 split_key1 gts = splitGT m2 split_key1 new_a = case lookup split_key1 m2 of Nothing -> a1 Just a2 -> combiner a2 a1 --- (difference a1 a2) deletes from a1 any bindings which are bound in a2 difference :: Ord k => Map k a -> Map k b -> Map k a difference Tip _ = Tip difference m1@(Bin _ _ _ _ _) Tip = m1 difference m1@(Bin _ _ _ _ _) (Bin split_key2 _ _ left2 right2) = glueVBal (difference lts left2) (difference gts right2) -- The two can be way different, so we need glueVBal where lts = splitLT m1 split_key2 -- NB gt and lt, so the equal ones gts = splitGT m1 split_key2 -- are not in either. --- Filters only those keys that are bound in both of the given maps. --- CHANGED: The elements will be taken from the first map. intersection :: Ord k => Map k a -> Map k a -> Map k a intersection m1 m2 = intersectionWith (\ left _ -> left) m1 m2 --- Filters only those keys that are bound in both of the given maps --- and combines the elements as in insertWith. intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c intersectionWith _ _ Tip = Tip intersectionWith _ Tip (Bin _ _ _ _ _) = Tip intersectionWith combiner m1@(Bin _ _ _ _ _) (Bin split_key2 a2 _ left2 right2) | isJust maybe_a1 -- split_a *is* in intersection = mkVBalBranch split_key2 (combiner a1' a2) (intersectionWith combiner lts left2) (intersectionWith combiner gts right2) | otherwise -- split_a is *not* in intersection = glueVBal (intersectionWith combiner lts left2) (intersectionWith combiner gts right2) where lts = splitLT m1 split_key2 -- NB gt and lt, so the equal ones gts = splitGT m1 split_key2 -- are not in either. maybe_a1 = lookup split_key2 m1 Just a1' = maybe_a1 ------------------------------------------------------------- -- MAPPING, FOLDING, FILTERING on maps ------------------------------------------------------------- --- Folds map by given function. foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b foldrWithKey _ z Tip = z foldrWithKey k z (Bin key elt _ fm_l fm_r) = foldrWithKey k (k key elt (foldrWithKey k z fm_r)) fm_l --- Applies a given function on every element in the map. mapWithKey :: (k -> a -> b) -> Map k a -> Map k b mapWithKey _ Tip = Tip mapWithKey f (Bin key a size' m_l m_r) = Bin key (f key a) size' (mapWithKey f m_l) (mapWithKey f m_r) --- Yields a new map with only those key/element pairs matching the --- given predicate. filterWithKey :: Ord k => (k -> a -> Bool) -> Map k a -> Map k a filterWithKey _ Tip = Tip filterWithKey p (Bin key a _ m_l m_r) | p key a -- Keep the item = mkVBalBranch key a (filterWithKey p m_l) (filterWithKey p m_r) | otherwise -- Drop the item = glueVBal (filterWithKey p m_l) (filterWithKey p m_r) ----------------------------------------------------- -- INTERROGATING maps ----------------------------------------------------- --- How many elements does given map contain? size :: Map _ _ -> Int size Tip = 0 size (Bin _ _ size' _ _) = size' --- Is the given finite map empty? null :: Map _ _ -> Bool null m = size m == 0 --- Does given map contain given key? member :: Ord k => k -> Map k _ -> Bool member k m = isJust (lookup k m) --- Retrieves element bound to given key lookup :: Ord k => k -> Map k a -> Maybe a lookup _ Tip = Nothing lookup key_to_find (Bin k a _ m_l m_r) = if key_to_find < k then lookup key_to_find m_l else if key_to_find == k then Just a else lookup key_to_find m_r --- Retrieves element bound to given key. --- If the element is not contained in map, return --- default value. findWithDefault :: Ord k => a -> k -> Map k a -> a findWithDefault deflt k m = case lookup k m of Nothing -> deflt Just a -> a --- Retrieves the smallest key/element pair in the finite map --- according to the basic key ordering. lookupMin :: Map k a -> Maybe (k, a) lookupMin Tip = Nothing lookupMin (Bin k x _ l _) | isBranch l = lookupMin l | otherwise = Just (k, x) --- Retrieves the greatest key/element pair in the finite map --- according to the basic key ordering. lookupMax :: Map k a -> Maybe (k, a) lookupMax Tip = Nothing lookupMax (Bin k x _ _ r) | isBranch r = lookupMax r | otherwise = Just (k, x) ---------------------------------------------------- -- LISTIFYING: transform finite maps to lists ---------------------------------------------------- --- Builds a list of key/element pairs. The list is ordered --- by the "Ord" context on keys. toList :: Map k a -> [(k, a)] toList m = foldrWithKey (\ k a rest -> (k, a) : rest) [] m --- Retrieves a list of keys contained in map. --- The list is ordered --- by the "Ord" context on keys. keys :: Map k _ -> [k] keys m = foldrWithKey (\ k _ rest -> k : rest) [] m --- Retrieves a list of elements contained in map. --- The list is ordered --- by the "Ord" context on keys. elems :: Map _ a -> [a] elems m = foldrWithKey (\ _ a rest -> a : rest) [] m --- Retrieves list of key/element pairs in preorder of the internal tree. --- Useful for lists that will be retransformed into a tree or to match --- any elements regardless of basic order. toPreOrderList :: Map k a -> [(k, a)] toPreOrderList m = pre m [] where pre Tip xs = xs pre (Bin k x _ l r) xs = (k, x) : pre l (pre r xs) --- Sorts a given list by inserting and retrieving from map. --- Duplicates are deleted. sortWithMap :: Ord k => [k] -> [k] sortWithMap l = keys (fromList (zip l (repeat ()))) ----------------------------------------------------- -- internal Implementation ----------------------------------------------------- data Map k a = Tip | Bin k a -- Key and element stored here Int{-STRICT-} -- Size >= 1 (Map k a) -- Children (Map k a) deriving (Show, Read) instance (Eq k, Eq a) => Eq (Map k a) where m_1 == m_2 = (size m_1 == size m_2) && -- quick test (toList m_1 == toList m_2) isBranch :: Map _ _ -> Bool isBranch (Bin _ _ _ _ _) = True isBranch Tip = False ------------------------------------------------------------------------- -- - -- The implementation of balancing - -- - ------------------------------------------------------------------------- ------------------------------------------------------------------------- -- - -- Basic construction of a FiniteMap - -- - ------------------------------------------------------------------------- sIZE_RATIO :: Int sIZE_RATIO = 5 mkBranch :: Int -> key -> elt -> Map key elt -> Map key elt -> Map key elt mkBranch _{-which-} key elt fm_l fm_r = let result = Bin key elt (unbox (1 + left_size + right_size)) fm_l fm_r in result -- if size result <= 8 then -- result -- else -- pprTrace ("mkBranch:"++(show which)) (ppr result) ( -- result -- ) where {-left_ok = case fm_l of Tip -> True Bin _ _ _ _ _ -> cmpWithBiggest_left_key key cmpWithBiggest_left_key key' = (fst (findMax fm_l)) < key' right_ok = case fm_r of Tip -> True Bin _ _ _ _ _ -> cmpWithSmallest_right_key key cmpWithSmallest_right_key key' = key' < (fst (findMin fm_r)) balance_ok = True -- sigh-} left_size = size fm_l right_size = size fm_r unbox :: Int -> Int unbox x = x ------------------------------------------------------------------------- -- - -- Balanced construction of a FiniteMap - -- - ------------------------------------------------------------------------- mkBalBranch :: key -> elt -> Map key elt -> Map key elt -> Map key elt mkBalBranch key elt fm_L fm_R | size_l + size_r < 2 = mkBranch 1{-which-} key elt fm_L fm_R | size_r > sIZE_RATIO * size_l -- Right tree too big = case fm_R of Bin _ _ _ fm_rl fm_rr -> if size fm_rl < 2 * size fm_rr then single_L fm_L fm_R else double_L fm_L fm_R -- Other case impossible Tip -> error "Data.Map.mkBalBranch" | size_l > sIZE_RATIO * size_r -- Left tree too big = case fm_L of Bin _ _ _ fm_ll fm_lr -> if size fm_lr < 2 * size fm_ll then single_R fm_L fm_R else double_R fm_L fm_R -- Other case impossible Tip -> error "Data.Map.mkBalBranch" | otherwise -- No imbalance = mkBranch 2{-which-} key elt fm_L fm_R where size_l = size fm_L size_r = size fm_R single_L fm_l (Bin key_r elt_r _ fm_rl fm_rr) = mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr single_L _ Tip = error "Data.Map.single_L" double_L fm_l (Bin key_r elt_r _ (Bin key_rl elt_rl _ fm_rll fm_rlr) fm_rr) = mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key elt fm_l fm_rll) (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr) double_L _ Tip = error "Data.Map.double_L" double_L _ (Bin _ _ _ Tip _) = error "Data.Map.double_L" single_R (Bin key_l elt_l _ fm_ll fm_lr) fm_r = mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r) single_R Tip _ = error "Data.Map.single_R" double_R (Bin key_l elt_l _ fm_ll (Bin key_lr elt_lr _ fm_lrl fm_lrr)) fm_r = mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll fm_lrl) (mkBranch 12{-which-} key elt fm_lrr fm_r) double_R Tip _ = error "Data.Map.double_R" double_R (Bin _ _ _ _ Tip) _ = error "Data.Map.double_R" mkVBalBranch :: Ord key => key -> elt -> Map key elt -> Map key elt -> Map key elt -- Assert: in any call to (mkVBalBranch_C comb key elt l r), -- (a) all keys in l are < all keys in r -- (b) all keys in l are < key -- (c) all keys in r are > key mkVBalBranch key elt Tip fm_r = insert key elt fm_r mkVBalBranch key elt (Bin key_l elt_l s_l fm_ll fm_lr) Tip = insert key elt (Bin key_l elt_l s_l fm_ll fm_lr) mkVBalBranch key elt (Bin key_l elt_l s_l fm_ll fm_lr) (Bin key_r elt_r s_r fm_rl fm_rr) | sIZE_RATIO * size_l < size_r = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr | sIZE_RATIO * size_r < size_l = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r) | otherwise = mkBranch 13{-which-} key elt fm_l fm_r where fm_l = Bin key_l elt_l s_l fm_ll fm_lr fm_r = Bin key_r elt_r s_r fm_rl fm_rr size_l = size fm_l size_r = size fm_r ------------------------------------------------------------------------- -- - -- Gluing two trees together - -- - ------------------------------------------------------------------------- glueBal :: Map key elt -> Map key elt -> Map key elt glueBal fm1 fm2 = if null fm1 then fm2 else if null fm2 then fm1 else -- The case analysis here (absent in Adams' program) is really to deal -- with the case where fm2 is a singleton. Then deleting the minimum means -- we pass an empty tree to mkBalBranch, which breaks its invariant. let (mid_key1, mid_elt1) = findMax fm1 (mid_key2, mid_elt2) = findMin fm2 in if size fm2 > size fm1 then mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2) else mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2 glueVBal :: Map key elt -> Map key elt -> Map key elt glueVBal fm_l fm_r = if null fm_l then fm_r else if null fm_r then fm_l else let Bin key_l elt_l _ fm_ll fm_lr = fm_l Bin key_r elt_r _ fm_rl fm_rr = fm_r --(mid_key_l,mid_elt_l) = findMax fm_l --(mid_key_r,mid_elt_r) = findMin fm_r size_l = size fm_l size_r = size fm_r in if sIZE_RATIO * size_l < size_r then mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr else if sIZE_RATIO * size_r < size_l then mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r) -- We now need the same two cases as in glueBal above. else glueBal fm_l fm_r ------------------------------------------------------------------------- -- - -- Local utilities - -- - ------------------------------------------------------------------------- splitLT, splitGT :: Ord key => Map key elt -> key -> Map key elt -- splitLT fm split_key = fm restricted to keys < split_key -- splitGT fm split_key = fm restricted to keys > split_key splitLT Tip _ = Tip splitLT (Bin key elt _ fm_l fm_r) split_key = if split_key < key then splitLT fm_l split_key else if split_key == key then fm_l else mkVBalBranch key elt fm_l (splitLT fm_r split_key) splitGT Tip _ = Tip splitGT (Bin key elt _ fm_l fm_r) split_key = if split_key < key then mkVBalBranch key elt (splitGT fm_l split_key) fm_r else if split_key == key then fm_r else splitGT fm_r split_key findMin :: Map key elt -> (key, elt) findMin Tip = error "Data.Map.findMin: empty map" findMin (Bin key elt _ Tip _) = (key, elt) findMin (Bin _ _ _ (Bin key_l elt_l s_l fm_ll fm_lr)_) = findMin (Bin key_l elt_l s_l fm_ll fm_lr) deleteMin :: Map key elt -> Map key elt deleteMin Tip = error "Data.Map.deleteMin: empty map" deleteMin (Bin _ _ _ Tip fm_r) = fm_r deleteMin (Bin key elt _ (Bin key_l elt_l s_l fm_ll fm_lr) fm_r) = mkBalBranch key elt (deleteMin (Bin key_l elt_l s_l fm_ll fm_lr)) fm_r findMax :: Map key elt -> (key,elt) findMax Tip = error "Data.Map.findMax: empty map" findMax (Bin key elt _ _ Tip) = (key, elt) findMax (Bin _ _ _ _ (Bin key_r elt_r s_r fm_rl fm_rr)) = findMax (Bin key_r elt_r s_r fm_rl fm_rr) deleteMax :: Map key elt -> Map key elt deleteMax Tip = error "FiniteMap.deleteMax: empty map" deleteMax (Bin _ _ _ fm_l Tip) = fm_l deleteMax (Bin key elt _ fm_l (Bin key_r elt_r s_r fm_rl fm_rr)) = mkBalBranch key elt fm_l (deleteMax (Bin key_r elt_r s_r fm_rl fm_rr)) curry-tools-v3.3.0/optimize/.cpm/packages/containers/src/Data/Set.curry000066400000000000000000000036741377556325500261420ustar00rootroot00000000000000----------------------------------------------------------------------------- --- An efficient implementation of set based on finite maps. ----------------------------------------------------------------------------- module Data.Set ( Set, null, size, fromList, empty, insert, member, delete , union, toList, difference ) where import qualified Data.Map as Map ------------------------------------------------------------------------- -- - -- FiniteSets --- a thin veneer - -- - ------------------------------------------------------------------------- --- The type of sets of elements. type Set key = Map.Map key () --- Returns an empty set. empty :: Set key empty = Map.empty --- Transforms a list into a set of its elements. fromList :: Ord key => [key] -> Set key fromList xs = Map.fromList [ (x, ()) | x <- xs] --- Test for an empty set. null :: Set key -> Bool null = Map.null --- Inserts an element into a set if it is not already there. insert :: Ord key => key -> Set key -> Set key insert k s = Map.insert k () s --- Deletes an element from a set. delete :: Ord key => key -> Set key -> Set key delete k s = Map.delete k s --- Computes the size of two sets. size :: Set key -> Int size = Map.size --- Returns `True` if an element is contained in a set. --- @param e - an element to be checked for containment --- @param s - a set --- @return `True` if `e` is contained in `s` member :: Ord key => key -> Set key -> Bool member = Map.member --- Computes the difference of two sets. difference :: Ord key => Set key -> Set key -> Set key difference = Map.difference --- Transforms a set into an ordered list of its elements. toList :: Set key -> [key] toList = Map.keys --- Computes the union of two sets. union :: Ord key => Set key -> Set key -> Set key union = Map.union curry-tools-v3.3.0/optimize/.cpm/packages/containers/test/000077500000000000000000000000001377556325500236265ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/containers/test/TestMap.curry000066400000000000000000000055261377556325500263010ustar00rootroot00000000000000import Data.List hiding (union) import Data.Maybe import Prelude hiding (lookup) import System.Random import Test.Prop import Data.Map fm f = f . fromList . map (\x ->(x,x)) fms f = map fst . toList . fm f fms' f = map snd . toList . fm f so f = spnub . sortBy (<) . f testInsert = eq (fms (\x-> insert 73 73 x)) (so (73:)) testDeleteAll = test (\nums -> fms (deleteAll (take 500 nums)) nums == so (drop 500) nums) testUnion = test (\nums -> let l=length nums (xs,ys) = splitAt (div l 2) nums in (map fst $ toList $ union (fm id xs) (fm id ys)) == so id nums) testDifference = test (\nums -> let l = length nums (xs,ys) = splitAt (div l 2) nums in (map fst $ toList $ difference (fm id nums) (fm id ys)) == so id xs) testIntersection = test (\nums -> let l=length nums (_,ys) = splitAt (div l 2) nums in (map fst $ toList $ intersection (fm id ys) (fm id nums)) == so id ys) testFoldrWithKey = eq (fm (foldrWithKey (\x _ z->x+z) 0)) (foldl (+) 0) testMapWithKey = eq (fms' (mapWithKey (\_ z->z+1))) (so (map (+1))) testFilterFM = eq (fms (filterWithKey (\x _->x>0))) (so (filter (>0))) testSize = eq (fm size) length testMember_Lookup = eq (fm (\x-> member 73 (insert 73 73 x))) (const True) testKeys_elems = test (\nums -> let finm=fm id nums in unzip (toList finm)==(keys finm, elems finm)) testSortWithMap = eq sortWithMap (so id) testMin_Max = eq (fm (\finm -> (fst $ fromJust $ lookupMin finm, fst $ fromJust $ lookupMax finm))) ((\l->(head l,last l)) .so id) testAdjust = eq (fm (\x-> lookup 73 (adjust (+7) 73 (insert 73 73 x)))) (const $ Just 80) spnub [] = [] spnub [x] = [x] spnub (x:y:xs) = if x==y then spnub (y:xs) else x:spnub (y:xs) ------------------------------------------------------------------------------ -- Random test: --- Tests a given predicate on a list of distinct random numbers. --- In case of a failure, the list of random numbers is returned --- in order to see the test cases in the CurryTest tool. test :: ([Int] -> Bool) -> PropIO test f = (rndList lenRnds >>= \xs -> return (if f xs then Nothing else Just xs)) `returns` Nothing --- Tests whether two operations return equal results --- on a list of distinct random numbers. --- In case of a failure, the list of random numbers is returned --- in order to see the test cases in the CurryTest tool. eq :: Eq a => ([Int] -> a) -> ([Int] -> a) -> PropIO eq f g = test (\x -> (f x)==(g x)) --- generate a list of at most n random numbers (without duplicated elements) rndList :: Int -> IO [Int] rndList n = getRandomSeed >>= return . nub . take n . (flip nextIntRange 100000) --- maximal length of test lists lenRnds :: Int lenRnds = 1000 ------------------------------------------------------------------------------ curry-tools-v3.3.0/optimize/.cpm/packages/containers/test/TestSet.curry000066400000000000000000000010501377556325500263030ustar00rootroot00000000000000-- Some tests for sets (to be extended...) import Prelude hiding ( null ) import Test.Prop import Data.Set testSizeFromList1 :: Int -> Prop testSizeFromList1 m = size (fromList [1 .. n]) -=- n where n = toPos m testSizeFromList2 :: Int -> Prop testSizeFromList2 m = size (fromList [n, n-1 .. 1] `union` fromList [1 .. n]) -=- n where n = toPos m testDeleteAll :: Int -> Prop testDeleteAll m = always (null (foldr delete (fromList [1 .. n]) [1 .. n])) where n = toPos m toPos :: Int -> Int toPos n | n < 0 = 2 * abs n | otherwise = n curry-tools-v3.3.0/optimize/.cpm/packages/csv/000077500000000000000000000000001377556325500212755ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/csv/LICENSE000066400000000000000000000027351377556325500223110ustar00rootroot00000000000000Copyright (c) 2017, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/csv/README.md000066400000000000000000000005541377556325500225600ustar00rootroot00000000000000csv: Reading/writing files in CSV format ======================================== This package contains a library with operations to read and write files CSV (comma separated values) format. Files in CSV format can be imported and exported by most spreadsheed and database applications. -------------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/csv/package.json000066400000000000000000000011521377556325500235620ustar00rootroot00000000000000{ "name": "csv", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library for reading/writing files in CSV format", "category": [ "Data", "Parsing" ], "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Text.CSV" ], "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "license": "BSD-3-Clause", "licenseFile": "LICENSE", "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/csv.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/csv/src/000077500000000000000000000000001377556325500220645ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/csv/src/Text/000077500000000000000000000000001377556325500230105ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/csv/src/Text/CSV.curry000066400000000000000000000070711377556325500245360ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for reading/writing files in CSV format. --- Files in CSV (comma separated values) format can be imported and exported --- by most spreadsheed and database applications. --- --- @author Michael Hanus --- @version September 2004 --- @category general ------------------------------------------------------------------------------ module Text.CSV ( showCSV, readCSV, readCSVWithDelims , writeCSVFile, readCSVFile, readCSVFileWithDelims ) where import Data.List (intersperse) --- Writes a list of records (where each record is a list of strings) --- into a file in CSV format. --- @param fname - the name of the result file (with standard suffix ".csv") --- @param rows - the list of rows writeCSVFile :: String -> [[String]] -> IO () writeCSVFile fname rows = writeFile fname (showCSV rows) --- Shows a list of records (where each record is a list of strings) --- as a string in CSV format. showCSV :: [[String]] -> String showCSV rows = concatMap showCSVLine rows --- Shows a list of strings as a line in CSV format. showCSVLine :: [String] -> String showCSVLine row = concat (intersperse "," (map convert row)) ++ "\n" where -- enclose in quotation marks if necessary: convert s = if any (\c->c `elem` ['"',',',';',':','\n']) s then '"' : concatMap (\c->if c=='"' then [c,c] else [c]) s ++ "\"" else s --- Reads a file in CSV format and returns the list of records --- (where each record is a list of strings). --- @param fname - the name of the result file (with standard suffix ".csv") readCSVFile :: String -> IO [[String]] readCSVFile = readCSVFileWithDelims [','] --- Reads a file in CSV format and returns the list of records --- (where each record is a list of strings). --- @param delims - the list of characters considered as delimiters --- @param fname - the name of the result file (with standard suffix ".csv") readCSVFileWithDelims :: [Char] -> String -> IO [[String]] readCSVFileWithDelims delims fname = do contents <- readFile fname return (readCSVWithDelims delims contents) --- Reads a string in CSV format and returns the list of records --- (where each record is a list of strings). --- @param str - the string in CSV format readCSV :: String -> [[String]] readCSV = readCSVWithDelims [','] --- Reads a string in CSV format and returns the list of records --- (where each record is a list of strings). --- @param delims - the list of characters considered as delimiters --- @param str - the string in CSV format readCSVWithDelims :: [Char] -> String -> [[String]] readCSVWithDelims delims str = map (components delims) (lines str) --- Breaks a string in CSV record format into a list of components. components :: [Char] -> String -> [String] components _ [] = [[]] components delims (c:cs) = if c=='"' then breakString cs else let (e,s) = break (`elem` delims) (c:cs) in e : (if null s then [] else components delims (tail s)) where breakString [] = delimError breakString [x] = if x=='"' then [[]] else delimError breakString (x:y:zs) | x=='"' && y=='"' = let (b:bs) = breakString zs in (x:b):bs | x=='"' && y `elem` delims = []:components delims zs | otherwise = let (b:bs) = breakString (y:zs) in (x:b):bs delimError = error "Missing closing delimiter in CSV record!" -- Examples: -- writeCSVFile "tmp.csv" [["Name","Value"],["aa\"bb,cc","1"]] -- readCSVFile "tmp.csv" curry-tools-v3.3.0/optimize/.cpm/packages/currypath/000077500000000000000000000000001377556325500225235ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/currypath/LICENSE000066400000000000000000000027351377556325500235370ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/currypath/README.md000066400000000000000000000003221377556325500237770ustar00rootroot00000000000000currypath ========= This package provides the library `System.CurryPath` which contains operations to deal with module names and paths used in a Curry system, like finding a module in the standard load path. curry-tools-v3.3.0/optimize/.cpm/packages/currypath/package.json000066400000000000000000000013001377556325500250030ustar00rootroot00000000000000{ "name": "currypath", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Operations to deal with Curry module names and paths", "category": [ "System" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "directory" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0", "process" : ">= 3.0.0, < 4.0.0", "propertyfile": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.CurryPath" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/currypath.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/currypath/src/000077500000000000000000000000001377556325500233125ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/currypath/src/System/000077500000000000000000000000001377556325500245765ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/currypath/src/System/CurryPath.curry000066400000000000000000000261701377556325500276130ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains operations related to module names and paths --- used in Curry system. --- --- @author Bernd Brassel, Michael Hanus, Bjoern Peemoeller, Finn Teegen --- @version December 2020 ------------------------------------------------------------------------------ module System.CurryPath ( ModuleIdent , splitProgramName, splitValidProgramName, isValidModuleName , runModuleAction , splitModuleFileName, splitModuleIdentifiers , joinModuleIdentifiers , stripCurrySuffix , ModulePath, modNameToPath , currySubdir, inCurrySubdir, inCurrySubdirModule, addCurrySubdir , sysLibPath, getLoadPathForModule , lookupModuleSourceInLoadPath, lookupModuleSource , curryrcFileName ) where import Control.Monad ( unless ) import Curry.Compiler.Distribution ( curryCompiler, curryCompilerMajorVersion , curryCompilerMinorVersion , curryCompilerRevisionVersion , installDir ) import Data.Char ( toLower ) import Data.List ( init, intercalate, last, split ) import System.Directory ( doesFileExist, getCurrentDirectory , getHomeDirectory, setCurrentDirectory ) import System.Environment ( getEnv ) import System.Process ( system ) import System.FilePath ( FilePath, (), (<.>), addTrailingPathSeparator , dropFileName, joinPath, splitDirectories , splitExtension, splitFileName, splitPath , splitSearchPath , takeFileName, takeExtension, dropExtension ) import Data.PropertyFile ( getPropertyFromFile ) ------------------------------------------------------------------------------ --- Functions for handling file names of Curry modules ------------------------------------------------------------------------------ type ModuleIdent = String --- Splits a program name, i.e., a module name possibly prefixed by --- a directory, into the directory and the module name. --- A possible suffix like `.curry` or `.lcurry` is dropped from the --- module name. --- For instance `splitProgramName "lib/Data.Set.curry"` evaluates --- to `("lib","Data.Set")`. splitProgramName :: String -> (FilePath, ModuleIdent) splitProgramName s | null ps = (".", "") | null (tail ps) = (".", head ps) | otherwise = (concat (init ps), last ps) where ps = splitPath (stripCurrySuffix s) --- Splits a program name, i.e., a module name possibly prefixed by --- a directory, into the directory and a *valid* module name. --- A possible suffix like `.curry` or `.lcurry` is dropped from the --- module name. --- For instance `splitValidProgramName "lib/Data.Set.curry"` evaluates --- to `("lib","Data.Set")`. --- An error is raised if the program name is empty or the module name --- is not valid. splitValidProgramName :: String -> (FilePath, ModuleIdent) splitValidProgramName s | null mname = error $ "The module name is empty." | not (isValidModuleName mname) = error $ "The program name '" ++ s ++ "' contains an invalid module name." | otherwise = (dir,mname) where (dir,mname) = splitProgramName s --- Is the given string a valid module name? isValidModuleName :: String -> Bool isValidModuleName = all isModId . split (=='.') where isModId [] = False isModId (c:cs) = isAlpha c && all (\x -> isAlphaNum x || x `elem` "_'") cs --- Executes an I/O action, which is parameterized over a module name, --- for a given program name. If the program name is prefixed by a directory, --- switch to this directory before executing the action. --- A possible suffix like `.curry` or `.lcurry` is dropped from the --- module name passed to the action. --- An error is raised if the module name is not valid. runModuleAction :: (String -> IO a) -> String -> IO a runModuleAction modaction progname = do let (progdir,mname) = splitValidProgramName progname curdir <- getCurrentDirectory unless (progdir == ".") $ do putStrLn $ "Switching to directory '" ++ progdir ++ "'..." setCurrentDirectory progdir result <- modaction mname unless (progdir == ".") $ setCurrentDirectory curdir return result --- Split the `FilePath` of a module into the directory prefix and the --- `FilePath` corresponding to the module name. --- For instance, the call `splitModuleFileName "Data.Set" "lib/Data/Set.curry"` --- evaluates to `("lib", "Data/Set.curry")`. --- This can be useful to compute output directories while retaining the --- hierarchical module structure. splitModuleFileName :: ModuleIdent -> FilePath -> (FilePath, FilePath) splitModuleFileName mid fn = case splitModuleIdentifiers mid of [_] -> splitFileName fn ms -> let (base, ext) = splitExtension fn dirs = splitDirectories base (pre , suf) = splitAt (length dirs - length ms) dirs path = if null pre then "" else addTrailingPathSeparator (joinPath pre) in (path, joinPath suf <.> ext) --- Split up the components of a module identifier. For instance, --- `splitModuleIdentifiers "Data.Set"` evaluates to `["Data", "Set"]`. splitModuleIdentifiers :: ModuleIdent -> [String] splitModuleIdentifiers = split (=='.') --- Join the components of a module identifier. For instance, --- `joinModuleIdentifiers ["Data", "Set"]` evaluates to `"Data.Set"`. joinModuleIdentifiers :: [String] -> ModuleIdent joinModuleIdentifiers = foldr1 combine where combine xs ys = xs ++ '.' : ys --- Strips the suffix `.curry` or `.lcurry` from a file name. stripCurrySuffix :: String -> String stripCurrySuffix s = if takeExtension s `elem` [".curry",".lcurry"] then dropExtension s else s --- A module path consists of a directory prefix (which can be omitted) --- and a module name (which can be hierarchical). For instance, the --- following strings are module paths in Unix-based systems: --- --- HTML --- Data.Number.Int --- curry/Data.Number.Int type ModulePath = String --- Transforms a hierarchical module name into a path name, i.e., --- replace the dots in the name by directory separator chars. modNameToPath :: ModuleIdent -> String modNameToPath = foldr1 () . split (=='.') --- Name of the sub directory where auxiliary files (.fint, .fcy, etc) --- are stored. Note that the name of this directory depends --- on the compiler to avoid confusion when using different compilers. --- For instance, when using PAKCS 3.2.0, `currySubdir` evaluates --- to `".curry/pakcs-3.2.0"`. currySubdir :: FilePath currySubdir = ".curry" curryCompiler ++ "-" ++ intercalate "." (map show [curryCompilerMajorVersion, curryCompilerMinorVersion, curryCompilerRevisionVersion]) --- Transforms a path to a module name into a file name --- by adding the result of 'currySubDir' to the path and transforming --- a hierarchical module name into a path. --- For instance, when using PAKCS 3.2.0, `inCurrySubdir "mylib/Data.Char"` --- evaluates to `"mylib/.curry/pakcs-3.2.0/Data/Char"`. inCurrySubdir :: FilePath -> FilePath inCurrySubdir filename = let (base,file) = splitFileName filename in base currySubdir modNameToPath file --- Transforms a file name by adding the currySubDir to the file name. --- This version respects hierarchical module names. inCurrySubdirModule :: ModuleIdent -> FilePath -> FilePath inCurrySubdirModule m fn = let (dirP, modP) = splitModuleFileName m fn in dirP currySubdir modP --- Transforms a directory name into the name of the corresponding --- sub directory containing auxiliary files. addCurrySubdir :: FilePath -> FilePath addCurrySubdir dir = dir currySubdir ------------------------------------------------------------------------------ --- Finding files in correspondence to compiler load path ------------------------------------------------------------------------------ --- Returns the current path (list of directory names) of the --- system libraries. sysLibPath :: [String] sysLibPath = case curryCompiler of "pakcs" -> [installDir "lib"] "kics" -> [installDir "src" "lib"] "kics2" -> [installDir "lib"] _ -> error "Distribution.sysLibPath: unknown curryCompiler" --- Returns the current path (list of directory names) that is --- used for loading modules w.r.t. a given module path. --- The directory prefix of the module path (or "." if there is --- no such prefix) is the first element of the load path and the --- remaining elements are determined by the environment variable --- CURRYRPATH and the entry "libraries" of the system's rc file. getLoadPathForModule :: ModulePath -> IO [String] getLoadPathForModule modpath = do rcfile <- curryrcFileName mblib <- getPropertyFromFile rcfile "libraries" let fileDir = dropFileName modpath if curryCompiler `elem` ["pakcs","kics","kics2"] then do currypath <- getEnv "CURRYPATH" let llib = maybe [] (\l -> if null l then [] else splitSearchPath l) mblib return $ (fileDir : (if null currypath then [] else splitSearchPath currypath) ++ llib ++ sysLibPath) else error "Distribution.getLoadPathForModule: unknown curryCompiler" --- Returns a directory name and the actual source file name for a module --- by looking up the module source in the current load path. --- If the module is hierarchical, the directory is the top directory --- of the hierarchy. --- Returns Nothing if there is no corresponding source file. lookupModuleSourceInLoadPath :: ModulePath -> IO (Maybe (String,String)) lookupModuleSourceInLoadPath modpath = do loadpath <- getLoadPathForModule modpath lookupModuleSource loadpath modpath --- Returns a directory name and the actual source file name for a module --- by looking up the module source in the load path provided as the --- first argument. --- If the module is hierarchical, the directory is the top directory --- of the hierarchy. --- Returns Nothing if there is no corresponding source file. lookupModuleSource :: [String] -> String -> IO (Maybe (String,String)) lookupModuleSource loadpath mod = lookupSourceInPath loadpath where fn = takeFileName mod fnlcurry = modNameToPath fn ++ ".lcurry" fncurry = modNameToPath fn ++ ".curry" lookupSourceInPath [] = return Nothing lookupSourceInPath (dir:dirs) = do lcurryExists <- doesFileExist (dir fnlcurry) if lcurryExists then return (Just (dir, dir fnlcurry)) else do curryExists <- doesFileExist (dir fncurry) if curryExists then return (Just (dir, dir fncurry)) else lookupSourceInPath dirs ------------------------------------------------------------------------------ --- The name of the file specifying resource configuration parameters of the --- current distribution. --- This file must have the usual format of property files. curryrcFileName :: IO FilePath curryrcFileName = getHomeDirectory >>= return . ( rcFile) where rcFile = '.' : curryCompiler ++ "rc" ------------------------------------------------------------------------------ curry-tools-v3.3.0/optimize/.cpm/packages/directory/000077500000000000000000000000001377556325500225065ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/directory/LICENSE000066400000000000000000000027351377556325500235220ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/directory/package.json000066400000000000000000000014611377556325500247760ustar00rootroot00000000000000{ "name": "directory", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library for accessing the directory structure of the underlying operating system.", "category": [ "System" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "filepath": ">= 3.0.0, < 4.0.0", "time" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.Directory" ], "testsuite": { "src-dir": "test", "modules": [ "TestDirectory" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/directory.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/directory/src/000077500000000000000000000000001377556325500232755ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/directory/src/System/000077500000000000000000000000001377556325500245615ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/directory/src/System/Directory.curry000066400000000000000000000142261377556325500276200ustar00rootroot00000000000000--- Library for accessing the directory structure of the --- underlying operating system. --- --- @author Michael Hanus --- @version January 2013 --- @category general module System.Directory ( doesFileExist, doesDirectoryExist, getFileSize, getModificationTime , getCurrentDirectory, setCurrentDirectory , getDirectoryContents, createDirectory, createDirectoryIfMissing , removeDirectory, renameDirectory , getHomeDirectory, getTemporaryDirectory , getAbsolutePath , removeFile, renameFile, copyFile , findFileWithSuffix, getFileWithSuffix ) where import System.FilePath ( FilePath, (), splitDirectories, isAbsolute , normalise, pathSeparator, searchPathSeparator) import System.Environment (getEnv, isWindows) import Data.List (isPrefixOf, scanl1, last, intersperse) import Data.Time (ClockTime) --- Returns true if the argument is the name of an existing file. doesFileExist :: FilePath -> IO Bool doesFileExist fname = prim_doesFileExist $## fname prim_doesFileExist :: FilePath -> IO Bool prim_doesFileExist external --- Returns true if the argument is the name of an existing directory. doesDirectoryExist :: FilePath -> IO Bool doesDirectoryExist dir = prim_doesDirectoryExist $## dir prim_doesDirectoryExist :: FilePath -> IO Bool prim_doesDirectoryExist external --- Returns the size of the file. getFileSize :: FilePath -> IO Int getFileSize fname = prim_fileSize $## fname prim_fileSize :: FilePath -> IO Int prim_fileSize external --- Returns the modification time of the file. getModificationTime :: FilePath -> IO ClockTime getModificationTime fname = prim_getModificationTime $## fname prim_getModificationTime :: FilePath -> IO ClockTime prim_getModificationTime external --- Returns the current working directory. getCurrentDirectory :: IO FilePath getCurrentDirectory external --- Sets the current working directory. setCurrentDirectory :: FilePath -> IO () setCurrentDirectory dir = prim_setCurrentDirectory $## dir prim_setCurrentDirectory :: FilePath -> IO () prim_setCurrentDirectory external --- Returns the list of all entries in a directory. getDirectoryContents :: FilePath -> IO [FilePath] getDirectoryContents dir = prim_getDirectoryContents $## dir prim_getDirectoryContents :: FilePath -> IO [FilePath] prim_getDirectoryContents external --- Creates a new directory with the given name. createDirectory :: FilePath -> IO () createDirectory dir = prim_createDirectory $## dir prim_createDirectory :: FilePath -> IO () prim_createDirectory external --- Creates a new directory with the given name if it does not already exist. --- If the first parameter is `True` it will also create all missing --- parent directories. createDirectoryIfMissing :: Bool -> FilePath -> IO () createDirectoryIfMissing createParents path = if createParents then createDirs parents else createDirs [last parents] where parents = scanl1 () $ splitDirectories $ path createDirs [] = return () createDirs (d:ds) = do exists <- doesDirectoryExist d if exists then return () else createDirectory d createDirs ds --- Deletes a directory from the file system. removeDirectory :: FilePath -> IO () removeDirectory dir = prim_removeDirectory $## dir prim_removeDirectory :: FilePath -> IO () prim_removeDirectory external --- Renames a directory. renameDirectory :: FilePath -> FilePath -> IO () renameDirectory dir1 dir2 = (prim_renameDirectory $## dir1) $## dir2 prim_renameDirectory :: FilePath -> FilePath -> IO () prim_renameDirectory external --- Returns the home directory of the current user. getHomeDirectory :: IO FilePath getHomeDirectory = if isWindows then getEnv "USERPROFILE" else getEnv "HOME" --- Returns the temporary directory of the operating system. getTemporaryDirectory :: IO FilePath getTemporaryDirectory = if isWindows then getEnv "TMP" else return "/tmp" --- Convert a path name into an absolute one. --- For instance, a leading `~` is replaced by the current home directory. getAbsolutePath :: FilePath -> IO FilePath getAbsolutePath path | isAbsolute path = return (normalise path) | path == "~" = getHomeDirectory | "~/" `isPrefixOf` path = do homedir <- getHomeDirectory return (normalise (homedir drop 2 path)) | otherwise = do curdir <- getCurrentDirectory return (normalise (curdir path)) --- Deletes a file from the file system. removeFile :: FilePath -> IO () removeFile file = prim_removeFile $## file prim_removeFile :: FilePath -> IO () prim_removeFile external --- Renames a file. renameFile :: FilePath -> FilePath -> IO () renameFile file1 file2 = (prim_renameFile $## file1) $## file2 prim_renameFile :: FilePath -> FilePath -> IO () prim_renameFile external --- Copy the contents from one file to another file copyFile :: FilePath -> FilePath -> IO () copyFile src dest = readFile src >>= writeFile dest --- Looks up the first file with a possible suffix in a list of directories. --- Returns Nothing if such a file does not exist. findFileWithSuffix :: String -> [String] -> [String] -> IO (Maybe String) findFileWithSuffix file suffixes path = if isAbsolute file then lookupFirstFileWithSuffix file suffixes else lookupFirstFile path where lookupFirstFile [] = return Nothing lookupFirstFile (dir:dirs) = do mbfile <- lookupFirstFileWithSuffix (dir++pathSeparator:file) suffixes maybe (lookupFirstFile dirs) (return . Just) mbfile lookupFirstFileWithSuffix _ [] = return Nothing lookupFirstFileWithSuffix f (suf:sufs) = do let fsuf = f++suf exfile <- doesFileExist fsuf if exfile then return (Just fsuf) else lookupFirstFileWithSuffix f sufs --- Gets the first file with a possible suffix in a list of directories. --- An error message is delivered if there is no such file. getFileWithSuffix :: String -> [String] -> [String] -> IO String getFileWithSuffix file suffixes path = do mbfile <- findFileWithSuffix file suffixes path maybe (error $ "File "++file++" not found in path "++ concat (intersperse [searchPathSeparator] path)) return mbfile curry-tools-v3.3.0/optimize/.cpm/packages/directory/src/System/Directory.kics2000066400000000000000000000056421377556325500274710ustar00rootroot00000000000000import System.Directory import System.IO import System.Time external_d_C_prim_doesFileExist :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_doesFileExist s _ _ = toCurry doesFileExist s external_d_C_prim_doesDirectoryExist :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Bool external_d_C_prim_doesDirectoryExist s _ _ = toCurry doesDirectoryExist s external_d_C_prim_fileSize :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_prim_fileSize s _ _ = toCurry (\f -> do h <- openFile f ReadMode i <- hFileSize h hClose h return i ) s external_d_C_prim_getModificationTime :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Time.C_ClockTime external_d_C_prim_getModificationTime s _ _ = toCurry getModificationTime s external_d_C_getCurrentDirectory :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_String) external_d_C_getCurrentDirectory _ _ = toCurry getCurrentDirectory external_d_C_prim_setCurrentDirectory :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_setCurrentDirectory s _ _ = toCurry setCurrentDirectory s external_d_C_prim_getDirectoryContents :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_List (Curry_Prelude.C_String)) external_d_C_prim_getDirectoryContents s _ _ = toCurry getDirectoryContents s external_d_C_prim_createDirectory :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_createDirectory s _ _ = toCurry createDirectory s external_d_C_prim_removeFile :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_removeFile s _ _ = toCurry removeFile s external_d_C_prim_removeDirectory :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_removeDirectory s _ _ = toCurry removeDirectory s external_d_C_prim_renameFile :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_renameFile s1 s2 _ _ = toCurry renameFile s1 s2 external_d_C_prim_renameDirectory :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_renameDirectory s1 s2 _ _= toCurry renameDirectory s1 s2 curry-tools-v3.3.0/optimize/.cpm/packages/directory/src/System/Directory.pakcs.pl000066400000000000000000000035011377556325500301610ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module Directory: % 'System.Directory.prim_doesFileExist'(FileName,Exists) :- string2Atom(FileName,FName), (existsFile(FName) -> Exists='Prelude.True' ; Exists='Prelude.False'). 'System.Directory.prim_doesDirectoryExist'(DirName,Exists) :- string2Atom(DirName,Dir), (existsDirectory(Dir) -> Exists='Prelude.True' ; Exists='Prelude.False'). 'System.Directory.prim_getModificationTime'(FileName,'Data.Time.CTime'(Time)) :- string2Atom(FileName,FName), fileModTime(FName,Time). 'System.Directory.prim_fileSize'(FileName,Size) :- string2Atom(FileName,FName), fileSize(FName,Size). 'System.Directory.getCurrentDirectory'(DirName) :- workingDirectory(Dir), atom2String(Dir,DirName). 'System.Directory.prim_setCurrentDirectory'(DirName,'Prelude.()') :- string2Atom(DirName,Dir), setWorkingDirectory(Dir). 'System.Directory.prim_getDirectoryContents'(DirName,EntryNames) :- string2Atom(DirName,Dir), directoryFiles(Dir,Entries), map2M(basics:atom2String,Entries,EntryNames). 'System.Directory.prim_createDirectory'(DirName,'Prelude.()') :- string2Atom(DirName,DName), makeDirectory(DName). 'System.Directory.prim_removeFile'(FileName,'Prelude.()') :- string2Atom(FileName,FName), deleteFile(FName). 'System.Directory.prim_removeDirectory'(DirName,'Prelude.()') :- string2Atom(DirName,DName), deleteDirectory(DName). 'System.Directory.prim_renameFile'(FileName1,FileName2,'Prelude.()') :- string2Atom(FileName1,FName1), string2Atom(FileName2,FName2), renameFile(FName1,FName2). 'System.Directory.prim_renameDirectory'(DirName1,DirName2,'Prelude.()') :- string2Atom(DirName1,DName1), string2Atom(DirName2,DName2), renameDirectory(DName1,DName2). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% curry-tools-v3.3.0/optimize/.cpm/packages/directory/test/000077500000000000000000000000001377556325500234655ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/directory/test/TestDirectory.curry000066400000000000000000000041721377556325500273630ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some tests for library System.Directory --- --- To run all tests automatically by the currycheck tool, use the command: --- "curry-check TestDirectory" --- --- @author Michael Hanus --- @version November 2020 ------------------------------------------------------------------------------ import System.Directory import Data.List --import System import Test.Prop testCreateRenameDeleteFile = fileOps `returns` (True,False,True,False) where fileOps = do let fname = "xxx1234" fnamebak = fname++".bak" writeFile fname "test\n" ex1 <- doesFileExist fname renameFile fname fnamebak ex2 <- doesFileExist fname ex3 <- doesFileExist fnamebak removeFile fnamebak ex4 <- doesFileExist fnamebak return (ex1,ex2,ex3,ex4) testCreateRenameDeleteDirectory = dirOps `returns` (True,False,True,False) where dirOps = do let dname = "xxx1111" dnamebak = dname++".bak" createDirectory dname ex1 <- doesDirectoryExist dname renameDirectory dname dnamebak ex2 <- doesDirectoryExist dname ex3 <- doesDirectoryExist dnamebak removeDirectory dnamebak ex4 <- doesDirectoryExist dnamebak return (ex1,ex2,ex3,ex4) testGetSetDirectory = dirOps `returns` (True,True,"abcdef",False) where dirOps = do cdir <- getCurrentDirectory let dname = cdir++"/xxx2222" createDirectory dname ex1 <- doesDirectoryExist dname writeFile (dname++"/xxx") "abcdef" setCurrentDirectory dname ex2 <- doesFileExist "xxx" cnt <- readFile "xxx" cnt==cnt `seq` removeFile "xxx" setCurrentDirectory cdir removeDirectory dname ex3 <- doesDirectoryExist dname return (ex1,ex2,cnt,ex3) testGetDirectoryContents = dirOps `returns` [".","..","xxx"] where dirOps = do cdir <- getCurrentDirectory let dname = cdir++"/xxx3333" createDirectory dname setCurrentDirectory dname d <- getCurrentDirectory writeFile "xxx" "Hello\n" fs <- getDirectoryContents d fs==fs `seq` removeFile "xxx" setCurrentDirectory cdir removeDirectory dname return (sort fs) curry-tools-v3.3.0/optimize/.cpm/packages/filepath/000077500000000000000000000000001377556325500222765ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/filepath/LICENSE000066400000000000000000000027351377556325500233120ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/filepath/package.json000066400000000000000000000013521377556325500245650ustar00rootroot00000000000000{ "name": "filepath", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "A library for FilePath manipulations, using Posix or Windows filepaths depending on the platform.", "category": [ "System" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.FilePath" ], "testsuite": { "src-dir": "test", "modules": [ "TestFilePath" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/filepath.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/filepath/src/000077500000000000000000000000001377556325500230655ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/filepath/src/System/000077500000000000000000000000001377556325500243515ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/filepath/src/System/FilePath.curry000066400000000000000000000733751377556325500271520ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library is a direct port of the Haskell library System.FilePath --- of Neil Mitchell. --- --- @author Bjoern Peemoeller --- @version November 2011 --- @category general ------------------------------------------------------------------------------ -- -- Some short examples: -- -- You are given a C file, you want to figure out the corresponding object (.o) file: -- -- @'replaceExtension' file \"o\"@ -- -- Haskell module Main imports Test, you have the file named main: -- -- @['replaceFileName' path_to_main \"Test\" '<.>' ext | ext <- [\"hs\",\"lhs\"] ]@ -- -- You want to download a file from the web and save it to disk: -- -- @do let file = 'makeValid' url -- System.IO.createDirectoryIfMissing True ('takeDirectory' file)@ -- -- You want to compile a Haskell file, but put the hi file under \"interface\" -- -- @'takeDirectory' file '' \"interface\" '' ('takeFileName' file \`replaceExtension\` \"hi\"@) -- -- The examples in code format descibed by each function are used to generate -- tests, and should give clear semantics for the functions. ----------------------------------------------------------------------------- module System.FilePath ( -- * Separator predicates FilePath, pathSeparator, pathSeparators, isPathSeparator, searchPathSeparator, isSearchPathSeparator, extSeparator, isExtSeparator, -- * Path methods (environment $PATH) splitSearchPath, getSearchPath, -- * Extension methods splitExtension, takeExtension, replaceExtension, dropExtension, addExtension, hasExtension, (<.>), splitExtensions, dropExtensions, takeExtensions, isExtensionOf, -- * Drive methods splitDrive, joinDrive, takeDrive, hasDrive, dropDrive, isDrive, -- * Operations on a FilePath, as a list of directories splitFileName, takeFileName, replaceFileName, dropFileName, takeBaseName, replaceBaseName, takeDirectory, replaceDirectory, combine, (), splitPath, joinPath, splitDirectories, -- * Low level FilePath operators hasTrailingPathSeparator, addTrailingPathSeparator, dropTrailingPathSeparator, -- * File name manipulators normalise, equalFilePath, makeRelative, isRelative, isAbsolute, isValid, makeValid ) where import Data.Char (toLower, toUpper) import Data.List (isSuffixOf, isPrefixOf, init, last, intersperse) import Data.Maybe (isJust, fromJust) import System.Environment (getEnv, isPosix, isWindows) infixr 7 <.> infixr 5 --------------------------------------------------------------------- -- The basic functions -- | The character that separates directories. In the case where more than -- one character is possible, 'pathSeparator' is the \'ideal\' one. -- -- > Windows: pathSeparator == '\\' -- > Posix: pathSeparator == '/' -- > isPathSeparator pathSeparator pathSeparator :: Char pathSeparator = if isWindows then '\\' else '/' -- | The list of all possible separators. -- -- > Windows: pathSeparators == ['\\', '/'] -- > Posix: pathSeparators == ['/'] -- > pathSeparator `elem` pathSeparators pathSeparators :: [Char] pathSeparators = if isWindows then "\\/" else "/" -- | Rather than using @(== 'pathSeparator')@, use this. Test if something -- is a path separator. -- -- > isPathSeparator a == (a `elem` pathSeparators) isPathSeparator :: Char -> Bool isPathSeparator = (`elem` pathSeparators) -- | The character that is used to separate the entries in the $PATH -- environment variable. -- -- > Windows: searchPathSeparator == ';' -- > Posix: searchPathSeparator == ':' searchPathSeparator :: Char searchPathSeparator = if isWindows then ';' else ':' -- | Is the character a file separator? -- -- > isSearchPathSeparator a == (a == searchPathSeparator) isSearchPathSeparator :: Char -> Bool isSearchPathSeparator = (== searchPathSeparator) -- | File extension character -- -- > extSeparator == '.' extSeparator :: Char extSeparator = '.' -- | Is the character an extension character? -- -- > isExtSeparator a == (a == extSeparator) isExtSeparator :: Char -> Bool isExtSeparator = (== extSeparator) --------------------------------------------------------------------- -- Path methods (environment $PATH) -- | Take a string, split it on the 'searchPathSeparator' character. -- -- Follows the recommendations in -- -- -- > Posix: splitSearchPath "File1:File2:File3" == ["File1","File2","File3"] -- > Posix: splitSearchPath "File1::File2:File3" == ["File1",".","File2","File3"] -- > Windows: splitSearchPath "File1;File2;File3" == ["File1","File2","File3"] -- > Windows: splitSearchPath "File1;;File2;File3" == ["File1","File2","File3"] splitSearchPath :: String -> [FilePath] splitSearchPath = f where f xs = case break isSearchPathSeparator xs of (pre, [] ) -> g pre (pre, _:post) -> g pre ++ f post g [] = ["." | isPosix] g x@(_:_) = [x] -- | Get a list of filepaths in the $PATH. getSearchPath :: IO [FilePath] getSearchPath = getEnv "PATH" >>= return . splitSearchPath --------------------------------------------------------------------- -- Extension methods -- | Split on the extension. 'addExtension' is the inverse. -- -- > uncurry (++) (splitExtension x) == x -- > uncurry addExtension (splitExtension x) == x -- > splitExtension "file.txt" == ("file",".txt") -- > splitExtension "file" == ("file","") -- > splitExtension "file/file.txt" == ("file/file",".txt") -- > splitExtension "file.txt/boris" == ("file.txt/boris","") -- > splitExtension "file.txt/boris.ext" == ("file.txt/boris",".ext") -- > splitExtension "file/path.txt.bob.fred" == ("file/path.txt.bob",".fred") -- > splitExtension "file/path.txt/" == ("file/path.txt/","") splitExtension :: FilePath -> (String, String) splitExtension x = case d of [] -> (x,"") (y:ys) -> (a ++ reverse ys, y : reverse c) where (a,b) = splitFileName_ x (c,d) = break isExtSeparator $ reverse b -- | Get the extension of a file, returns @\"\"@ for no extension, @.ext@ otherwise. -- -- > takeExtension x == snd (splitExtension x) -- > Valid x => takeExtension (addExtension x "ext") == ".ext" -- > Valid x => takeExtension (replaceExtension x "ext") == ".ext" takeExtension :: FilePath -> String takeExtension = snd . splitExtension -- | Set the extension of a file, overwriting one if already present. -- -- > replaceExtension "file.txt" ".bob" == "file.bob" -- > replaceExtension "file.txt" "bob" == "file.bob" -- > replaceExtension "file" ".bob" == "file.bob" -- > replaceExtension "file.txt" "" == "file" -- > replaceExtension "file.fred.bob" "txt" == "file.fred.txt" replaceExtension :: FilePath -> String -> FilePath replaceExtension x y = dropExtension x <.> y -- | Alias to 'addExtension', for people who like that sort of thing. (<.>) :: FilePath -> String -> FilePath (<.>) = addExtension -- | Remove last extension, and the \".\" preceding it. -- -- > dropExtension x == fst (splitExtension x) dropExtension :: FilePath -> FilePath dropExtension = fst . splitExtension -- | Add an extension, even if there is already one there. -- E.g. @addExtension \"foo.txt\" \"bat\" -> \"foo.txt.bat\"@. -- -- > addExtension "file.txt" "bib" == "file.txt.bib" -- > addExtension "file." ".bib" == "file..bib" -- > addExtension "file" ".bib" == "file.bib" -- > addExtension "/" "x" == "/.x" -- > Valid x => takeFileName (addExtension (addTrailingPathSeparator x) "ext") == ".ext" -- > Windows: addExtension "\\\\share" ".txt" == "\\\\share\\.txt" addExtension :: FilePath -> String -> FilePath addExtension file [] = file addExtension file xs@(x:_) = joinDrive a res where res = if isExtSeparator x then b ++ xs else b ++ [extSeparator] ++ xs (a,b) = splitDrive file -- | Does the given filename have an extension? -- -- > null (takeExtension x) == not (hasExtension x) hasExtension :: FilePath -> Bool hasExtension = any isExtSeparator . takeFileName -- | Split on all extensions -- -- > uncurry (++) (splitExtensions x) == x -- > uncurry addExtension (splitExtensions x) == x -- > splitExtensions "file.tar.gz" == ("file",".tar.gz") splitExtensions :: FilePath -> (FilePath, String) splitExtensions x = (a ++ c, d) where (a,b) = splitFileName_ x (c,d) = break isExtSeparator b -- | Drop all extensions -- -- > not $ hasExtension (dropExtensions x) dropExtensions :: FilePath -> FilePath dropExtensions = fst . splitExtensions -- | Get all extensions -- -- > takeExtensions "file.tar.gz" == ".tar.gz" takeExtensions :: FilePath -> String takeExtensions = snd . splitExtensions -- | Does the given filename have the specified extension? -- -- > "png" `isExtensionOf` "/directory/file.png" == True -- > ".png" `isExtensionOf` "/directory/file.png" == True -- > ".tar.gz" `isExtensionOf` "bar/foo.tar.gz" == True -- > "ar.gz" `isExtensionOf` "bar/foo.tar.gz" == False -- > "png" `isExtensionOf` "/directory/file.png.jpg" == False -- > "csv/table.csv" `isExtensionOf` "/data/csv/table.csv" == False isExtensionOf :: String -> FilePath -> Bool isExtensionOf extension path = case extension of ext@('.':_) -> isSuffixOf ext $ takeExtensions path ext -> isSuffixOf ('.':ext) $ takeExtensions path --------------------------------------------------------------------- -- Drive methods -- | Is the given character a valid drive letter? -- only a-z and A-Z are letters, not isAlpha which is more unicodey isLetter :: Char -> Bool isLetter x = (x >= 'a' && x <= 'z') || (x >= 'A' && x <= 'Z') -- | Split a path into a drive and a path. -- On Unix, \/ is a Drive. -- -- > uncurry (++) (splitDrive x) == x -- > Windows: splitDrive "file" == ("","file") -- > Windows: splitDrive "c:/file" == ("c:/","file") -- > Windows: splitDrive "c:\\file" == ("c:\\","file") -- > Windows: splitDrive "\\\\shared\\test" == ("\\\\shared\\","test") -- > Windows: splitDrive "\\\\shared" == ("\\\\shared","") -- > Windows: splitDrive "\\\\?\\UNC\\shared\\file" == ("\\\\?\\UNC\\shared\\","file") -- > Windows: splitDrive "\\\\?\\UNCshared\\file" == ("\\\\?\\","UNCshared\\file") -- > Windows: splitDrive "\\\\?\\d:\\file" == ("\\\\?\\d:\\","file") -- > Windows: splitDrive "/d" == ("","/d") -- > Posix: splitDrive "/test" == ("/","test") -- > Posix: splitDrive "//test" == ("//","test") -- > Posix: splitDrive "test/file" == ("","test/file") -- > Posix: splitDrive "file" == ("","file") splitDrive :: FilePath -> (FilePath, FilePath) splitDrive x | isPosix = span (== '/') x | isJust dl = fromJust dl | isJust unc = fromJust unc | isJust shr = fromJust shr | otherwise = ("",x) where dl = readDriveLetter x unc = readDriveUNC x shr = readDriveShare x addSlash :: FilePath -> FilePath -> (FilePath, FilePath) addSlash a xs = (a++c,d) where (c,d) = span isPathSeparator xs -- http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp -- "\\?\D:\" or "\\?\UNC\\" -- a is "\\?\" readDriveUNC :: FilePath -> Maybe (FilePath, FilePath) readDriveUNC path = case path of (s1:s2:'?':s3:xs) -> if all isPathSeparator [s1,s2,s3] then let rdl = case readDriveLetter xs of Just (a,b) -> Just (s1:s2:'?':s3:a,b) Nothing -> Nothing in case map toUpper xs of ('U':'N':'C':s4:_) -> if isPathSeparator s4 then let (a,b) = readDriveShareName (drop 4 xs) in Just (s1:s2:'?':s3:take 4 xs ++ a, b) else rdl _ -> rdl else Nothing _ -> Nothing {- c:\ -} readDriveLetter :: String -> Maybe (FilePath, FilePath) readDriveLetter path = case path of (x:':':y:xs) -> if isLetter x && isPathSeparator y then Just $ addSlash [x,':'] (y:xs) else if isLetter x then Just ([x,':'], (y:xs)) else Nothing (x:':':xs) -> if isLetter x then Just ([x,':'], xs) else Nothing _ -> Nothing {- \\sharename\ -} readDriveShare :: String -> Maybe (FilePath, FilePath) readDriveShare path = case path of (s1:s2:xs) -> if isPathSeparator s1 && isPathSeparator s2 then let (a,b) = readDriveShareName xs in Just (s1:s2:a,b) else Nothing _ -> Nothing {- assume you have already seen \\ -} {- share\bob -> "share","\","bob" -} readDriveShareName :: String -> (FilePath, FilePath) readDriveShareName name = addSlash a b where (a,b) = break isPathSeparator name -- | Join a drive and the rest of the path. -- -- > uncurry joinDrive (splitDrive x) == x -- > Windows: joinDrive "C:" "foo" == "C:foo" -- > Windows: joinDrive "C:\\" "bar" == "C:\\bar" -- > Windows: joinDrive "\\\\share" "foo" == "\\\\share\\foo" -- > Windows: joinDrive "/:" "foo" == "/:\\foo" joinDrive :: FilePath -> FilePath -> FilePath joinDrive a b | isPosix = a ++ b | null a = b | null b = a | isPathSeparator (last a) = a ++ b | otherwise = case a of [a1,':'] -> if isLetter a1 then a ++ b else a ++ [pathSeparator] ++ b _ -> a ++ [pathSeparator] ++ b -- | Get the drive from a filepath. -- -- > takeDrive x == fst (splitDrive x) takeDrive :: FilePath -> FilePath takeDrive = fst . splitDrive -- | Delete the drive, if it exists. -- -- > dropDrive x == snd (splitDrive x) dropDrive :: FilePath -> FilePath dropDrive = snd . splitDrive -- | Does a path have a drive. -- -- > not (hasDrive x) == null (takeDrive x) hasDrive :: FilePath -> Bool hasDrive = not . null . takeDrive -- | Is an element a drive isDrive :: FilePath -> Bool isDrive = null . dropDrive --------------------------------------------------------------------- -- Operations on a filepath, as a list of directories -- | Split a filename into directory and file. 'combine' is the inverse. -- -- > Valid x => uncurry () (splitFileName x) == x || fst (splitFileName x) == "./" -- > Valid x => isValid (fst (splitFileName x)) -- > splitFileName "file/bob.txt" == ("file/", "bob.txt") -- > splitFileName "file/" == ("file/", "") -- > splitFileName "bob" == ("./", "bob") -- > Posix: splitFileName "/" == ("/","") -- > Windows: splitFileName "c:" == ("c:","") splitFileName :: FilePath -> (String, String) splitFileName x = (if null dir then "./" else dir, name) where (dir, name) = splitFileName_ x -- version of splitFileName where, if the FilePath has no directory -- component, the returned directory is "" rather than "./". This -- is used in cases where we are going to combine the returned -- directory to make a valid FilePath, and having a "./" appear would -- look strange and upset simple equality properties. See -- e.g. replaceFileName. splitFileName_ :: FilePath -> (String, String) splitFileName_ x = (c ++ reverse b, reverse a) where (a,b) = break isPathSeparator $ reverse d (c,d) = splitDrive x -- | Set the filename. -- -- > Valid x => replaceFileName x (takeFileName x) == x replaceFileName :: FilePath -> String -> FilePath replaceFileName x y = a y where (a,_) = splitFileName_ x -- | Drop the filename. -- -- > dropFileName x == fst (splitFileName x) dropFileName :: FilePath -> FilePath dropFileName = fst . splitFileName -- | Get the file name. -- -- > takeFileName "test/" == "" -- > takeFileName x `isSuffixOf` x -- > takeFileName x == snd (splitFileName x) -- > Valid x => takeFileName (replaceFileName x "fred") == "fred" -- > Valid x => takeFileName (x "fred") == "fred" -- > Valid x => isRelative (takeFileName x) takeFileName :: FilePath -> FilePath takeFileName = snd . splitFileName -- | Get the base name, without an extension or path. -- -- > takeBaseName "file/test.txt" == "test" -- > takeBaseName "dave.ext" == "dave" -- > takeBaseName "" == "" -- > takeBaseName "test" == "test" -- > takeBaseName (addTrailingPathSeparator x) == "" -- > takeBaseName "file/file.tar.gz" == "file.tar" takeBaseName :: FilePath -> String takeBaseName = dropExtension . takeFileName -- | Set the base name. -- -- > replaceBaseName "file/test.txt" "bob" == "file/bob.txt" -- > replaceBaseName "fred" "bill" == "bill" -- > replaceBaseName "/dave/fred/bob.gz.tar" "new" == "/dave/fred/new.tar" -- > Valid x => replaceBaseName x (takeBaseName x) == x replaceBaseName :: FilePath -> String -> FilePath replaceBaseName pth nam = combineAlways a (nam <.> ext) where (a,b) = splitFileName_ pth ext = takeExtension b -- | Is an item either a directory or the last character a path separator? -- -- > hasTrailingPathSeparator "test" == False -- > hasTrailingPathSeparator "test/" == True hasTrailingPathSeparator :: FilePath -> Bool hasTrailingPathSeparator [] = False hasTrailingPathSeparator x@(_:_) = isPathSeparator (last x) -- | Add a trailing file path separator if one is not already present. -- -- > hasTrailingPathSeparator (addTrailingPathSeparator x) -- > hasTrailingPathSeparator x ==> addTrailingPathSeparator x == x -- > Posix: addTrailingPathSeparator "test/rest" == "test/rest/" addTrailingPathSeparator :: FilePath -> FilePath addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pathSeparator] -- | Remove any trailing path separators -- -- > dropTrailingPathSeparator "file/test/" == "file/test" -- > Posix: not (hasTrailingPathSeparator (dropTrailingPathSeparator x)) || isDrive x -- > Posix: dropTrailingPathSeparator "/" == "/" -- > Windows: dropTrailingPathSeparator "\\" == "\\" dropTrailingPathSeparator :: FilePath -> FilePath dropTrailingPathSeparator x = if hasTrailingPathSeparator x && not (isDrive x) then let x' = reverse $ dropWhile isPathSeparator $ reverse x in if null x' then [pathSeparator] else x' else x -- | Get the directory name, move up one level. -- -- > takeDirectory x `isPrefixOf` x || takeDirectory x == "." -- > takeDirectory "foo" == "." -- > takeDirectory "/foo/bar/baz" == "/foo/bar" -- > takeDirectory "/foo/bar/baz/" == "/foo/bar/baz" -- > takeDirectory "foo/bar/baz" == "foo/bar" -- > Windows: takeDirectory "foo\\bar" == "foo" -- > Windows: takeDirectory "foo\\bar\\\\" == "foo\\bar" -- > Windows: takeDirectory "C:\\" == "C:\\" takeDirectory :: FilePath -> FilePath takeDirectory x = if isDrive file then file else if null res && not (null file) then file else res where res = reverse $ dropWhile isPathSeparator $ reverse file file = dropFileName x _ = isPrefixOf x -- warning suppression -- | Set the directory, keeping the filename the same. -- -- > Valid x => replaceDirectory x (takeDirectory x) `equalFilePath` x replaceDirectory :: FilePath -> String -> FilePath replaceDirectory x dir = combineAlways dir (takeFileName x) -- | Combine two paths, if the second path 'isAbsolute', then it returns the second. -- -- > Valid x => combine (takeDirectory x) (takeFileName x) `equalFilePath` x -- > Posix: combine "/" "test" == "/test" -- > Posix: combine "home" "bob" == "home/bob" -- > Windows: combine "home" "bob" == "home\\bob" -- > Windows: combine "home" "/bob" == "/bob" combine :: FilePath -> FilePath -> FilePath combine a b | hasDrive b || (not (null b) && isPathSeparator (head b)) = b | otherwise = combineAlways a b -- | Combine two paths, assuming rhs is NOT absolute. combineAlways :: FilePath -> FilePath -> FilePath combineAlways a b | null a = b | null b = a | isPathSeparator (last a) = a ++ b | isDrive a = joinDrive a b | otherwise = a ++ [pathSeparator] ++ b -- | A nice alias for 'combine'. () :: FilePath -> FilePath -> FilePath () = combine -- | Split a path by the directory separator. -- -- > concat (splitPath x) == x -- > splitPath "test//item/" == ["test//","item/"] -- > splitPath "test/item/file" == ["test/","item/","file"] -- > splitPath "" == [] -- > Windows: splitPath "c:\\test\\path" == ["c:\\","test\\","path"] -- > Posix: splitPath "/file/test" == ["/","file/","test"] splitPath :: FilePath -> [FilePath] splitPath x = [drive | drive /= ""] ++ f path where (drive,path) = splitDrive x f [] = [] f y@(_:_) = (a ++ c) : f d where (a,b) = break isPathSeparator y (c,d) = break (not . isPathSeparator) b -- | Just as 'splitPath', but don't add the trailing slashes to each element. -- -- > splitDirectories "test/file" == ["test","file"] -- > splitDirectories "/test/file" == ["/","test","file"] -- > Valid x => joinPath (splitDirectories x) `equalFilePath` x -- > splitDirectories "" == [] splitDirectories :: FilePath -> [FilePath] splitDirectories path = if hasDrive path then head pathComponents : f (tail pathComponents) else f pathComponents where pathComponents = splitPath path f xs = map g xs g x = if null res then x else res where res = takeWhile (not . isPathSeparator) x -- | Join path elements back together. -- -- > Valid x => joinPath (splitPath x) == x -- > joinPath [] == "" -- > Posix: joinPath ["test","file","path"] == "test/file/path" -- Note that this definition on c:\\c:\\, join then split will give c:\\. joinPath :: [FilePath] -> FilePath joinPath x = foldr combine "" x --------------------------------------------------------------------- -- File name manipulators -- | Equality of two 'FilePath's. -- If you call @System.Directory.canonicalizePath@ -- first this has a much better chance of working. -- Note that this doesn't follow symlinks or DOSNAM~1s. -- -- > x == y ==> equalFilePath x y -- > normalise x == normalise y ==> equalFilePath x y -- > Posix: equalFilePath "foo" "foo/" -- > Posix: not (equalFilePath "foo" "/foo") -- > Posix: not (equalFilePath "foo" "FOO") -- > Windows: equalFilePath "foo" "FOO" equalFilePath :: FilePath -> FilePath -> Bool equalFilePath a b = f a == f b where f x | isWindows = dropTrailSlash $ map toLower $ normalise x | otherwise = dropTrailSlash $ normalise x dropTrailSlash x | length x >= 2 && isPathSeparator (last x) = init x | otherwise = x -- | Contract a filename, based on a relative path. -- -- There is no corresponding @makeAbsolute@ function, instead use -- @System.Directory.canonicalizePath@ which has the same effect. -- -- > Valid y => equalFilePath x y || (isRelative x && makeRelative y x == x) || equalFilePath (y makeRelative y x) x -- > makeRelative x x == "." -- > null y || equalFilePath (makeRelative x (x y)) y || null (takeFileName x) -- > Windows: makeRelative "C:\\Home" "c:\\home\\bob" == "bob" -- > Windows: makeRelative "C:\\Home" "c:/home/bob" == "bob" -- > Windows: makeRelative "C:\\Home" "D:\\Home\\Bob" == "D:\\Home\\Bob" -- > Windows: makeRelative "C:\\Home" "C:Home\\Bob" == "C:Home\\Bob" -- > Windows: makeRelative "/Home" "/home/bob" == "bob" -- > Posix: makeRelative "/Home" "/home/bob" == "/home/bob" -- > Posix: makeRelative "/home/" "/home/bob/foo/bar" == "bob/foo/bar" -- > Posix: makeRelative "/fred" "bob" == "bob" -- > Posix: makeRelative "/file/test" "/file/test/fred" == "fred" -- > Posix: makeRelative "/file/test" "/file/test/fred/" == "fred/" -- > Posix: makeRelative "some/path" "some/path/a/b/c" == "a/b/c" makeRelative :: FilePath -> FilePath -> FilePath makeRelative root path | equalFilePath root path = "." | takeAbs root /= takeAbs path = path | otherwise = f (dropAbs root) (dropAbs path) where f [] y = dropWhile isPathSeparator y f x@(_:_) y = let (x1,x2) = g x (y1,y2) = g y in if equalFilePath x1 y1 then f x2 y2 else path g x = (dropWhile isPathSeparator a, dropWhile isPathSeparator b) where (a,b) = break isPathSeparator $ dropWhile isPathSeparator x -- on windows, need to drop '/' which is kind of absolute, but not a drive dropAbs [] = dropDrive [] dropAbs (x:xs) | isPathSeparator x = xs | otherwise = dropDrive (x:xs) takeAbs [] = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive [] takeAbs xs@(x:_) | isPathSeparator x = [pathSeparator] | otherwise = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive xs -- | Normalise a file -- -- * \/\/ outside of the drive can be made blank -- -- * \/ -> 'pathSeparator' -- -- * .\/ -> \"\" -- -- > Posix: normalise "/file/\\test////" == "/file/\\test/" -- > Posix: normalise "/file/./test" == "/file/test" -- > Posix: normalise "/test/file/../bob/fred/" == "/test/file/../bob/fred/" -- > Posix: normalise "../bob/fred/" == "../bob/fred/" -- > Posix: normalise "./bob/fred/" == "bob/fred/" -- > Windows: normalise "c:\\file/bob\\" == "C:\\file\\bob\\" -- > Windows: normalise "c:\\" == "C:\\" -- > Windows: normalise "\\\\server\\test" == "\\\\server\\test" -- > Windows: normalise "c:/file" == "C:\\file" -- > normalise "." == "." -- > Posix: normalise "./" == "./" -- > Posix: normalise "./." == "./" -- > Posix: normalise "bob/fred/." == "bob/fred/" normalise :: FilePath -> FilePath normalise path = joinDrive (normaliseDrive drv) (f pth) ++ [pathSeparator | isDirPath pth] where (drv,pth) = splitDrive path isDirPath xs = lastSep xs || not (null xs) && last xs == '.' && lastSep (init xs) lastSep xs = not (null xs) && isPathSeparator (last xs) f = joinPath . dropDots . splitDirectories . propSep propSep [] = [] propSep xs@[x] | isPathSeparator x = [pathSeparator] | otherwise = xs propSep (x:y:xs) | isPathSeparator x && isPathSeparator y = propSep (x:xs) | isPathSeparator x = pathSeparator : propSep (y:xs) | otherwise = x : propSep (y:xs) dropDots xs | all (== ".") xs = ["."] | otherwise = dropDots' [] xs dropDots' acc [] = reverse acc dropDots' acc (x:xs) | x == "." = dropDots' acc xs | otherwise = dropDots' (x:acc) xs normaliseDrive :: FilePath -> FilePath normaliseDrive drive | isPosix = drive | otherwise = if isJust $ readDriveLetter x2 then map toUpper x2 else drive where x2 = map repSlash drive repSlash x = if isPathSeparator x then pathSeparator else x -- information for validity functions on Windows -- see http://msdn.microsoft.com/library/default.asp?url=/library/en-us/fileio/fs/naming_a_file.asp badCharacters :: [Char] badCharacters = ":*?><|\"" badElements :: [FilePath] badElements = ["CON", "PRN", "AUX", "NUL", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9", "CLOCK$"] -- | Is a FilePath valid, i.e. could you create a file like it? -- -- > isValid "" == False -- > Posix: isValid "/random_ path:*" == True -- > Posix: isValid x == not (null x) -- > Windows: isValid "c:\\test" == True -- > Windows: isValid "c:\\test:of_test" == False -- > Windows: isValid "test*" == False -- > Windows: isValid "c:\\test\\nul" == False -- > Windows: isValid "c:\\test\\prn.txt" == False -- > Windows: isValid "c:\\nul\\file" == False -- > Windows: isValid "\\\\" == False isValid :: FilePath -> Bool isValid [] = False isValid path@(_:_) | isPosix = True | otherwise = not (any (`elem` badCharacters) x2) && not (any f $ splitDirectories x2) && not (length path >= 2 && all isPathSeparator path) where x2 = dropDrive path f x = map toUpper (dropExtensions x) `elem` badElements -- | Take a FilePath and make it valid; does not change already valid FilePaths. -- -- > isValid (makeValid x) -- > isValid x ==> makeValid x == x -- > makeValid "" == "_" -- > Windows: makeValid "c:\\test:of_test" == "c:\\test_of_test" -- > Windows: makeValid "test*" == "test_" -- > Windows: makeValid "c:\\test\\nul" == "c:\\test\\nul_" -- > Windows: makeValid "c:\\test\\prn.txt" == "c:\\test\\prn_.txt" -- > Windows: makeValid "c:\\test/prn.txt" == "c:\\test/prn_.txt" -- > Windows: makeValid "c:\\nul\\file" == "c:\\nul_\\file" makeValid :: FilePath -> FilePath makeValid [] = "_" makeValid path@(_:_) | isPosix = path | length path >= 2 && all isPathSeparator path = take 2 path ++ "drive" | otherwise = joinDrive drv $ validElements $ validChars pth where (drv,pth) = splitDrive path validChars x = map f x f x | x `elem` badCharacters = '_' | otherwise = x validElements x = joinPath $ map g $ splitPath x g x = h (reverse b) ++ reverse a where (a,b) = span isPathSeparator $ reverse x h x = if map toUpper a `elem` badElements then a ++ "_" <.> b else x where (a,b) = splitExtensions x -- | Is a path relative, or is it fixed to the root? -- -- > Windows: isRelative "path\\test" == True -- > Windows: isRelative "c:\\test" == False -- > Windows: isRelative "c:test" == True -- > Windows: isRelative "c:" == True -- > Windows: isRelative "\\\\foo" == False -- > Windows: isRelative "/foo" == True -- > Posix: isRelative "test/path" == True -- > Posix: isRelative "/test" == False isRelative :: FilePath -> Bool isRelative = isRelativeDrive . takeDrive -- > isRelativeDrive "" == True -- > Windows: isRelativeDrive "c:\\" == False -- > Windows: isRelativeDrive "c:/" == False -- > Windows: isRelativeDrive "c:" == True -- > Windows: isRelativeDrive "\\\\foo" == False -- > Posix: isRelativeDrive "/" == False isRelativeDrive :: String -> Bool isRelativeDrive x = null x || maybe False (not . isPathSeparator . last . fst) (readDriveLetter x) -- | @not . 'isRelative'@ -- -- > isAbsolute x == not (isRelative x) isAbsolute :: FilePath -> Bool isAbsolute = not . isRelative curry-tools-v3.3.0/optimize/.cpm/packages/filepath/test/000077500000000000000000000000001377556325500232555ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/filepath/test/TestFilePath.curry000066400000000000000000000025411377556325500267010ustar00rootroot00000000000000----------------------------------------------------------------------------- -- A few tests for module System.FilePath ----------------------------------------------------------------------------- import Test.Prop import Data.List import System.FilePath sp1 :: [String] sp1 = ["Dir1","Dir2","Dir3"] testSplitSearchPath :: Prop testSplitSearchPath = splitSearchPath (intercalate [searchPathSeparator] sp1) -=- sp1 splitExtProp s = uncurry (++) (splitExtension s) -=- s addSplitProp s = uncurry addExtension (splitExtension s) -=- s testSplitExt1 = splitExtension "file.txt" -=- ("file",".txt") testSplitExt2 = splitExtension "file" -=- ("file","") testSplitExt3 = splitExtension "file/file.txt" -=- ("file/file",".txt") testSplitExt4 = splitExtension "file.txt/boris" -=- ("file.txt/boris","") testSplitExt5 = splitExtension "file.txt/boris.ext" -=- ("file.txt/boris",".ext") testSplitExt6 = splitExtension "file/path.txt.bob.fred" -=- ("file/path.txt.bob",".fred") testSplitExt7 = splitExtension "file/path.txt/" -=- ("file/path.txt/","") testReplExt1 = replaceExtension "file.txt" ".bob" -=- "file.bob" testReplExt2 = replaceExtension "file.txt" "bob" -=- "file.bob" testReplExt3 = replaceExtension "file" ".bob" -=- "file.bob" testReplExt4 = replaceExtension "file.txt" "" -=- "file" testReplExt5 = replaceExtension "file.fred.bob" "txt" -=- "file.fred.txt" curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/000077500000000000000000000000001377556325500225155ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/LICENSE000066400000000000000000000027351377556325500235310ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/README.md000066400000000000000000000032221377556325500237730ustar00rootroot00000000000000flatcurry ========= This package contains libraries to deal with FlatCurry programs. Currently, it contains the following modules: * `FlatCurry.Compact`: This module contains operations to reduce the size of FlatCurry programs by combining the main module and all imports into a single program that contains only the functions directly or indirectly called from a set of main functions. * `FlatCurry.Files`: This module defines operations to read and write FlatCurry programs. * `FlatCurry.FlexRigid`: provides a function to compute the rigid/flex status of a FlatCurry expression (right-hand side of a function definition). * `FlatCurry.Goodies`: This library provides selector functions, test and update operations as well as some useful auxiliary functions for FlatCurry data terms. * `FlatCurry.Pretty`: This library provides pretty-printers for FlatCurry modules and all substructures (e.g., expressions). * `FlatCurry.Read`: This library defines operations to read FlatCurry programs or interfaces together with all its imported modules in the current load path. * `FlatCurry.Show`: This library contains operations to transform FlatCurry programs into string representations, either in a FlatCurry format or in a Curry-like syntax. * `FlatCurry.Types`: This module defines the data types to represent FlatCurry programs in Curry. * `FlatCurry.XML`: This module contains operations to convert FlatCurry programs into corresponding XML expressions and vice versa. This can be used to store Curry programs in a way independent of a Curry system or to use a Curry system, like PAKCS, as back end by other functional logic programming systems. curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/package.json000066400000000000000000000025611377556325500250070ustar00rootroot00000000000000{ "name": "flatcurry", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Libraries to deal with FlatCurry programs", "category": [ "Metaprogramming" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "currypath" : ">= 3.0.0, < 4.0.0", "directory" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0", "frontend-exec" : ">= 3.0.0, < 4.0.0", "read-legacy" : ">= 3.0.0, < 4.0.0", "redblacktree" : ">= 3.0.0, < 4.0.0", "wl-pprint" : ">= 3.0.0, < 4.0.0", "xml" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "FlatCurry.Compact", "FlatCurry.Files", "FlatCurry.FlexRigid", "FlatCurry.Goodies", "FlatCurry.Pretty", "FlatCurry.Read", "FlatCurry.Show", "FlatCurry.Types", "FlatCurry.XML" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/flatcurry.git", "tag": "$version" }, "testsuite": { "src-dir": "test", "modules": [ "TestFlatCurryGoodies", "TestFlatCurryXML" ] } } curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/src/000077500000000000000000000000001377556325500233045ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/src/FlatCurry/000077500000000000000000000000001377556325500252175ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/src/FlatCurry/Compact.curry000066400000000000000000000572161377556325500277060ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains functions to reduce the size of FlatCurry programs --- by combining the main module and all imports into a single program --- that contains only the functions directly or indirectly called from --- a set of main functions. --- --- @author Michael Hanus, Carsten Heine --- @version December 2018 ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-} module FlatCurry.Compact(generateCompactFlatCurryFile,computeCompactFlatCurry, Option(..),RequiredSpec,requires,alwaysRequired, defaultRequired) where import FlatCurry.Types import FlatCurry.Files import qualified Data.Set.RBTree as RBS import qualified Data.Table.RBTree as RBT import Data.Maybe import Data.List ( nub, union ) import System.CurryPath ( lookupModuleSourceInLoadPath, stripCurrySuffix) import System.FilePath ( takeFileName, () ) import System.Directory import XML infix 0 `requires` ------------------------------------------------------------------------------ --- Options to guide the compactification process. --- @cons Verbose - for more output --- @cons Main - optimize for one main (unqualified!) function supplied here --- @cons Exports - optimize w.r.t. the exported functions of the module only --- @cons InitFuncs - optimize w.r.t. given list of initially required functions --- @cons Required - list of functions that are implicitly required and, thus, --- should not be deleted if the corresponding module --- is imported --- @cons Import - module that should always be imported --- (useful in combination with option InitFuncs) data Option = Verbose | Main String | Exports | InitFuncs [QName] | Required [RequiredSpec] | Import String deriving Eq isMainOption :: Option -> Bool isMainOption o = case o of Main _ -> True _ -> False getMainFuncFromOptions :: [Option] -> String getMainFuncFromOptions (o:os) = case o of Main f -> f _ -> getMainFuncFromOptions os getRequiredFromOptions :: [Option] -> [RequiredSpec] getRequiredFromOptions options = concat [ fs | Required fs <- options ] -- add Import for modules containing always required functions: addImport2Options :: [Option] -> [Option] addImport2Options options = options ++ map Import (nub (concatMap alwaysReqMod (getRequiredFromOptions options))) where alwaysReqMod (AlwaysReq (m,_)) = [m] alwaysReqMod (Requires _ _) = [] ------------------------------------------------------------------------------ --- Data type to specify requirements of functions. data RequiredSpec = AlwaysReq QName | Requires QName QName deriving Eq --- (fun `requires` reqfun) specifies that the use of the function "fun" --- implies the application of function "reqfun". requires :: QName -> QName -> RequiredSpec requires fun reqfun = Requires fun reqfun --- (alwaysRequired fun) specifies that the function "fun" should be --- always present if the corresponding module is loaded. alwaysRequired :: QName -> RequiredSpec alwaysRequired fun = AlwaysReq fun --- Functions that are implicitly required in a FlatCurry program --- (since they might be generated by external functions like --- "==" or "=:=" on the fly). defaultRequired :: [RequiredSpec] defaultRequired = [alwaysRequired (prelude,"apply"), alwaysRequired (prelude,"letrec"), alwaysRequired (prelude,"cond"), alwaysRequired (prelude,"failure"), (prelude,"==") `requires` (prelude,"&&"), (prelude,"=:=") `requires` (prelude,"&"), (prelude,"=:<=") `requires` (prelude,"ifVar"), (prelude,"=:<=") `requires` (prelude,"=:="), (prelude,"=:<=") `requires` (prelude,"&>"), (prelude,"=:<<=") `requires` (prelude,"&"), (prelude,"$#") `requires` (prelude,"ensureNotFree"), (prelude,"readFile") `requires` (prelude,"prim_readFileContents"), ("Ports","prim_openPortOnSocket") `requires` ("Ports","basicServerLoop"), ("Ports","prim_timeoutOnStream") `requires` ("Ports","basicServerLoop"), ("Ports","prim_choiceSPEP") `requires` ("Ports","basicServerLoop"), ("Dynamic","getDynamicKnowledge") `requires` ("Dynamic","isKnownAtTime") ] prelude :: String prelude = "Prelude" --- Get functions that are required in a module w.r.t. --- a requirement specification. getRequiredInModule :: [RequiredSpec] -> String -> [QName] getRequiredInModule reqspecs mod = concatMap getImpReq reqspecs where getImpReq (AlwaysReq (mf,f)) = if mf==mod then [(mf,f)] else [] getImpReq (Requires _ _) = [] --- Get functions that are implicitly required by a function w.r.t. --- a requirement specification. getImplicitlyRequired :: [RequiredSpec] -> QName -> [QName] getImplicitlyRequired reqspecs fun = concatMap getImpReq reqspecs where getImpReq (AlwaysReq _) = [] getImpReq (Requires f reqf) = if f==fun then [reqf] else [] --- The basic types that are always required in a FlatCurry program. defaultRequiredTypes :: [QName] defaultRequiredTypes = [(prelude,"()"),(prelude,"Int"),(prelude,"Float"),(prelude,"Char"), (prelude,"Success"),(prelude,"IO")] ------------------------------------------------------------------------------- -- Main functions: ------------------------------------------------------------------------------- --- Computes a single FlatCurry program containing all functions potentially --- called from a set of main functions and writes it into a FlatCurry file. --- This is done by merging all imported FlatCurry modules and removing --- the imported functions that are definitely not used. --- @param options - list of options --- @param progname - name of the Curry program that should be compacted --- @param target - name of the target file where the compact program is saved generateCompactFlatCurryFile :: [Option] -> String -> String -> IO () generateCompactFlatCurryFile options progname target = do optprog <- computeCompactFlatCurry options progname writeFCY target optprog --- Computes a single FlatCurry program containing all functions potentially --- called from a set of main functions. --- This is done by merging all imported FlatCurry modules (these are loaded --- demand-driven so that modules that contains no potentially called functions --- are not loaded) and removing the imported functions that are definitely --- not used. --- @param options - list of options --- @param progname - name of the Curry program that should be compacted --- @return the compact FlatCurry program computeCompactFlatCurry :: [Option] -> String -> IO Prog computeCompactFlatCurry orgoptions progname = let options = addImport2Options orgoptions in if (elem Exports options) && (any isMainOption options) then error "CompactFlat: Options 'Main' and 'Exports' can't be be used together!" else do putStr "CompactFlat: Searching relevant functions in module " prog <- readCurrentFlatCurry progname resultprog <- makeCompactFlatCurry prog options putStrLn ("CompactFlat: Number of functions after optimization: " ++ show (length (moduleFuns resultprog))) return resultprog --- Create the optimized program. makeCompactFlatCurry :: Prog -> [Option] -> IO Prog makeCompactFlatCurry mainmod options = do (initfuncs,loadedmnames,loadedmods) <- requiredInCompactProg mainmod options let initFuncTable = extendFuncTable (RBT.empty (<)) (concatMap moduleFuns loadedmods) required = getRequiredFromOptions options loadedreqfuns = concatMap (getRequiredInModule required) (map moduleName loadedmods) initreqfuncs = initfuncs ++ loadedreqfuns (finalmods,finalfuncs,finalcons,finaltcons) <- getCalledFuncs required loadedmnames loadedmods initFuncTable (foldr RBS.insert (RBS.empty (<)) initreqfuncs) (RBS.empty (<)) (RBS.empty (<)) initreqfuncs putStrLn ("\nCompactFlat: Total number of functions (without unused imports): " ++ show (foldr (+) 0 (map (length . moduleFuns) finalmods))) let finalfnames = map functionName finalfuncs return (Prog (moduleName mainmod) [] (let allTDecls = concatMap moduleTypes finalmods reqTCons = extendTConsWithConsType finalcons finaltcons allTDecls allReqTCons = requiredDatatypes reqTCons allTDecls in filter (\tdecl->tconsName tdecl `RBS.member` allReqTCons) allTDecls) finalfuncs (filter (\ (Op oname _ _) -> oname `elem` finalfnames) (concatMap moduleOps finalmods))) -- compute the transitive closure of a set of type constructors w.r.t. -- to a given list of type declaration so that the set contains -- all type constructor names occurring in the type declarations: requiredDatatypes :: RBS.SetRBT QName -> [TypeDecl] -> RBS.SetRBT QName requiredDatatypes tcnames tdecls = let newtcons = concatMap (newTypeConsOfTDecl tcnames) tdecls in if null newtcons then tcnames else requiredDatatypes (foldr RBS.insert tcnames newtcons) tdecls -- Extract the new type constructors (w.r.t. a given set) contained in a -- type declaration: newTypeConsOfTDecl :: RBS.SetRBT QName -> TypeDecl -> [QName] newTypeConsOfTDecl tcnames (TypeSyn tcons _ _ texp) = if tcons `RBS.member` tcnames then filter (\tc -> not (tc `RBS.member` tcnames)) (allTypesOfTExpr texp) else [] newTypeConsOfTDecl tcnames (TypeNew tcons _ _ (NewCons _ _ texp)) = if tcons `RBS.member` tcnames then filter (\tc -> not (tc `RBS.member` tcnames)) (allTypesOfTExpr texp) else [] newTypeConsOfTDecl tcnames (Type tcons _ _ cdecls) = if tcons `RBS.member` tcnames then filter (\tc -> not (tc `RBS.member` tcnames)) (concatMap (\ (Cons _ _ _ texps) -> concatMap allTypesOfTExpr texps) cdecls) else [] -- Extend set of type constructor with type constructors of data declarations -- contain some constructor. extendTConsWithConsType :: RBS.SetRBT QName -> RBS.SetRBT QName -> [TypeDecl] -> RBS.SetRBT QName extendTConsWithConsType _ tcons [] = tcons extendTConsWithConsType cnames tcons (TypeSyn tname _ _ _ : tds) = extendTConsWithConsType cnames (RBS.insert tname tcons) tds extendTConsWithConsType cnames tcons (TypeNew tname _ _ cdecl : tds) = if newConsName cdecl `RBS.member` cnames then extendTConsWithConsType cnames (RBS.insert tname tcons) tds else extendTConsWithConsType cnames tcons tds extendTConsWithConsType cnames tcons (Type tname _ _ cdecls : tds) = if tname `elem` defaultRequiredTypes || any (\cdecl->consName cdecl `RBS.member` cnames) cdecls then extendTConsWithConsType cnames (RBS.insert tname tcons) tds else extendTConsWithConsType cnames tcons tds -- Extend function table (mapping from qualified names to function declarations) -- by some new function declarations: extendFuncTable :: RBT.TableRBT QName FuncDecl -> [FuncDecl] -> RBT.TableRBT QName FuncDecl extendFuncTable ftable fdecls = foldr (\f t -> RBT.update (functionName f) f t) ftable fdecls ------------------------------------------------------------------------------- -- Generate the Prog to start with: ------------------------------------------------------------------------------- -- Compute the initially required functions in the compact program -- together with the set of module names and contents that are initially loaded: requiredInCompactProg :: Prog -> [Option] -> IO ([QName],RBS.SetRBT String,[Prog]) requiredInCompactProg mainmod options | not (null initfuncs) = do impprogs <- mapM readCurrentFlatCurry imports return (concat initfuncs, add2mainmodset imports, mainmod:impprogs) | Exports `elem` options = do impprogs <- mapM readCurrentFlatCurry imports return (nub mainexports, add2mainmodset imports, mainmod:impprogs) | any isMainOption options = let func = getMainFuncFromOptions options in if (mainmodname,func) `elem` (map functionName (moduleFuns mainmod)) then do impprogs <- mapM readCurrentFlatCurry imports return ([(mainmodname,func)], add2mainmodset imports, mainmod:impprogs) else error $ "CompactFlat: Cannot find main function \""++func++"\"!" | otherwise = do impprogs <- mapM readCurrentFlatCurry (nub (imports ++ moduleImports mainmod)) return (nub (mainexports ++ concatMap (exportedFuncNames . moduleFuns) impprogs), add2mainmodset (map moduleName impprogs), mainmod:impprogs) where imports = nub [ mname | Import mname <- options ] mainmodname = moduleName mainmod initfuncs = [ fs | InitFuncs fs <- options ] mainexports = exportedFuncNames (moduleFuns mainmod) mainmodset = RBS.insert mainmodname $ RBS.empty (<) add2mainmodset mnames = foldr RBS.insert mainmodset mnames -- extract the names of all exported functions: exportedFuncNames :: [FuncDecl] -> [QName] exportedFuncNames funs = map (\(Func name _ _ _ _)->name) (filter (\(Func _ _ vis _ _)->vis==Public) funs) ------------------------------------------------------------------------------- --- Adds all required functions to the program and load modules, if necessary. --- @param required - list of potentially required functions --- @param loadedmnames - set of already considered module names --- @param progs - list of already loaded modules --- @param functable - mapping from (loaded) function names to their definitions --- @param loadedfnames - set of already loaded function names --- @param loadedcnames - set of already required data constructors --- @param loadedtnames - set of already required data constructors --- @param fnames - list of function names to be analyzed for dependencies --- @return (list of loaded modules, list of required function declarations, --- set of required data constructors, set of required type names) getCalledFuncs :: [RequiredSpec] -> RBS.SetRBT String -> [Prog] -> RBT.TableRBT QName FuncDecl -> RBS.SetRBT QName -> RBS.SetRBT QName -> RBS.SetRBT QName -> [QName] -> IO ([Prog],[FuncDecl],RBS.SetRBT QName,RBS.SetRBT QName) getCalledFuncs _ _ progs _ _ dcs ts [] = return (progs,[],dcs,ts) getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames loadedtnames ((m,f):fs) | not (m `RBS.member` loadedmnames) = do newmod <- readCurrentFlatCurry m let reqnewfun = getRequiredInModule required m getCalledFuncs required (RBS.insert m loadedmnames) (newmod:progs) (extendFuncTable functable (moduleFuns newmod)) (foldr RBS.insert loadedfnames reqnewfun) loadedcnames loadedtnames ((m,f):fs ++ reqnewfun) | isNothing (RBT.lookup (m,f) functable) = -- this must be a data constructor: ingore it since already considered getCalledFuncs required loadedmnames progs functable loadedfnames loadedcnames loadedtnames fs | otherwise = do let fdecl = fromJust (RBT.lookup (m,f) functable) funcCalls = allFuncCalls fdecl newFuncCalls = filter (\qn->not (qn `RBS.member` loadedfnames)) funcCalls newReqs = concatMap (getImplicitlyRequired required) newFuncCalls consCalls = allConstructorsOfFunc fdecl newConsCalls = filter (\qn->not (qn `RBS.member` loadedcnames)) consCalls newtcons = allTypesOfFunc fdecl (newprogs,newfuns,newcons, newtypes) <- getCalledFuncs required loadedmnames progs functable (foldr RBS.insert loadedfnames (newFuncCalls++newReqs)) (foldr RBS.insert loadedcnames consCalls) (foldr RBS.insert loadedtnames newtcons) (fs ++ newFuncCalls ++ newReqs ++ newConsCalls) return (newprogs, fdecl:newfuns, newcons, newtypes) ------------------------------------------------------------------------------- -- Operations to get all function calls, types,... in a function declaration: ------------------------------------------------------------------------------- --- Get all function calls in a function declaration and remove duplicates. --- @param funcDecl - a function declaration in FlatCurry --- @return a list of all function calls allFuncCalls :: FuncDecl -> [QName] allFuncCalls (Func _ _ _ _ (External _)) = [] allFuncCalls (Func _ _ _ _ (Rule _ expr)) = nub (allFuncCallsOfExpr expr) --- Get all function calls in an expression. --- @param expr - an expression --- @return a list of all function calls allFuncCallsOfExpr :: Expr -> [QName] allFuncCallsOfExpr (Var _) = [] allFuncCallsOfExpr (Lit _) = [] allFuncCallsOfExpr (Comb ctype fname exprs) = case ctype of FuncCall -> fname:fnames FuncPartCall _ -> fname:fnames _ -> fnames where fnames = concatMap allFuncCallsOfExpr exprs allFuncCallsOfExpr (Free _ expr) = allFuncCallsOfExpr expr allFuncCallsOfExpr (Let bs expr) = concatMap (allFuncCallsOfExpr . snd) bs ++ allFuncCallsOfExpr expr allFuncCallsOfExpr (Or expr1 expr2) = allFuncCallsOfExpr expr1 ++ allFuncCallsOfExpr expr2 allFuncCallsOfExpr (Case _ expr branchExprs) = allFuncCallsOfExpr expr ++ concatMap allFuncCallsOfBranchExpr branchExprs allFuncCallsOfExpr (Typed expr _) = allFuncCallsOfExpr expr --- Get all function calls in a branch expression in case expressions. --- @param branchExpr - a branch expression --- @return a list of all function calls allFuncCallsOfBranchExpr :: BranchExpr -> [QName] allFuncCallsOfBranchExpr (Branch _ expr) = allFuncCallsOfExpr expr --- Get all data constructors in a function declaration. allConstructorsOfFunc :: FuncDecl -> [QName] allConstructorsOfFunc (Func _ _ _ _ (External _)) = [] allConstructorsOfFunc (Func _ _ _ _ (Rule _ expr)) = allConsOfExpr expr --- Get all data constructors in an expression. allConsOfExpr :: Expr -> [QName] allConsOfExpr (Var _) = [] allConsOfExpr (Lit _) = [] allConsOfExpr (Comb ctype cname exprs) = case ctype of ConsCall -> cname:cnames ConsPartCall _ -> cname:cnames _ -> cnames where cnames = unionMap allConsOfExpr exprs allConsOfExpr (Free _ expr) = allConsOfExpr expr allConsOfExpr (Let bs expr) = union (unionMap (allConsOfExpr . snd) bs) (allConsOfExpr expr) allConsOfExpr (Or expr1 expr2) = union (allConsOfExpr expr1) (allConsOfExpr expr2) allConsOfExpr (Case _ expr branchExprs) = union (allConsOfExpr expr) (unionMap consOfBranch branchExprs) where consOfBranch (Branch (LPattern _) e) = allConsOfExpr e consOfBranch (Branch (Pattern c _) e) = union [c] (allConsOfExpr e) allConsOfExpr (Typed expr _) = allConsOfExpr expr --- Get all type constructors in a function declaration. allTypesOfFunc :: FuncDecl -> [QName] allTypesOfFunc (Func _ _ _ texp _) = allTypesOfTExpr texp --- Get all data constructors in an expression. allTypesOfTExpr :: TypeExpr -> [QName] allTypesOfTExpr (TVar _) = [] allTypesOfTExpr (FuncType texp1 texp2) = union (allTypesOfTExpr texp1) (allTypesOfTExpr texp2) allTypesOfTExpr (TCons tcons args) = union [tcons] (unionMap allTypesOfTExpr args) unionMap :: Eq b => (a -> [b]) -> [a] -> [b] unionMap f = foldr union [] . map f ------------------------------------------------------------------------------- -- Functions to get direct access to some data inside a datatype: ------------------------------------------------------------------------------- --- Extracts the function name of a function declaration. functionName :: FuncDecl -> QName functionName (Func name _ _ _ _) = name --- Extracts the constructor name of a constructor declaration. consName :: ConsDecl -> QName consName (Cons name _ _ _) = name --- Extracts the constructor name of a newtype constructor declaration. newConsName :: NewConsDecl -> QName newConsName (NewCons name _ _) = name --- Extracts the type name of a type declaration. tconsName :: TypeDecl -> QName tconsName (Type name _ _ _) = name tconsName (TypeSyn name _ _ _) = name tconsName (TypeNew name _ _ _) = name --- Extracts the names of imported modules of a FlatCurry program. moduleImports :: Prog -> [String] moduleImports (Prog _ imports _ _ _) = imports --- Extracts the types of a FlatCurry program. moduleTypes :: Prog -> [TypeDecl] moduleTypes (Prog _ _ types _ _) = types --- Extracts the operators of a FlatCurry program. moduleOps :: Prog -> [OpDecl] moduleOps (Prog _ _ _ _ ops) = ops --- Extracts the name of the Prog. moduleName :: Prog -> String moduleName (Prog name _ _ _ _) = name --- Extracts the functions of the program. moduleFuns :: Prog -> [FuncDecl] moduleFuns (Prog _ _ _ funs _) = funs ------------------------------------------------------------------------------- -- Functions for comparison: ------------------------------------------------------------------------------- --- Compares two qualified names. --- Returns True, if the first name is lexicographically smaller than --- the second name using the leString function to compare String. leqQName :: QName -> QName -> Bool leqQName (m1,n1) (m2,n2) = let cm = compare m1 m2 in cm == LT || (cm == EQ && n1 <= n2) ------------------------------------------------------------------------------- -- I/O functions: ------------------------------------------------------------------------------- -- Read a FlatCurry program (parse only if necessary): readCurrentFlatCurry :: String -> IO Prog readCurrentFlatCurry modname = do putStr (modname++"...") mbsrc <- lookupModuleSourceInLoadPath modname case mbsrc of Nothing -> error ("Curry file for module \""++modname++"\" not found!") Just (moddir,progname) -> do let fcyname = flatCurryFileName (moddir takeFileName modname) fcyexists <- doesFileExist fcyname if not fcyexists then readFlatCurry modname >>= processPrimitives progname else do ctime <- getModificationTime progname ftime <- getModificationTime fcyname if ctime>ftime then readFlatCurry progname >>= processPrimitives progname else readFlatCurryFile fcyname >>= processPrimitives progname -- read primitive specification and transform FlatCurry program accordingly: processPrimitives :: String -> Prog -> IO Prog processPrimitives progname prog = do pspecs <- readPrimSpec (moduleName prog) (stripCurrySuffix progname ++ ".pakcs") return (mergePrimSpecIntoModule pspecs prog) mergePrimSpecIntoModule :: [(QName,QName)] -> Prog -> Prog mergePrimSpecIntoModule trans (Prog name imps types funcs ops) = Prog name imps types (concatMap (mergePrimSpecIntoFunc trans) funcs) ops mergePrimSpecIntoFunc :: [(QName,QName)] -> FuncDecl -> [FuncDecl] mergePrimSpecIntoFunc trans (Func name ar vis tp rule) = let fname = lookup name trans in if fname==Nothing then [Func name ar vis tp rule] else let Just (lib,entry) = fname in if null entry then [] else [Func name ar vis tp (External (lib++' ':entry))] readPrimSpec :: String -> String -> IO [(QName,QName)] readPrimSpec mod xmlfilename = do existsXml <- doesFileExist xmlfilename if existsXml then do --putStrLn $ "Reading specification '"++xmlfilename++"'..." xmldoc <- readXmlFile xmlfilename return (xml2primtrans mod xmldoc) else return [] xml2primtrans :: String -> XmlExp -> [(QName,QName)] xml2primtrans mod (XElem "primitives" [] primitives) = map xml2prim primitives where xml2prim (XElem "primitive" (("name",fname):_) [XElem "library" [] xlib, XElem "entry" [] xfun]) = ((mod,fname),(textOfXml xlib,textOfXml xfun)) xml2prim (XElem "ignore" (("name",fname):_) []) = ((mod,fname),("","")) ------------------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/src/FlatCurry/Files.curry000066400000000000000000000157201377556325500273540ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library supports meta-programming, i.e., the manipulation of --- Curry programs in Curry. This library defines I/O actions --- to read Curry programs and transform them into this representation. --- --- @author Michael Hanus, Finn Teegen --- @version November 2020 ------------------------------------------------------------------------------ module FlatCurry.Files where import System.Directory ( doesFileExist, getFileWithSuffix , findFileWithSuffix ) import System.FilePath ( takeFileName, (), (<.>)) import System.CurryPath ( inCurrySubdir, stripCurrySuffix , lookupModuleSourceInLoadPath, getLoadPathForModule ) import System.FrontendExec ( FrontendParams, FrontendTarget (..), defaultParams , setQuiet, callFrontendWithParams ) import ReadShowTerm (readUnqualifiedTerm, showTerm) import FlatCurry.Types --- I/O action which parses a Curry program and returns the corresponding --- FlatCurry program. --- Thus, the argument is the module path (without suffix ".curry" --- or ".lcurry") and the result is a FlatCurry term representing this --- program. readFlatCurry :: String -> IO Prog readFlatCurry progname = readFlatCurryWithParseOptions progname (setQuiet True defaultParams) --- I/O action which parses a Curry program --- with respect to some parser options and returns the --- corresponding FlatCurry program. --- This I/O action is used by the standard action `readFlatCurry`. --- @param progfile - the program file name (without suffix ".curry") --- @param options - parameters passed to the front end readFlatCurryWithParseOptions :: String -> FrontendParams -> IO Prog readFlatCurryWithParseOptions progname options = do mbsrc <- lookupModuleSourceInLoadPath progname case mbsrc of Nothing -> do -- no source file, try to find FlatCurry file in load path: loadpath <- getLoadPathForModule progname filename <- getFileWithSuffix (flatCurryFileName (takeFileName progname)) [""] loadpath readFlatCurryFile filename Just (dir,_) -> do callFrontendWithParams FCY options progname readFlatCurryFile (flatCurryFileName (dir takeFileName progname)) --- Transforms a name of a Curry program (with or without suffix ".curry" --- or ".lcurry") into the name of the file containing the --- corresponding FlatCurry program. flatCurryFileName :: String -> String flatCurryFileName prog = inCurrySubdir (stripCurrySuffix prog) <.> "fcy" --- Transforms a name of a Curry program (with or without suffix ".curry" --- or ".lcurry") into the name of the file containing the --- corresponding FlatCurry program. flatCurryIntName :: String -> String flatCurryIntName prog = inCurrySubdir (stripCurrySuffix prog) <.> "fint" --- I/O action which reads a FlatCurry program from a file in ".fcy" format. --- In contrast to `readFlatCurry`, this action does not parse --- a source program. Thus, the argument must be the name of an existing --- file (with suffix ".fcy") containing a FlatCurry program in ".fcy" --- format and the result is a FlatCurry term representing this program. readFlatCurryFile :: String -> IO Prog readFlatCurryFile filename = do exfcy <- doesFileExist filename if exfcy then readExistingFCY filename else do let subdirfilename = inCurrySubdir filename exdirfcy <- doesFileExist subdirfilename if exdirfcy then readExistingFCY subdirfilename else error ("EXISTENCE ERROR: FlatCurry file '" ++ filename ++ "' does not exist") where readExistingFCY fname = do filecontents <- readFile fname return (readUnqualifiedTerm ["FlatCurry.Types","Prelude"] filecontents) --- I/O action which returns the interface of a Curry module, i.e., --- a FlatCurry program containing only "Public" entities and function --- definitions without rules (i.e., external functions). --- The argument is the file name without suffix ".curry" --- (or ".lcurry") and the result is a FlatCurry term representing the --- interface of this module. readFlatCurryInt :: String -> IO Prog readFlatCurryInt progname = do readFlatCurryIntWithParseOptions progname (setQuiet True defaultParams) --- I/O action which parses Curry program --- with respect to some parser options and returns the FlatCurry --- interface of this program, i.e., --- a FlatCurry program containing only "Public" entities and function --- definitions without rules (i.e., external functions). --- The argument is the file name without suffix ".curry" --- (or ".lcurry") and the result is a FlatCurry term representing the --- interface of this module. readFlatCurryIntWithParseOptions :: String -> FrontendParams -> IO Prog readFlatCurryIntWithParseOptions progname options = do mbsrc <- lookupModuleSourceInLoadPath progname case mbsrc of Nothing -> do -- no source file, try to find FlatCurry file in load path: loadpath <- getLoadPathForModule progname filename <- getFileWithSuffix (flatCurryIntName (takeFileName progname)) [""] loadpath readFlatCurryFile filename Just (dir,_) -> do callFrontendWithParams FINT options progname readFlatCurryFile (flatCurryIntName (dir takeFileName progname)) --- Writes a FlatCurry program into a file in `.fcy` format. --- The file is written in the standard location for intermediate files, --- i.e., in the 'flatCurryFileName' relative to the directory of the --- Curry source program (which must exist!). writeFlatCurry :: Prog -> IO () writeFlatCurry prog@(Prog mname _ _ _ _) = do mbsrc <- lookupModuleSourceInLoadPath mname case mbsrc of Nothing -> error $ "Curry source file for module '" ++ mname ++ "' not found!" Just (dir,_) -> writeFlatCurryFile (flatCurryFileName (dir mname)) prog --- Writes a FlatCurry program into a file in ".fcy" format. --- The first argument must be the name of the target file --- (usually with suffix ".fcy"). writeFlatCurryFile :: String -> Prog -> IO () writeFlatCurryFile file prog = writeFile file (showTerm prog) --- Writes a FlatCurry program into a file in ".fcy" format. --- The first argument must be the name of the target file --- (usually with suffix ".fcy"). writeFCY :: String -> Prog -> IO () writeFCY = writeFlatCurryFile --- Returns the name of the FlatCurry file of a module in the load path, --- if this file exists. lookupFlatCurryFileInLoadPath :: String -> IO (Maybe String) lookupFlatCurryFileInLoadPath modname = getLoadPathForModule modname >>= findFileWithSuffix (flatCurryFileName modname) [""] --- Returns the name of the FlatCurry file of a module in the load path, --- if this file exists. getFlatCurryFileInLoadPath :: String -> IO String getFlatCurryFileInLoadPath modname = getLoadPathForModule modname >>= getFileWithSuffix (flatCurryFileName modname) [""] curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/src/FlatCurry/FlexRigid.curry000066400000000000000000000044231377556325500301650ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library provides a function to compute the rigid/flex status --- of a FlatCurry expression (right-hand side of a function definition). --- --- @author Michael Hanus --- @version April 2005 ------------------------------------------------------------------------------ module FlatCurry.FlexRigid(FlexRigidResult(..),getFlexRigid) where import FlatCurry.Types --- Datatype for representing a flex/rigid status of an expression. data FlexRigidResult = UnknownFR | ConflictFR | KnownFlex | KnownRigid --- Computes the rigid/flex status of a FlatCurry expression. --- This function checks all cases in this expression. --- If the expression has rigid as well as flex cases (which cannot --- be the case for source level programs but might occur after --- some program transformations), the result ConflictFR is returned. getFlexRigid :: Expr -> FlexRigidResult getFlexRigid (Var _) = UnknownFR getFlexRigid (Lit _) = UnknownFR getFlexRigid (Comb _ _ args) = foldr joinCaseTypes UnknownFR (map getFlexRigid args) getFlexRigid (Let _ e) = getFlexRigid e getFlexRigid (Free _ e) = getFlexRigid e getFlexRigid (Or e1 e2) = joinCaseTypes (getFlexRigid e1) (getFlexRigid e2) getFlexRigid (Case ctype e bs) = foldr joinCaseTypes (if ctype==Flex then KnownFlex else KnownRigid) (map getFlexRigid (e : map (\(Branch _ be)->be) bs)) getFlexRigid (Typed e _) = getFlexRigid e joinCaseTypes :: FlexRigidResult -> FlexRigidResult -> FlexRigidResult joinCaseTypes ConflictFR ConflictFR = ConflictFR joinCaseTypes ConflictFR UnknownFR = ConflictFR joinCaseTypes ConflictFR KnownFlex = ConflictFR joinCaseTypes ConflictFR KnownRigid = ConflictFR joinCaseTypes UnknownFR ConflictFR = ConflictFR joinCaseTypes KnownFlex ConflictFR = ConflictFR joinCaseTypes KnownRigid ConflictFR = ConflictFR joinCaseTypes UnknownFR UnknownFR = UnknownFR joinCaseTypes UnknownFR KnownFlex = KnownFlex joinCaseTypes UnknownFR KnownRigid = KnownRigid joinCaseTypes KnownFlex UnknownFR = KnownFlex joinCaseTypes KnownFlex KnownFlex = KnownFlex joinCaseTypes KnownFlex KnownRigid = ConflictFR joinCaseTypes KnownRigid UnknownFR = KnownRigid joinCaseTypes KnownRigid KnownFlex = ConflictFR joinCaseTypes KnownRigid KnownRigid = KnownRigid curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/src/FlatCurry/Goodies.curry000066400000000000000000000764451377556325500277160ustar00rootroot00000000000000---------------------------------------------------------------------------- --- This library provides selector functions, test and update operations --- as well as some useful auxiliary functions for FlatCurry data terms. --- Most of the provided functions are based on general transformation --- functions that replace constructors with user-defined --- functions. For recursive datatypes the transformations are defined --- inductively over the term structure. This is quite usual for --- transformations on FlatCurry terms, --- so the provided functions can be used to implement specific transformations --- without having to explicitly state the recursion. Essentially, the tedious --- part of such transformations - descend in fairly complex term structures - --- is abstracted away, which hopefully makes the code more clear and brief. --- --- @author Sebastian Fischer --- @version November 2020 ---------------------------------------------------------------------------- module FlatCurry.Goodies where import FlatCurry.Types type Update a b = (b -> b) -> a -> a -- Prog ---------------------------------------------------------------------- --- transform program trProg :: (String -> [String] -> [TypeDecl] -> [FuncDecl] -> [OpDecl] -> a) -> Prog -> a trProg prog (Prog name imps types funcs ops) = prog name imps types funcs ops -- Selectors --- get name from program progName :: Prog -> String progName = trProg (\name _ _ _ _ -> name) --- get imports from program progImports :: Prog -> [String] progImports = trProg (\_ imps _ _ _ -> imps) --- get type declarations from program progTypes :: Prog -> [TypeDecl] progTypes = trProg (\_ _ types _ _ -> types) --- get functions from program progFuncs :: Prog -> [FuncDecl] progFuncs = trProg (\_ _ _ funcs _ -> funcs) --- get infix operators from program progOps :: Prog -> [OpDecl] progOps = trProg (\_ _ _ _ ops -> ops) -- Update Operations --- update program updProg :: (String -> String) -> ([String] -> [String]) -> ([TypeDecl] -> [TypeDecl]) -> ([FuncDecl] -> [FuncDecl]) -> ([OpDecl] -> [OpDecl]) -> Prog -> Prog updProg fn fi ft ff fo = trProg prog where prog name imps types funcs ops = Prog (fn name) (fi imps) (ft types) (ff funcs) (fo ops) --- update name of program updProgName :: Update Prog String updProgName f = updProg f id id id id --- update imports of program updProgImports :: Update Prog [String] updProgImports f = updProg id f id id id --- update type declarations of program updProgTypes :: Update Prog [TypeDecl] updProgTypes f = updProg id id f id id --- update functions of program updProgFuncs :: Update Prog [FuncDecl] updProgFuncs f = updProg id id id f id --- update infix operators of program updProgOps :: Update Prog [OpDecl] updProgOps = updProg id id id id -- Auxiliary Functions --- get all program variables (also from patterns) allVarsInProg :: Prog -> [VarIndex] allVarsInProg = concatMap allVarsInFunc . progFuncs --- lift transformation on expressions to program updProgExps :: Update Prog Expr updProgExps = updProgFuncs . map . updFuncBody --- rename programs variables rnmAllVarsInProg :: Update Prog VarIndex rnmAllVarsInProg = updProgFuncs . map . rnmAllVarsInFunc --- update all qualified names in program updQNamesInProg :: Update Prog QName updQNamesInProg f = updProg id id (map (updQNamesInType f)) (map (updQNamesInFunc f)) (map (updOpName f)) --- rename program (update name of and all qualified names in program) rnmProg :: String -> Prog -> Prog rnmProg name p = updProgName (const name) (updQNamesInProg rnm p) where rnm (mod,n) | mod==progName p = (name,n) | otherwise = (mod,n) -- TypeDecl ------------------------------------------------------------------ -- Selectors --- transform type declaration trType :: (QName -> Visibility -> [(TVarIndex,Kind)] -> [ConsDecl] -> a) -> (QName -> Visibility -> [(TVarIndex,Kind)] -> TypeExpr -> a) -> (QName -> Visibility -> [(TVarIndex,Kind)] -> NewConsDecl -> a) -> TypeDecl -> a trType typ _ _ (Type name vis params cs) = typ name vis params cs trType _ typesyn _ (TypeSyn name vis params syn) = typesyn name vis params syn trType _ _ typenew (TypeNew name vis params c) = typenew name vis params c --- get name of type declaration typeName :: TypeDecl -> QName typeName = trType (\name _ _ _ -> name) (\name _ _ _ -> name) (\name _ _ _ -> name) --- get visibility of type declaration typeVisibility :: TypeDecl -> Visibility typeVisibility = trType (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) (\_ vis _ _ -> vis) --- get type parameters of type declaration typeParams :: TypeDecl -> [(TVarIndex, Kind)] typeParams = trType (\_ _ params _ -> params) (\_ _ params _ -> params) (\_ _ params _ -> params) --- get constructor declarations from type declaration typeConsDecls :: TypeDecl -> [ConsDecl] typeConsDecls = trType (\_ _ _ cs -> cs) failed failed --- get synonym of type declaration typeSyn :: TypeDecl -> TypeExpr typeSyn = trType failed (\_ _ _ syn -> syn) failed --- is type declaration a basic data type? isTypeData :: TypeDecl -> Bool isTypeData = trType (\_ _ _ _ -> True) (\_ _ _ _ -> False) (\_ _ _ _ -> False) --- is type declaration a type synonym? isTypeSyn :: TypeDecl -> Bool isTypeSyn = trType (\_ _ _ _ -> False) (\_ _ _ _ -> True) (\_ _ _ _ -> False) --- is type declaration a newtype? isTypeNew :: TypeDecl -> Bool isTypeNew = trType (\_ _ _ _ -> False) (\_ _ _ _ -> False) (\_ _ _ _ -> True) -- Update Operations --- update type declaration updType :: (QName -> QName) -> (Visibility -> Visibility) -> ([(TVarIndex,Kind)] -> [(TVarIndex,Kind)]) -> ([ConsDecl] -> [ConsDecl]) -> (NewConsDecl -> NewConsDecl) -> (TypeExpr -> TypeExpr) -> TypeDecl -> TypeDecl updType fn fv fp fc fnc fs = trType typ typesyn typenew where typ name vis params cs = Type (fn name) (fv vis) (fp params) (fc cs) typesyn name vis params syn = TypeSyn (fn name) (fv vis) (fp params) (fs syn) typenew name vis params nc = TypeNew (fn name) (fv vis) (fp params) (fnc nc) --- update name of type declaration updTypeName :: Update TypeDecl QName updTypeName f = updType f id id id id id --- update visibility of type declaration updTypeVisibility :: Update TypeDecl Visibility updTypeVisibility f = updType id f id id id id --- update type parameters of type declaration updTypeParams :: Update TypeDecl [(TVarIndex, Kind)] updTypeParams f = updType id id f id id id --- update constructor declarations of type declaration updTypeConsDecls :: Update TypeDecl [ConsDecl] updTypeConsDecls f = updType id id id f id id --- update newtype constructor declaration of type declaration updTypeNewConsDecl :: Update TypeDecl NewConsDecl updTypeNewConsDecl f = updType id id id id f id --- update synonym of type declaration updTypeSynonym :: Update TypeDecl TypeExpr updTypeSynonym = updType id id id id id -- Auxiliary Functions --- update all qualified names in type declaration updQNamesInType :: Update TypeDecl QName updQNamesInType f = updType f id id (map (updQNamesInConsDecl f)) (updQNamesInNewConsDecl f) (updQNamesInTypeExpr f) -- ConsDecl ------------------------------------------------------------------ -- Selectors --- transform constructor declaration trCons :: (QName -> Int -> Visibility -> [TypeExpr] -> a) -> ConsDecl -> a trCons cons (Cons name arity vis args) = cons name arity vis args --- get name of constructor declaration consName :: ConsDecl -> QName consName = trCons (\name _ _ _ -> name) --- get arity of constructor declaration consArity :: ConsDecl -> Int consArity = trCons (\_ arity _ _ -> arity) --- get visibility of constructor declaration consVisibility :: ConsDecl -> Visibility consVisibility = trCons (\_ _ vis _ -> vis) --- get arguments of constructor declaration consArgs :: ConsDecl -> [TypeExpr] consArgs = trCons (\_ _ _ args -> args) -- Update Operations --- update constructor declaration updCons :: (QName -> QName) -> (Int -> Int) -> (Visibility -> Visibility) -> ([TypeExpr] -> [TypeExpr]) -> ConsDecl -> ConsDecl updCons fn fa fv fas = trCons cons where cons name arity vis args = Cons (fn name) (fa arity) (fv vis) (fas args) --- update name of constructor declaration updConsName :: Update ConsDecl QName updConsName f = updCons f id id id --- update arity of constructor declaration updConsArity :: Update ConsDecl Int updConsArity f = updCons id f id id --- update visibility of constructor declaration updConsVisibility :: Update ConsDecl Visibility updConsVisibility f = updCons id id f id --- update arguments of constructor declaration updConsArgs :: Update ConsDecl [TypeExpr] updConsArgs = updCons id id id -- Auxiliary Functions --- update all qualified names in constructor declaration updQNamesInConsDecl :: Update ConsDecl QName updQNamesInConsDecl f = updCons f id id (map (updQNamesInTypeExpr f)) -- NewConsDecl ------------------------------------------------------------------ --- transform newtype constructor declaration trNewCons :: (QName -> Visibility -> TypeExpr -> a) -> NewConsDecl -> a trNewCons cons (NewCons name vis arg) = cons name vis arg -- get argument of newtype constructor declaration newConsArg :: NewConsDecl -> TypeExpr newConsArg = trNewCons (\_ _ arg -> arg) -- get name of newtype constructor declaration newConsName :: NewConsDecl -> QName newConsName = trNewCons (\name _ _ -> name) -- get visibility of newtype constructor declaration newConsVisibility :: NewConsDecl -> Visibility newConsVisibility = trNewCons (\_ vis _ -> vis) -- Update Operations --- update newtype constructor declaration updNewCons :: (QName -> QName) -> (Visibility -> Visibility) -> (TypeExpr -> TypeExpr) -> NewConsDecl -> NewConsDecl updNewCons fn fv fas = trNewCons newcons where newcons name vis args = NewCons (fn name) (fv vis) (fas args) --- update name of newtype constructor declaration updNewConsName :: Update NewConsDecl QName updNewConsName f = updNewCons f id id --- update visibility of newtype constructor declaration updNewConsVisibility :: Update NewConsDecl Visibility updNewConsVisibility f = updNewCons id f id --- update argument of newtype constructor declaration updNewConsArg :: Update NewConsDecl TypeExpr updNewConsArg = updNewCons id id -- Auxiliary Functions updQNamesInNewConsDecl :: Update NewConsDecl QName updQNamesInNewConsDecl f = updNewCons f id (updQNamesInTypeExpr f) -- TypeExpr ------------------------------------------------------------------ -- Selectors --- get index from type variable tVarIndex :: TypeExpr -> TVarIndex tVarIndex texpr = case texpr of (TVar n) -> n _ -> error "FlatCurryGoodies.tVarIndex: no type variable" --- get domain from functional type domain :: TypeExpr -> TypeExpr domain texpr = case texpr of (FuncType dom _) -> dom _ -> error "FlatCurryGoodies.domain: no functional type" --- get range from functional type range :: TypeExpr -> TypeExpr range texpr = case texpr of (FuncType _ ran) -> ran _ -> error "FlatCurryGoodies.range: no functional type" --- get name from constructed type tConsName :: TypeExpr -> QName tConsName texpr = case texpr of (TCons name _) -> name _ -> error "FlatCurryGoodies.tConsName: no constructed type" --- get arguments from constructed type tConsArgs :: TypeExpr -> [TypeExpr] tConsArgs texpr = case texpr of (TCons _ args) -> args _ -> error "FlatCurryGoodies.tConsArgs: no constructed type" --- transform type expression trTypeExpr :: (TVarIndex -> a) -> (QName -> [a] -> a) -> (a -> a -> a) -> ([(TVarIndex, Kind)] -> a -> a) -> TypeExpr -> a trTypeExpr tvar _ _ _ (TVar tv) = tvar tv trTypeExpr tvar tcons functype foralltype (TCons name args) = tcons name (map (trTypeExpr tvar tcons functype foralltype) args) trTypeExpr tvar tcons functype foralltype (FuncType from to) = functype (f from) (f to) where f = trTypeExpr tvar tcons functype foralltype trTypeExpr tvar tcons functype foralltype (ForallType ns t) = foralltype ns (trTypeExpr tvar tcons functype foralltype t) -- Test Operations --- is type expression a type variable? isTVar :: TypeExpr -> Bool isTVar = trTypeExpr (\_ -> True) (\_ _ -> False) (\_ _ -> False) (\_ _ -> False) --- is type declaration a constructed type? isTCons :: TypeExpr -> Bool isTCons = trTypeExpr (\_ -> False) (\_ _ -> True) (\_ _ -> False) (\_ _ -> False) --- is type declaration a functional type? isFuncType :: TypeExpr -> Bool isFuncType = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> True) (\_ _ -> False) --- is type declaration a forall type? isForallType :: TypeExpr -> Bool isForallType = trTypeExpr (\_ -> False) (\_ _ -> False) (\_ _ -> False) (\_ _ -> True) -- Update Operations --- update all type variables updTVars :: (TVarIndex -> TypeExpr) -> TypeExpr -> TypeExpr updTVars tvar = trTypeExpr tvar TCons FuncType ForallType --- update all type constructors updTCons :: (QName -> [TypeExpr] -> TypeExpr) -> TypeExpr -> TypeExpr updTCons tcons = trTypeExpr TVar tcons FuncType ForallType --- update all functional types updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr updFuncTypes functype = trTypeExpr TVar TCons functype ForallType --- update all forall types updForallTypes :: ([(TVarIndex, Kind)] -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr updForallTypes = trTypeExpr TVar TCons FuncType -- Auxiliary Functions --- get argument types from functional type argTypes :: TypeExpr -> [TypeExpr] argTypes (TVar _) = [] argTypes (TCons _ _) = [] argTypes (FuncType dom ran) = dom : argTypes ran argTypes (ForallType _ _) = [] --- get result type from (nested) functional type resultType :: TypeExpr -> TypeExpr resultType (TVar n) = TVar n resultType (TCons name args) = TCons name args resultType (FuncType _ ran) = resultType ran resultType (ForallType ns t) = ForallType ns t --- rename variables in type expression rnmAllVarsInTypeExpr :: (TVarIndex -> TVarIndex) -> TypeExpr -> TypeExpr rnmAllVarsInTypeExpr f = updTVars (TVar . f) --- update all qualified names in type expression updQNamesInTypeExpr :: (QName -> QName) -> TypeExpr -> TypeExpr updQNamesInTypeExpr f = updTCons (\name args -> TCons (f name) args) -- OpDecl -------------------------------------------------------------------- --- transform operator declaration trOp :: (QName -> Fixity -> Int -> a) -> OpDecl -> a trOp op (Op name fix prec) = op name fix prec -- Selectors --- get name from operator declaration opName :: OpDecl -> QName opName = trOp (\name _ _ -> name) --- get fixity of operator declaration opFixity :: OpDecl -> Fixity opFixity = trOp (\_ fix _ -> fix) --- get precedence of operator declaration opPrecedence :: OpDecl -> Int opPrecedence = trOp (\_ _ prec -> prec) -- Update Operations --- update operator declaration updOp :: (QName -> QName) -> (Fixity -> Fixity) -> (Int -> Int) -> OpDecl -> OpDecl updOp fn ff fp = trOp op where op name fix prec = Op (fn name) (ff fix) (fp prec) --- update name of operator declaration updOpName :: Update OpDecl QName updOpName f = updOp f id id --- update fixity of operator declaration updOpFixity :: Update OpDecl Fixity updOpFixity f = updOp id f id --- update precedence of operator declaration updOpPrecedence :: Update OpDecl Int updOpPrecedence = updOp id id -- FuncDecl ------------------------------------------------------------------ --- transform function trFunc :: (QName -> Int -> Visibility -> TypeExpr -> Rule -> a) -> FuncDecl -> a trFunc func (Func name arity vis t rule) = func name arity vis t rule -- Selectors --- get name of function funcName :: FuncDecl -> QName funcName = trFunc (\name _ _ _ _ -> name) --- get arity of function funcArity :: FuncDecl -> Int funcArity = trFunc (\_ arity _ _ _ -> arity) --- get visibility of function funcVisibility :: FuncDecl -> Visibility funcVisibility = trFunc (\_ _ vis _ _ -> vis) --- get type of function funcType :: FuncDecl -> TypeExpr funcType = trFunc (\_ _ _ t _ -> t) --- get rule of function funcRule :: FuncDecl -> Rule funcRule = trFunc (\_ _ _ _ rule -> rule) -- Update Operations --- update function updFunc :: (QName -> QName) -> (Int -> Int) -> (Visibility -> Visibility) -> (TypeExpr -> TypeExpr) -> (Rule -> Rule) -> FuncDecl -> FuncDecl updFunc fn fa fv ft fr = trFunc func where func name arity vis t rule = Func (fn name) (fa arity) (fv vis) (ft t) (fr rule) --- update name of function updFuncName :: Update FuncDecl QName updFuncName f = updFunc f id id id id --- update arity of function updFuncArity :: Update FuncDecl Int updFuncArity f = updFunc id f id id id --- update visibility of function updFuncVisibility :: Update FuncDecl Visibility updFuncVisibility f = updFunc id id f id id --- update type of function updFuncType :: Update FuncDecl TypeExpr updFuncType f = updFunc id id id f id --- update rule of function updFuncRule :: Update FuncDecl Rule updFuncRule = updFunc id id id id -- Auxiliary Functions --- is function externally defined? isExternal :: FuncDecl -> Bool isExternal = isRuleExternal . funcRule --- get variable names in a function declaration allVarsInFunc :: FuncDecl -> [Int] allVarsInFunc = allVarsInRule . funcRule --- get arguments of function, if not externally defined funcArgs :: FuncDecl -> [Int] funcArgs = ruleArgs . funcRule --- get body of function, if not externally defined funcBody :: FuncDecl -> Expr funcBody = ruleBody . funcRule funcRHS :: FuncDecl -> [Expr] funcRHS f | not (isExternal f) = orCase (funcBody f) | otherwise = [] where orCase e | isOr e = concatMap orCase (orExps e) | isCase e = concatMap orCase (map branchExpr (caseBranches e)) | otherwise = [e] --- rename all variables in function rnmAllVarsInFunc :: Update FuncDecl VarIndex rnmAllVarsInFunc = updFunc id id id id . rnmAllVarsInRule --- update all qualified names in function updQNamesInFunc :: Update FuncDecl QName updQNamesInFunc f = updFunc f id id (updQNamesInTypeExpr f) (updQNamesInRule f) --- update arguments of function, if not externally defined updFuncArgs :: Update FuncDecl [VarIndex] updFuncArgs = updFuncRule . updRuleArgs --- update body of function, if not externally defined updFuncBody :: Update FuncDecl Expr updFuncBody = updFuncRule . updRuleBody -- Rule ---------------------------------------------------------------------- --- transform rule trRule :: ([Int] -> Expr -> a) -> (String -> a) -> Rule -> a trRule rule _ (Rule args exp) = rule args exp trRule _ ext (External s) = ext s -- Selectors --- get rules arguments if it's not external ruleArgs :: Rule -> [Int] ruleArgs = trRule (\args _ -> args) failed --- get rules body if it's not external ruleBody :: Rule -> Expr ruleBody = trRule (\_ exp -> exp) failed --- get rules external declaration ruleExtDecl :: Rule -> String ruleExtDecl = trRule failed id -- Test Operations --- is rule external? isRuleExternal :: Rule -> Bool isRuleExternal = trRule (\_ _ -> False) (\_ -> True) -- Update Operations --- update rule updRule :: ([Int] -> [Int]) -> (Expr -> Expr) -> (String -> String) -> Rule -> Rule updRule fa fe fs = trRule rule ext where rule args exp = Rule (fa args) (fe exp) ext s = External (fs s) --- update rules arguments updRuleArgs :: Update Rule [VarIndex] updRuleArgs f = updRule f id id --- update rules body updRuleBody :: Update Rule Expr updRuleBody f = updRule id f id --- update rules external declaration updRuleExtDecl :: Update Rule String updRuleExtDecl f = updRule id id f -- Auxiliary Functions --- get variable names in a functions rule allVarsInRule :: Rule -> [Int] allVarsInRule = trRule (\args body -> args ++ allVars body) (\_ -> []) --- rename all variables in rule rnmAllVarsInRule :: Update Rule VarIndex rnmAllVarsInRule f = updRule (map f) (rnmAllVars f) id --- update all qualified names in rule updQNamesInRule :: Update Rule QName updQNamesInRule = updRuleBody . updQNames -- CombType ------------------------------------------------------------------ --- transform combination type trCombType :: a -> (Int -> a) -> a -> (Int -> a) -> CombType -> a trCombType fc _ _ _ FuncCall = fc trCombType _ fpc _ _ (FuncPartCall n) = fpc n trCombType _ _ cc _ ConsCall = cc trCombType _ _ _ cpc (ConsPartCall n) = cpc n -- Test Operations --- is type of combination FuncCall? isCombTypeFuncCall :: CombType -> Bool isCombTypeFuncCall = trCombType True (\_ -> False) False (\_ -> False) --- is type of combination FuncPartCall? isCombTypeFuncPartCall :: CombType -> Bool isCombTypeFuncPartCall = trCombType False (\_ -> True) False (\_ -> False) --- is type of combination ConsCall? isCombTypeConsCall :: CombType -> Bool isCombTypeConsCall = trCombType False (\_ -> False) True (\_ -> False) --- is type of combination ConsPartCall? isCombTypeConsPartCall :: CombType -> Bool isCombTypeConsPartCall = trCombType False (\_ -> False) False (\_ -> True) -- Auxiliary Functions missingArgs :: CombType -> Int missingArgs = trCombType 0 id 0 id -- Expr ---------------------------------------------------------------------- -- Selectors --- get internal number of variable varNr :: Expr -> Int varNr expr = case expr of (Var n) -> n _ -> error "FlatCurryGoodies.varNr: no variable" --- get literal if expression is literal expression literal :: Expr -> Literal literal expr = case expr of (Lit l) -> l _ -> error "FlatCurryGoodies.literal: no literal" --- get combination type of a combined expression combType :: Expr -> CombType combType expr = case expr of (Comb ct _ _) -> ct _ -> error "FlatCurryGoodies.combType: no combined expression" --- get name of a combined expression combName :: Expr -> QName combName expr = case expr of (Comb _ name _) -> name _ -> error "FlatCurryGoodies.combName: no combined expression" --- get arguments of a combined expression combArgs :: Expr -> [Expr] combArgs expr = case expr of (Comb _ _ args) -> args _ -> error "FlatCurryGoodies.combArgs: no combined expression" --- get number of missing arguments if expression is combined missingCombArgs :: Expr -> Int missingCombArgs = missingArgs . combType --- get indices of variables in let declaration letBinds :: Expr -> [(Int,Expr)] letBinds expr = case expr of (Let vs _) -> vs _ -> error "FlatCurryGoodies.letBinds: no let declaration" --- get body of let declaration letBody :: Expr -> Expr letBody expr = case expr of (Let _ e) -> e _ -> error "FlatCurryGoodies.letBody: no let declaration" --- get variable indices from declaration of free variables freeVars :: Expr -> [Int] freeVars expr = case expr of (Free vs _) -> vs _ -> error "FlatCurryGoodies.freeVars: no free variable declaration" --- get expression from declaration of free variables freeExpr :: Expr -> Expr freeExpr expr = case expr of (Free _ e) -> e _ -> error "FlatCurryGoodies.freeExpr: no free variable declaration" --- get expressions from or-expression orExps :: Expr -> [Expr] orExps expr = case expr of (Or e1 e2) -> [e1,e2] _ -> error "FlatCurryGoodies.orExps: no or-expression" --- get case-type of case expression caseType :: Expr -> CaseType caseType expr = case expr of (Case ct _ _) -> ct _ -> error "FlatCurryGoodies.caseType: no case expression" --- get scrutinee of case expression caseExpr :: Expr -> Expr caseExpr expr = case expr of (Case _ e _) -> e _ -> error "FlatCurryGoodies.caseExpr: no case expression" --- get branch expressions from case expression caseBranches :: Expr -> [BranchExpr] caseBranches expr = case expr of (Case _ _ bs) -> bs _ -> error "FlatCurryGoodies.caseBranches: no case expression" -- Test Operations --- is expression a variable? isVar :: Expr -> Bool isVar e = case e of Var _ -> True _ -> False --- is expression a literal expression? isLit :: Expr -> Bool isLit e = case e of Lit _ -> True _ -> False --- is expression combined? isComb :: Expr -> Bool isComb e = case e of Comb _ _ _ -> True _ -> False --- is expression a let expression? isLet :: Expr -> Bool isLet e = case e of Let _ _ -> True _ -> False --- is expression a declaration of free variables? isFree :: Expr -> Bool isFree e = case e of Free _ _ -> True _ -> False --- is expression an or-expression? isOr :: Expr -> Bool isOr e = case e of Or _ _ -> True _ -> False --- is expression a case expression? isCase :: Expr -> Bool isCase e = case e of Case _ _ _ -> True _ -> False --- transform expression trExpr :: (Int -> a) -> (Literal -> a) -> (CombType -> QName -> [a] -> a) -> ([(Int,a)] -> a -> a) -> ([Int] -> a -> a) -> (a -> a -> a) -> (CaseType -> a -> [b] -> a) -> (Pattern -> a -> b) -> (a -> TypeExpr -> a) -> Expr -> a trExpr var _ _ _ _ _ _ _ _ (Var n) = var n trExpr _ lit _ _ _ _ _ _ _ (Lit l) = lit l trExpr var lit comb lt fr or cas branch typed (Comb ct name args) = comb ct name (map (trExpr var lit comb lt fr or cas branch typed) args) trExpr var lit comb lt fr or cas branch typed (Let bs e) = lt (map (\ (n,exp) -> (n,f exp)) bs) (f e) where f = trExpr var lit comb lt fr or cas branch typed trExpr var lit comb lt fr or cas branch typed (Free vs e) = fr vs (trExpr var lit comb lt fr or cas branch typed e) trExpr var lit comb lt fr or cas branch typed (Or e1 e2) = or (f e1) (f e2) where f = trExpr var lit comb lt fr or cas branch typed trExpr var lit comb lt fr or cas branch typed (Case ct e bs) = cas ct (f e) (map (\ (Branch pat exp) -> branch pat (f exp)) bs) where f = trExpr var lit comb lt fr or cas branch typed trExpr var lit comb lt fr or cas branch typed (Typed e ty) = typed (trExpr var lit comb lt fr or cas branch typed e) ty -- Update Operations --- update all variables in given expression updVars :: (Int -> Expr) -> Expr -> Expr updVars var = trExpr var Lit Comb Let Free Or Case Branch Typed --- update all literals in given expression updLiterals :: (Literal -> Expr) -> Expr -> Expr updLiterals lit = trExpr Var lit Comb Let Free Or Case Branch Typed --- update all combined expressions in given expression updCombs :: (CombType -> QName -> [Expr] -> Expr) -> Expr -> Expr updCombs comb = trExpr Var Lit comb Let Free Or Case Branch Typed --- update all let expressions in given expression updLets :: ([(Int,Expr)] -> Expr -> Expr) -> Expr -> Expr updLets lt = trExpr Var Lit Comb lt Free Or Case Branch Typed --- update all free declarations in given expression updFrees :: ([Int] -> Expr -> Expr) -> Expr -> Expr updFrees fr = trExpr Var Lit Comb Let fr Or Case Branch Typed --- update all or expressions in given expression updOrs :: (Expr -> Expr -> Expr) -> Expr -> Expr updOrs or = trExpr Var Lit Comb Let Free or Case Branch Typed --- update all case expressions in given expression updCases :: (CaseType -> Expr -> [BranchExpr] -> Expr) -> Expr -> Expr updCases cas = trExpr Var Lit Comb Let Free Or cas Branch Typed --- update all case branches in given expression updBranches :: (Pattern -> Expr -> BranchExpr) -> Expr -> Expr updBranches branch = trExpr Var Lit Comb Let Free Or Case branch Typed --- update all typed expressions in given expression updTypeds :: (Expr -> TypeExpr -> Expr) -> Expr -> Expr updTypeds typed = trExpr Var Lit Comb Let Free Or Case Branch typed -- Auxiliary Functions --- is expression a call of a function where all arguments are provided? isFuncCall :: Expr -> Bool isFuncCall e = isComb e && isCombTypeFuncCall (combType e) --- is expression a partial function call? isFuncPartCall :: Expr -> Bool isFuncPartCall e = isComb e && isCombTypeFuncPartCall (combType e) --- is expression a call of a constructor? isConsCall :: Expr -> Bool isConsCall e = isComb e && isCombTypeConsCall (combType e) --- is expression a partial constructor call? isConsPartCall :: Expr -> Bool isConsPartCall e = isComb e && isCombTypeConsPartCall (combType e) --- is expression fully evaluated? isGround :: Expr -> Bool isGround exp = case exp of Comb ConsCall _ args -> all isGround args _ -> isLit exp --- get all variables (also pattern variables) in expression allVars :: Expr -> [Int] allVars e = trExpr (:) (const id) comb lt fr (.) cas branch const e [] where comb _ _ = foldr (.) id lt bs exp = exp . foldr (.) id (map (\ (n,ns) -> (n:) . ns) bs) fr vs exp = (vs++) . exp cas _ exp bs = exp . foldr (.) id bs branch pat exp = ((args pat)++) . exp args pat | isConsPattern pat = patArgs pat | otherwise = [] --- rename all variables (also in patterns) in expression rnmAllVars :: Update Expr Int rnmAllVars f = trExpr (Var . f) Lit Comb lt (Free . map f) Or Case branch Typed where lt = Let . map (\ (n,exp) -> (f n,exp)) branch = Branch . updPatArgs (map f) --- update all qualified names in expression updQNames :: Update Expr QName updQNames f = trExpr Var Lit comb Let Free Or Case (Branch . updPatCons f) typed where comb ct name args = Comb ct (f name) args typed e ty = Typed e (updQNamesInTypeExpr f ty) -- BranchExpr ---------------------------------------------------------------- --- transform branch expression trBranch :: (Pattern -> Expr -> a) -> BranchExpr -> a trBranch branch (Branch pat exp) = branch pat exp -- Selectors --- get pattern from branch expression branchPattern :: BranchExpr -> Pattern branchPattern = trBranch (\pat _ -> pat) --- get expression from branch expression branchExpr :: BranchExpr -> Expr branchExpr = trBranch (\_ e -> e) -- Update Operations --- update branch expression updBranch :: (Pattern -> Pattern) -> (Expr -> Expr) -> BranchExpr -> BranchExpr updBranch fp fe = trBranch branch where branch pat exp = Branch (fp pat) (fe exp) --- update pattern of branch expression updBranchPattern :: Update BranchExpr Pattern updBranchPattern f = updBranch f id --- update expression of branch expression updBranchExpr :: Update BranchExpr Expr updBranchExpr = updBranch id -- Pattern ------------------------------------------------------------------- --- transform pattern trPattern :: (QName -> [Int] -> a) -> (Literal -> a) -> Pattern -> a trPattern pattern _ (Pattern name args) = pattern name args trPattern _ lpattern (LPattern l) = lpattern l -- Selectors --- get name from constructor pattern patCons :: Pattern -> QName patCons = trPattern (\name _ -> name) failed --- get arguments from constructor pattern patArgs :: Pattern -> [Int] patArgs = trPattern (\_ args -> args) failed --- get literal from literal pattern patLiteral :: Pattern -> Literal patLiteral = trPattern failed id -- Test Operations --- is pattern a constructor pattern? isConsPattern :: Pattern -> Bool isConsPattern = trPattern (\_ _ -> True) (\_ -> False) -- Update Operations --- update pattern updPattern :: (QName -> QName) -> ([Int] -> [Int]) -> (Literal -> Literal) -> Pattern -> Pattern updPattern fn fa fl = trPattern pattern lpattern where pattern name args = Pattern (fn name) (fa args) lpattern l = LPattern (fl l) --- update constructors name of pattern updPatCons :: (QName -> QName) -> Pattern -> Pattern updPatCons f = updPattern f id id --- update arguments of constructor pattern updPatArgs :: ([Int] -> [Int]) -> Pattern -> Pattern updPatArgs f = updPattern id f id --- update literal of pattern updPatLiteral :: (Literal -> Literal) -> Pattern -> Pattern updPatLiteral f = updPattern id id f -- Auxiliary Functions --- build expression from pattern patExpr :: Pattern -> Expr patExpr = trPattern (\ name -> Comb ConsCall name . map Var) Lit curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/src/FlatCurry/Pretty.curry000066400000000000000000000307501377556325500276010ustar00rootroot00000000000000--- -------------------------------------------------------------------------- --- This library provides pretty-printers for FlatCurry modules --- and all substructures (e.g., expressions). --- --- @author Bjoern Peemoeller --- @version November 2020 --- -------------------------------------------------------------------------- module FlatCurry.Pretty where import Prelude hiding (empty) import Text.Pretty import FlatCurry.Types --- Options for pretty printing --- @field indentWidth - number of columns for indentation of substructures --- @field qualMode - Qualification mode of pretty printer --- @field currentModule - Name of current module to be pretty-printed, used --- for proper qualification data Options = Options { indentWidth :: Int , qualMode :: QualMode , currentModule :: String } --- Qualification mode, determines whether identifiers are printed qualified --- or unqualified. While `QualNone` and `QualImports` aim at readability, --- there may be ambiguities due to shadowing. On the contrary, `QualImports` --- and `QualAll` produce correct output at the cost of readability. --- --- @cons QualNone - no qualification, only unqualified names --- @cons QualImportsButPrelude - qualify all imports except those from --- the module `Prelude` --- @cons QualImports - qualify all imports, including `Prelude` --- @cons QualAll - qualify all names data QualMode = QualNone | QualImportsButPrelude | QualImports | QualAll -- deriving Eq instance Eq QualMode where QualNone == x = case x of { QualNone -> True ; _ -> False } QualImportsButPrelude == x = case x of { QualImportsButPrelude -> True ; _ -> False } QualImports == x = case x of { QualImports -> True ; _ -> False } QualAll == x = case x of { QualAll -> True ; _ -> False } --- Default `Options` for pretty-printing. defaultOptions :: Options defaultOptions = Options { indentWidth = 2 , qualMode = QualImportsButPrelude , currentModule = "" } -- --------------------------------------------------------------------------- -- Pretty printing of Flat modules -- --------------------------------------------------------------------------- --- pretty-print a FlatCurry module ppProg :: Options -> Prog -> Doc ppProg o (Prog m is ts fs os) = vsepBlank [ ppHeader o' m ts fs , ppImports o' is , ppOpDecls o' os , ppTypeDecls o' ts , ppFuncDecls o' fs ] where o' = o { currentModule = m } --- pretty-print the module header ppHeader :: Options -> String -> [TypeDecl] -> [FuncDecl] -> Doc ppHeader o m ts fs = indent o $ sep [text "module" <+> text m, ppExports o ts fs, text "where"] --- pretty-print the export list ppExports :: Options -> [TypeDecl] -> [FuncDecl] -> Doc ppExports o ts fs = tupledSpaced (map (ppTypeExport o) ts ++ ppFuncExports o fs) --- pretty-print a type export ppTypeExport :: Options -> TypeDecl -> Doc ppTypeExport o (Type qn vis _ cs) | vis == Private = empty | null cs = ppPrefixQOp o qn | all isPublicCons cs = ppPrefixQOp o qn <+> text "(..)" | otherwise = ppPrefixQOp o qn <+> tupled (ppConsExports o cs) where isPublicCons (Cons _ _ v _) = v == Public ppTypeExport o (TypeSyn qn vis _ _ ) | vis == Private = empty | otherwise = ppPrefixQOp o qn ppTypeExport o (TypeNew qn vis _ (NewCons _ vis' _)) | vis == Private || vis' == Private = empty | otherwise = ppPrefixQOp o qn <+> text "(..)" --- pretty-print the export list of constructors ppConsExports :: Options -> [ConsDecl] -> [Doc] ppConsExports o cs = [ ppPrefixQOp o qn | Cons qn _ Public _ <- cs] --- pretty-print the export list of functions ppFuncExports :: Options -> [FuncDecl] -> [Doc] ppFuncExports o fs = [ ppPrefixQOp o qn | Func qn _ Public _ _ <- fs] --- pretty-print a list of import statements ppImports :: Options -> [String] -> Doc ppImports o = vsep . map (ppImport o) --- pretty-print a single import statement ppImport :: Options -> String -> Doc ppImport o m = indent o $ text "import" <+> text m --- pretty-print a list of operator fixity declarations ppOpDecls :: Options -> [OpDecl] -> Doc ppOpDecls o = vsep . map (ppOpDecl o) --- pretty-print a single operator fixity declaration ppOpDecl :: Options -> OpDecl -> Doc ppOpDecl o (Op qn fix n) = indent o $ ppFixity fix <+> int n <+> ppInfixQOp o qn --- pretty-print the associativity keyword ppFixity :: Fixity -> Doc ppFixity InfixOp = text "infix" ppFixity InfixlOp = text "infixl" ppFixity InfixrOp = text "infixr" --- pretty-print a list of type declarations ppTypeDecls :: Options -> [TypeDecl] -> Doc ppTypeDecls o = vsepBlank . map (ppTypeDecl o) --- pretty-print a type declaration ppTypeDecl :: Options -> TypeDecl -> Doc ppTypeDecl o (Type qn _ vs cs) = indent o $ (text "data" <+> ppName qn <+> hsep (empty : map (ppTVarIndex . fst) vs)) $$ ppConsDecls o cs ppTypeDecl o (TypeSyn qn _ vs ty) = indent o $ text "type" <+> ppName qn <+> hsep (empty : map (ppTVarIndex . fst) vs) equals <+> ppTypeExp o ty ppTypeDecl o (TypeNew qn _ vs c) = indent o $ text "newtype" <+> ppName qn <+> hsep (empty : map (ppTVarIndex . fst) vs) $$ ppNewConsDecl o c --- pretty-print the constructor declarations ppConsDecls :: Options -> [ConsDecl] -> Doc ppConsDecls o cs = vsep $ zipWith (<+>) (equals : repeat bar) (map (ppConsDecl o) cs) --- pretty print a single constructor ppConsDecl :: Options -> ConsDecl -> Doc ppConsDecl o (Cons qn _ _ tys) = hsep $ ppPrefixOp qn : map (ppTypeExpr o 2) tys --- pretty print a single newtype constructor ppNewConsDecl :: Options -> NewConsDecl -> Doc ppNewConsDecl o (NewCons qn _ ty) = hsep [ppPrefixOp qn, ppTypeExpr o 2 ty] --- pretty a top-level type expression ppTypeExp :: Options -> TypeExpr -> Doc ppTypeExp o = ppTypeExpr o 0 --- pretty-print a type expression ppTypeExpr :: Options -> Int -> TypeExpr -> Doc ppTypeExpr _ _ (TVar v) = ppTVarIndex v ppTypeExpr o p (FuncType ty1 ty2) = parensIf (p > 0) $ ppTypeExpr o 1 ty1 rarrow <+> ppTypeExp o ty2 ppTypeExpr o p (TCons qn tys) | isListId qn && length tys == 1 = brackets (ppTypeExp o (head tys)) | isTupleId qn = tupled (map (ppTypeExp o) tys) | otherwise = parensIf (p > 1 && not (null tys)) $ sep (ppPrefixQOp o qn : map (ppTypeExpr o 2) tys) ppTypeExpr o p (ForallType vs ty) | null vs = ppTypeExpr o p ty | otherwise = parensIf (p > 0) $ ppQuantifiedVars vs <+> ppTypeExpr o 0 ty --- pretty-print explicitly quantified type variables ppQuantifiedVars :: [(TVarIndex, Kind)] -> Doc ppQuantifiedVars vs | null vs = empty | otherwise = text "forall" <+> hsep (map (ppTVarIndex . fst) vs) <+> char '.' --- pretty-print a type variable ppTVarIndex :: TVarIndex -> Doc ppTVarIndex i = text $ vars !! i where vars = [ chr c : if n == 0 then [] else show n | n <- [0 ..], c <- [ord 'a' .. ord 'z'] ] --- pretty-print a list of function declarations ppFuncDecls :: Options -> [FuncDecl] -> Doc ppFuncDecls o = vsepBlank . map (ppFuncDecl o) --- pretty-print a function declaration ppFuncDecl :: Options -> FuncDecl -> Doc ppFuncDecl o (Func qn _ _ ty r) = indent o (sep [ppPrefixOp qn, text "::", ppTypeExp o ty]) $$ indent o (ppPrefixOp qn <+> ppRule o r) --- pretty-print a function rule ppRule :: Options -> Rule -> Doc ppRule o (Rule vs e) | null vs = equals <+> ppExp o e | otherwise = hsep (map ppVarIndex vs) equals <+> ppExp o e ppRule _ (External e) = text "external" <+> dquotes (text e) --- Pretty-print a top-level expression. ppExp :: Options -> Expr -> Doc ppExp o = ppExpr o 0 --- pretty-print an expression ppExpr :: Options -> Int -> Expr -> Doc ppExpr _ _ (Var v) = ppVarIndex v ppExpr _ _ (Lit l) = ppLiteral l ppExpr o p (Comb _ qn es) = ppComb o p qn es ppExpr o p (Free vs e) | null vs = ppExpr o p e | otherwise = parensIf (p > 0) $ sep [ text "let" <+> sep (punctuate comma (map ppVarIndex vs)) <+> text "free" , text "in" ppExp o e ] ppExpr o p (Let ds e) = parensIf (p > 0) $ sep [ text "let" <+> ppDecls o ds , text "in" <+> ppExp o e ] ppExpr o p (Or e1 e2) = parensIf (p > 0) $ ppExpr o 1 e1 <+> text "?" <+> ppExpr o 1 e2 ppExpr o p (Case ct e bs) = parensIf (p > 0) $ indent o $ ppCaseType ct <+> ppExpr o 1 e <+> text "of" $$ vsep (map (ppBranch o) bs) ppExpr o p (Typed e ty) = parensIf (p > 0) $ ppExp o e <+> text "::" <+> ppTypeExp o ty --- pretty-print a variable ppVarIndex :: VarIndex -> Doc ppVarIndex i | i < 0 = text $ 'x' : show (negate i) | otherwise = text $ 'v' : show i --- pretty-print a literal ppLiteral :: Literal -> Doc ppLiteral (Intc i) = int i ppLiteral (Floatc f) = float f ppLiteral (Charc c) = text (show c) --- Pretty print a constructor or function call ppComb :: Options -> Int -> QName -> [Expr] -> Doc ppComb o p qn es | isListId qn && null es = text "[]" | isTupleId qn = tupled (map (ppExp o) es) | otherwise = case es of [] -> ppPrefixQOp o qn [e1,e2] | isInfixOp qn -> parensIf (p > 0) $ fillSep [ppExpr o 1 e1, ppInfixQOp o qn, ppExpr o 1 e2] _ -> parensIf (p > 0) $ fillSep (ppPrefixQOp o qn : map (ppExpr o 1) es) --- pretty-print a list of declarations ppDecls :: Options -> [(VarIndex, Expr)] -> Doc ppDecls o = align . vsep . map (ppDecl o) --- pretty-print a single declaration ppDecl :: Options -> (VarIndex, Expr) -> Doc ppDecl o (v, e) = ppVarIndex v <+> equals <+> ppExp o e --- Pretty print the type of a case expression ppCaseType :: CaseType -> Doc ppCaseType Rigid = text "case" ppCaseType Flex = text "fcase" --- Pretty print a case branch ppBranch :: Options -> BranchExpr -> Doc ppBranch o (Branch p e) = ppPattern o p <+> rarrow <+> indent o (ppExp o e) --- Pretty print a pattern ppPattern :: Options -> Pattern -> Doc ppPattern o (Pattern c vs) | isListId c && null vs = text "[]" | isTupleId c = tupled (map ppVarIndex vs) | otherwise = case vs of [v1,v2] | isInfixOp c -> ppVarIndex v1 <+> ppInfixQOp o c <+> ppVarIndex v2 _ -> hsep (ppPrefixQOp o c : map ppVarIndex vs) ppPattern _ (LPattern l) = ppLiteral l -- --------------------------------------------------------------------------- -- Names -- --------------------------------------------------------------------------- --- pretty-print a qualified prefix operator. ppPrefixQOp :: Options -> QName -> Doc ppPrefixQOp o qn = parensIf (isInfixOp qn) (ppQName o qn) --- pretty-print a prefix operator unqualified. ppPrefixOp :: QName -> Doc ppPrefixOp qn = parensIf (isInfixOp qn) (ppName qn) --- pretty-print an infix operator ppInfixQOp :: Options -> QName -> Doc ppInfixQOp o qn = if isInfixOp qn then ppQName o qn else bquotes (ppQName o qn) --- Pretty-print a qualified name ppQName :: Options -> QName -> Doc ppQName o qn@(m, i) | null m = text i | isConsId qn || isListId qn || isTupleId qn = text i | q == QualNone = text i | q == QualImportsButPrelude && (m == m' || m == "Prelude") = text i | q == QualImports && m == m' = text i | otherwise = text $ m ++ '.' : i where q = qualMode o m' = currentModule o --- Pretty-print a qualified name unqualified (e.g., for type definitions). ppName :: QName -> Doc ppName (_, i) = text i --- Check whether an operator is an infix operator isInfixOp :: QName -> Bool isInfixOp = all (`elem` "~!@#$%^&*+-=<>:?./|\\") . snd --- Check whether an identifier represents the `:` list constructor. isConsId :: QName -> Bool isConsId (m, i) = m `elem` ["Prelude", ""] && i == ":" --- Check whether an identifier represents a list isListId :: QName -> Bool isListId (m, i) = m `elem` ["Prelude", ""] && i == "[]" --- Check whether an identifier represents a tuple isTupleId :: QName -> Bool isTupleId (m, i) = m `elem` ["Prelude", ""] && i == mkTuple (length i) where mkTuple n = '(' : replicate (n - 2) ',' ++ ")" --- Indentation indent :: Options -> Doc -> Doc indent o d = nest (indentWidth o) d curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/src/FlatCurry/Read.curry000066400000000000000000000164121377556325500271640ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library defines operations to read FlatCurry programs or interfaces --- together with all its imported modules in the current load path. --- --- @author Michael Hanus, Bjoern Peemoeller, Finn Teegen --- @version November 2020 ------------------------------------------------------------------------------ module FlatCurry.Read ( readFlatCurryInPath , readFlatCurryWithImports , readFlatCurryWithImportsInPath , readFlatCurryIntWithImports , readFlatCurryIntWithImportsInPath ) where import Control.Monad ( when ) import System.Directory ( getModificationTime, getFileWithSuffix , findFileWithSuffix ) import System.FilePath ( dropExtension, normalise, takeFileName ) import System.CurryPath ( getLoadPathForModule, lookupModuleSource ) import System.FrontendExec ( FrontendTarget (FCY), callFrontendWithParams , defaultParams, setQuiet, setFullPath ) import FlatCurry.Types import FlatCurry.Files --- Reads a FlatCurry program together in a given load path. --- The arguments are a load path and the name of the module. readFlatCurryInPath :: [String] -> String -> IO Prog readFlatCurryInPath loadpath modname = do [prog] <- readFlatCurryFileInPath False False loadpath modname [".fcy"] return prog --- Reads a FlatCurry program together with all its imported modules. --- The argument is the name of the main module, --- possibly with a directory prefix. readFlatCurryWithImports :: String -> IO [Prog] readFlatCurryWithImports modname = do loadpath <- getLoadPathForModule modname readFlatCurryFileInPath True False loadpath (takeFileName modname) [".fcy"] --- Reads a FlatCurry program together with all its imported modules --- in a given load path. --- The arguments are a load path and the name of the main module. readFlatCurryWithImportsInPath :: [String] -> String -> IO [Prog] readFlatCurryWithImportsInPath loadpath modname = readFlatCurryFileInPath True False loadpath modname [".fcy"] --- Reads a FlatCurry interface together with all its imported module --- interfaces. --- The argument is the name of the main module, --- possibly with a directory prefix. --- If there is no interface file but a FlatCurry file (suffix ".fcy"), --- the FlatCurry file is read instead of the interface. readFlatCurryIntWithImports :: String -> IO [Prog] readFlatCurryIntWithImports modname = do loadpath <- getLoadPathForModule modname readFlatCurryFileInPath True False loadpath (takeFileName modname) [".fint",".fcy"] --- Reads a FlatCurry interface together with all its imported module --- interfaces in a given load path. --- The arguments are a load path and the name of the main module. --- If there is no interface file but a FlatCurry file (suffix ".fcy"), --- the FlatCurry file is read instead of the interface. readFlatCurryIntWithImportsInPath :: [String] -> String -> IO [Prog] readFlatCurryIntWithImportsInPath loadpath modname = readFlatCurryFileInPath True False loadpath modname [".fint",".fcy"] -- Read a FlatCurry file (together with its imported modules if the first -- argument is true). -- The further arguments are the verbosity mode, the loadpath, -- the name of the main module, and the possible suffixes -- of the FlatCurry file (e.g., [".fint",".fcy"]). readFlatCurryFileInPath :: Bool -> Bool -> [String] -> String -> [String] -> IO [Prog] readFlatCurryFileInPath withImp verb loadpath mod sfxs = do when verb $ putStr "Reading FlatCurry files " -- try to read the interface files directly eiMods <- tryReadFlatCurryFile withImp verb loadpath mod sfxs either (\_ -> parseFlatCurryFile withImp verb loadpath mod sfxs) return eiMods -- Parse a FlatCurry file together with its imported modules. -- The argument is the loadpath, the name of the main module, and the -- possible suffixes of the FlatCurry file (e.g., [".fint",".fcy"]). parseFlatCurryFile :: Bool -> Bool -> [String] -> String -> [String] -> IO [Prog] parseFlatCurryFile withImp verb loadpath modname suffixes = do when verb $ putStrLn $ ">>>>> FlatCurry files not up-to-date, parsing module \"" ++ modname ++ "\"..." callFrontendWithParams FCY (setQuiet True (setFullPath loadpath defaultParams)) modname when verb $ putStr "Reading FlatCurry files " eiMods <- tryReadFlatCurryFile withImp verb loadpath modname suffixes return (either (error . notFound) id eiMods) where notFound mods = "FlatCurry file not found for the following module(s): " ++ unwords mods -- Read a FlatCurry file (with all its imports if first argument is true). -- If all files could be read, -- then `Right progs` is returned, otherwise `Left mods` where `mods` is -- the list of modules that could *not* be read. tryReadFlatCurryFile :: Bool -> Bool -> [String] -> String -> [String] -> IO (Either [String] [Prog]) tryReadFlatCurryFile withImp verb loadpath modname suffixes = if withImp then tryReadFlatCurryFileWithImports verb loadpath modname suffixes else do mProg <- tryReadFlatCurry verb loadpath modname suffixes return $ maybe (Left [modname]) (Right . (:[])) mProg -- Read a FlatCurry file with all its imports. If all files could be read, -- then `Right progs` is returned, otherwise `Left mods` where `mods` is -- the list of modules that could *not* be read. tryReadFlatCurryFileWithImports :: Bool -> [String] -> String -> [String] -> IO (Either [String] [Prog]) tryReadFlatCurryFileWithImports verb loadpath modname suffixes = collect [modname] [] where -- Collects all imported modules collect [] _ = when verb (putStrLn "done") >> return (Right []) collect (mod:mods) implist | mod `elem` implist = collect mods implist | otherwise = do mbProg <- tryReadFlatCurry verb loadpath mod suffixes case mbProg of Nothing -> return (Left [mod]) Just prog@(Prog _ is _ _ _) -> do mbresults <- collect (mods ++ is) (mod:implist) return (either Left (Right . (prog :)) mbresults) -- Read a single FlatCurry file for a module if it exists and is up-to-date -- w.r.t. the source program. If no source exists, it is always assumed -- to be up-to-date. If the source is newer then the FlatCurry file or -- there is no FlatCurry file, the function returns `Nothing`. tryReadFlatCurry :: Bool -> [String] -> String -> [String] -> IO (Maybe Prog) tryReadFlatCurry verb loadpath modname suffixes = do mbSrc <- lookupModuleSource loadpath modname case mbSrc of Nothing -> findFileWithSuffix flattakeBaseName suffixes loadpath >>= maybe (return Nothing) (fmap Just . readFlatCurryFile) Just (_,src) -> do mbFcy <- findFileWithSuffix flattakeBaseName suffixes loadpath case mbFcy of Nothing -> return Nothing Just fcy -> do ctime <- getModificationTime src ftime <- getModificationTime fcy if ctime > ftime then return Nothing else do when verb $ putStr (normalise fcy ++ " ") fmap Just (readFlatCurryFile fcy) where flattakeBaseName = dropExtension (flatCurryFileName modname) curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/src/FlatCurry/Show.curry000066400000000000000000000372011377556325500272300ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library contains operations to transform FlatCurry programs --- into string representations, either in a FlatCurry format or --- in a Curry-like syntax. --- --- This library contains --- --- * show functions for a string representation of FlatCurry programs --- (`showFlatProg`, `showFlatType`, `showFlatFunc`) --- * functions for showing FlatCurry (type) expressions in (almost) --- Curry syntax (`showCurryType`, `showCurryExpr`,...). --- --- @author Michael Hanus --- @version December 2020 ------------------------------------------------------------------------------ module FlatCurry.Show (showFlatProg, showFlatType, showFlatFunc , showCurryType, isClassContext , showCurryExpr, showCurryId, showCurryVar ) where import FlatCurry.Types import Data.List import Data.Char --- Shows a FlatCurry program term as a string (with some pretty printing). showFlatProg :: Prog -> String showFlatProg (Prog modname imports types funcs ops) = " (Prog " ++ show modname ++ (if null imports then "\n []" else "\n [" ++ showFlatListElems show imports ++ "]") ++ (if null types then "\n []" else "\n [" ++ showFlatListElems showFlatType types ++ "\n ]") ++ "\n [" ++ showFlatListElems showFlatFunc funcs ++ "\n ]" ++ "\n " ++ showFlatList showFlatOp ops ++ "\n )\n" showFlatVisibility :: Visibility -> String showFlatVisibility Public = " Public " showFlatVisibility Private = " Private " showFlatFixity :: Fixity -> String showFlatFixity InfixOp = " InfixOp " showFlatFixity InfixlOp = " InfixlOp " showFlatFixity InfixrOp = " InfixrOp " showFlatOp :: OpDecl -> String showFlatOp (Op name fix prec) = "(Op " ++ show name ++ showFlatFixity fix ++ show prec ++ ")" showFlatType :: TypeDecl -> String showFlatType (Type name vis tpars consdecls) = "\n (Type " ++ show name ++ showFlatVisibility vis ++ showFlatList show tpars ++ showFlatList showFlatCons consdecls ++ ")" showFlatType (TypeSyn name vis tpars texp) = "\n (TypeSyn " ++ show name ++ showFlatVisibility vis ++ showFlatList show tpars ++ showFlatTypeExpr texp ++ ")" showFlatType (TypeNew name vis tpars consdecl) = "\n (TypeNew " ++ show name ++ showFlatVisibility vis ++ showFlatList show tpars ++ showFlatNewCons consdecl ++ ")" showFlatCons :: ConsDecl -> String showFlatCons (Cons cname arity vis types) = "(Cons " ++ show cname ++ " " ++ show arity ++ showFlatVisibility vis ++ showFlatList showFlatTypeExpr types ++ ")" showFlatNewCons :: NewConsDecl -> String showFlatNewCons (NewCons cname vis texp) = "(NewCons " ++ show cname ++ showFlatVisibility vis ++ showFlatTypeExpr texp ++ ")" showFlatFunc :: FuncDecl -> String showFlatFunc (Func name arity vis ftype rl) = "\n (Func " ++ show name ++ " " ++ show arity ++ " " ++ showFlatVisibility vis ++ "\n " ++ showFlatTypeExpr ftype ++ "\n " ++ showFlatRule rl ++ ")" showFlatRule :: Rule -> String showFlatRule (Rule params expr) = " (Rule " ++ showFlatList show params ++ showFlatExpr expr ++ ")" showFlatRule (External name) = " (External " ++ show name ++ ")" showFlatTypeExpr :: TypeExpr -> String showFlatTypeExpr (FuncType t1 t2) = "(FuncType " ++ showFlatTypeExpr t1 ++ " " ++ showFlatTypeExpr t2 ++ ")" showFlatTypeExpr (TCons tc ts) = "(TCons " ++ show tc ++ showFlatList showFlatTypeExpr ts ++ ")" showFlatTypeExpr (TVar n) = "(TVar " ++ show n ++ ")" showFlatTypeExpr (ForallType tvs te) = "(ForallType " ++ showFlatList show tvs ++ showFlatTypeExpr te ++ ")" showFlatCombType :: CombType -> String showFlatCombType FuncCall = "FuncCall" showFlatCombType ConsCall = "ConsCall" showFlatCombType (FuncPartCall n) = "(FuncPartCall " ++ show n ++ ")" showFlatCombType (ConsPartCall n) = "(ConsPartCall " ++ show n ++ ")" showFlatExpr :: Expr -> String showFlatExpr (Var n) = "(Var " ++ show n ++ ")" showFlatExpr (Lit l) = "(Lit " ++ showFlatLit l ++ ")" showFlatExpr (Comb ctype cf es) = "(Comb " ++ showFlatCombType ctype ++ " " ++ show cf ++ showFlatList showFlatExpr es ++ ")" showFlatExpr (Let bindings exp) = "(Let " ++ showFlatList showFlatBinding bindings ++ showFlatExpr exp ++ ")" where showFlatBinding (x,e) = "("++show x++","++showFlatExpr e++")" showFlatExpr (Free xs e) = "(Free " ++ showFlatList show xs ++ showFlatExpr e ++ ")" showFlatExpr (Or e1 e2) = "(Or " ++ showFlatExpr e1 ++ " " ++ showFlatExpr e2 ++ ")" showFlatExpr (Case Rigid e bs) = "(Case Rigid " ++ showFlatExpr e ++ showFlatList showFlatBranch bs ++ ")" showFlatExpr (Case Flex e bs) = "(Case Flex " ++ showFlatExpr e ++ showFlatList showFlatBranch bs ++ ")" showFlatExpr (Typed e ty) = "(Typed " ++ showFlatExpr e ++ ' ' : showFlatTypeExpr ty ++ ")" showFlatLit :: Literal -> String showFlatLit (Intc i) = "(Intc " ++ show i ++ ")" showFlatLit (Floatc f) = "(Floatc " ++ show f ++ ")" showFlatLit (Charc c) = "(Charc " ++ show c ++ ")" showFlatBranch :: BranchExpr -> String showFlatBranch (Branch p e) = "(Branch " ++ showFlatPattern p ++ showFlatExpr e ++ ")" showFlatPattern :: Pattern -> String showFlatPattern (Pattern qn xs) = "(Pattern " ++ show qn ++ showFlatList show xs ++ ")" showFlatPattern (LPattern lit) = "(LPattern " ++ showFlatLit lit ++ ")" -- format a finite list of elements: showFlatList :: (a->String) -> [a] -> String showFlatList format elems = " [" ++ showFlatListElems format elems ++ "] " showFlatListElems :: (a->String) -> [a] -> String showFlatListElems format elems = intercalate "," (map format elems) ------------------------------------------------------------------------------ --- Shows a FlatCurry type in Curry syntax. --- --- @param trans - a translation function from qualified type names --- to external type names --- @param nested - True iff brackets must be written around complex types --- @param texpr - the FlatCurry type expression to be formatted --- @return the String representation of the formatted type expression showCurryType :: (QName -> String) -> Bool -> TypeExpr -> String showCurryType tf nested = showTypeWithClass [] where showTypeWithClass cls texp = case texp of ForallType _ te -> showTypeWithClass cls te -- strip forall quantifiers FuncType t1 t2 -> maybe (showClassedType cls texp) (\ (cn,cv) -> showTypeWithClass (cls ++ [(cn,cv)]) t2) (isClassContext t1) _ -> showClassedType cls texp showClassedType cls texp | null cls = showCurryType_ tf nested texp | otherwise = showBracketsIf nested $ showBracketsIf (length cls > 1) (intercalate ", " (map (\ (cn,cv) -> cn ++ " " ++ showCurryType_ tf True cv) cls)) ++ " => " ++ showCurryType_ tf False texp --- Tests whether a FlatCurry type is a class context. --- If it is the case, return the class name and the type parameter --- of the context. isClassContext :: TypeExpr -> Maybe (String,TypeExpr) isClassContext texp = case texp of TCons (_,tc) [a] -> checkDictCons tc a -- a class context might be represented as function `() -> Dict`: FuncType (TCons unit []) (TCons (_,tc) [a]) | unit == ("Prelude","()") -> checkDictCons tc a _ -> Nothing where checkDictCons tc a | take 6 tc == "_Dict#" = Just (drop 6 tc, a) | otherwise = Nothing ------------------------------ showCurryType_ :: (QName -> String) -> Bool -> TypeExpr -> String showCurryType_ _ _ (TVar i) = if i<5 then [chr (97+i)] else 't':show i showCurryType_ tf nested (FuncType t1 t2) = showBracketsIf nested (showCurryType_ tf (isFuncType t1) t1 ++ " -> " ++ showCurryType_ tf False t2) showCurryType_ tf nested (TCons tc ts) | null ts = tf tc | tc==("Prelude","[]") && (head ts == TCons ("Prelude","Char") []) = "String" | tc==("Prelude","[]") = "[" ++ showCurryType_ tf False (head ts) ++ "]" -- list type | take 2 (snd tc) == "(," -- tuple type = "(" ++ intercalate "," (map (showCurryType_ tf False) ts) ++ ")" | otherwise = showBracketsIf nested (tf tc ++ concatMap (\t->' ':showCurryType_ tf True t) ts) showCurryType_ tf nested (ForallType tvs te) = showBracketsIf nested (unwords ("forall" : map (showCurryType_ tf False . TVar . fst) tvs) ++ " . " ++ showCurryType_ tf False te) isFuncType :: TypeExpr -> Bool isFuncType (TVar _) = False isFuncType (FuncType _ _) = True isFuncType (TCons _ _) = False isFuncType (ForallType _ te) = isFuncType te ------------------------------------------------------------------------------ --- Shows a FlatCurry expressions in (almost) Curry syntax. --- --- @param trans - a translation function from qualified functions names --- to external function names --- @param nested - True iff brackets must be written around complex terms --- @param indent - the indentation used in case expressions and if-then-else --- @param expr - the FlatCurry expression to be formatted --- @return the String representation of the formatted expression showCurryExpr :: (QName -> String) -> Bool -> Int -> Expr -> String showCurryExpr _ _ _ (Var n) = showCurryVar n showCurryExpr _ _ _ (Lit l) = showCurryLit l showCurryExpr tf _ _ (Comb _ cf []) = showCurryId (tf cf) showCurryExpr tf nested b (Comb _ cf [e]) = showBracketsIf nested (showCurryId (tf cf) ++ " " ++ showCurryExpr tf True b e) showCurryExpr tf nested b (Comb ct cf [e1,e2]) | cf==("Prelude","apply") = showBracketsIf nested (showCurryExpr tf True b e1 ++ " " ++ showCurryExpr tf True b e2) | isAlpha (head (snd cf)) = showBracketsIf nested (tf cf ++" "++ showCurryElems (showCurryExpr tf True b) [e1,e2]) | isFiniteList (Comb ct cf [e1,e2]) = if isStringConstant (Comb ct cf [e1,e2]) then "\"" ++ showCurryStringConstant (Comb ct cf [e1,e2]) ++ "\"" else "[" ++ intercalate "," (showCurryFiniteList tf b (Comb ct cf [e1,e2])) ++ "]" | snd cf == "(,)" -- pair constructor? = "(" ++ showCurryExpr tf False b e1 ++ "," ++ showCurryExpr tf False b e2 ++ ")" | otherwise = showBracketsIf nested (showCurryExpr tf True b e1 ++ " " ++ tf cf ++ " " ++ showCurryExpr tf True b e2 ) showCurryExpr tf nested b (Comb _ cf (e1:e2:e3:es)) | cf==("Prelude","if_then_else") && null es = showBracketsIf nested ("\n" ++ sceBlanks b ++ " if " ++ showCurryExpr tf False (b+2) e1 ++ "\n" ++ sceBlanks b ++ " then " ++ showCurryExpr tf False (b+2) e2 ++ "\n" ++ sceBlanks b ++ " else " ++ showCurryExpr tf False (b+2) e3) | take 2 (snd cf) == "(," -- tuple constructor? = "(" ++ intercalate "," (map (showCurryExpr tf False b) (e1:e2:e3:es)) ++ ")" | otherwise = showBracketsIf nested (showCurryId (tf cf) ++ " " ++ showCurryElems (showCurryExpr tf True b) (e1:e2:e3:es)) showCurryExpr tf nested b (Let bindings exp) = showBracketsIf nested ("\n" ++ sceBlanks b ++ "let " ++ intercalate ("\n " ++ sceBlanks b) (map (\ (x,e) -> showCurryVar x ++ " = " ++ showCurryExpr tf False (b+4) e) bindings) ++ ("\n" ++ sceBlanks b ++ " in ") ++ showCurryExpr tf False (b+4) exp) showCurryExpr tf nested b (Free [] e) = showCurryExpr tf nested b e showCurryExpr tf nested b (Free (x:xs) e) = showBracketsIf nested ("let " ++ intercalate "," (map showCurryVar (x:xs)) ++ " free in " ++ showCurryExpr tf False b e) showCurryExpr tf nested b (Or e1 e2) = showBracketsIf nested (showCurryExpr tf True b e1 ++ " ? " ++ showCurryExpr tf True b e2) showCurryExpr tf nested b (Case ctype e cs) = showBracketsIf nested ((case ctype of Rigid -> "case " Flex -> "fcase ") ++ showCurryExpr tf True b e ++ " of\n " ++ showCurryElems (showCurryCase tf (b+2)) cs ++ sceBlanks b) showCurryExpr tf nested b (Typed e ty) = showBracketsIf nested (showCurryExpr tf True b e ++ " :: " ++ showCurryType tf False ty) showCurryVar :: Show a => a -> String showCurryVar i = "v" ++ show i --- Shows an identifier in Curry form. Thus, operators are enclosed in brackets. showCurryId :: String -> String showCurryId name | isAlpha (head name) = name | name == "[]" = name | otherwise = ('(':name)++")" showCurryLit :: Literal -> String showCurryLit (Intc i) = show i showCurryLit (Floatc f) = show f showCurryLit (Charc c) = show c showCurryCase :: (QName -> String) -> Int -> BranchExpr -> String showCurryCase tf b (Branch (Pattern l vs) e) = sceBlanks b ++ showPattern (tf l) vs ++ " -> " ++ showCurryExpr tf False b e ++ "\n" where showPattern c [] = c showPattern c [x] = c ++ " " ++ showCurryVar x showPattern c [x1,x2] = if isAlpha (head c) then c ++ " " ++ showCurryVar x1 ++ " " ++ showCurryVar x2 else if c=="(,)" -- pair constructor? then "(" ++ showCurryVar x1 ++ "," ++ showCurryVar x2 ++ ")" else showCurryVar x1 ++ " " ++ c ++ " " ++ showCurryVar x2 showPattern c (x1:x2:x3:xs) = if take 2 c == "(," -- tuple constructor? then "(" ++ intercalate "," (map showCurryVar (x1:x2:x3:xs)) ++ ")" else c ++ " " ++ showCurryElems showCurryVar (x1:x2:x3:xs) showCurryCase tf b (Branch (LPattern l) e) = sceBlanks b ++ showCurryLit l ++ " " ++ " -> " ++ showCurryExpr tf False b e ++ "\n" showCurryFiniteList :: (QName -> String) -> Int -> Expr -> [String] showCurryFiniteList _ _ (Comb _ ("Prelude","[]") []) = [] showCurryFiniteList tf b (Comb _ ("Prelude",":") [e1,e2]) = showCurryExpr tf False b e1 : showCurryFiniteList tf b e2 -- show a string constant showCurryStringConstant :: Expr -> String showCurryStringConstant (Comb _ ("Prelude","[]") []) = [] showCurryStringConstant (Comb _ ("Prelude",":") [e1,e2]) = showCharExpr e1 ++ showCurryStringConstant e2 showCharExpr :: Expr -> String showCharExpr (Lit (Charc c)) | c=='"' = "\\\"" | c=='\'' = "\\\'" | c=='\n' = "\\n" | o < 32 || o > 126 = ['\\', chr (o `div` 100 + 48), chr (((o `mod` 100) `div` 10 + 48)), chr(o `mod` 10 + 48)] | otherwise = [c] where o = ord c showCurryElems :: (a -> String) -> [a] -> String showCurryElems format elems = intercalate " " (map format elems) showBracketsIf :: Bool -> String -> String showBracketsIf nested s = if nested then '(' : s ++ ")" else s sceBlanks :: Int -> String sceBlanks b = take b (repeat ' ') -- Is the expression a finite list (with an empty list at the end)? isFiniteList :: Expr -> Bool isFiniteList (Var _) = False isFiniteList (Lit _) = False isFiniteList (Comb _ name args) | name==("Prelude","[]") && null args = True | name==("Prelude",":") && length args == 2 = isFiniteList (args!!1) | otherwise = False isFiniteList (Let _ _) = False isFiniteList (Free _ _) = False isFiniteList (Or _ _) = False isFiniteList (Case _ _ _) = False isFiniteList (Typed e _) = isFiniteList e -- Is the expression a string constant? isStringConstant :: Expr -> Bool isStringConstant e = case e of Comb _ name args -> (name==("Prelude","[]") && null args) || (name==("Prelude",":") && length args == 2 && isCharConstant (head args) && isStringConstant (args!!1)) _ -> False -- Is the expression a character constant? isCharConstant :: Expr -> Bool isCharConstant e = case e of Lit (Charc _) -> True _ -> False ------------------------------------------------------------------------------ curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/src/FlatCurry/Types.curry000066400000000000000000000227561377556325500274250ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library supports meta-programming, i.e., the manipulation of --- Curry programs in Curry. For this purpose, the library contains --- definitions of data types for the representation of --- so-called FlatCurry programs. --- --- @author Michael Hanus --- @version July 2016 --- @category meta ------------------------------------------------------------------------------ module FlatCurry.Types where --- Data type for representing a Curry module in the intermediate form. --- A value of this data type has the form --- --- (Prog modname imports typedecls functions opdecls) --- --- where --- `modname` is the name of this module, --- `imports` is the list of modules names that are imported, and --- `typedecls`, `functions`, and `opdecls` are the list of --- data type, function, and operator declarations --- contained in this module, respectively. data Prog = Prog String [String] [TypeDecl] [FuncDecl] [OpDecl] deriving (Eq, Ord, Read, Show) --- The data type for representing qualified names. --- In FlatCurry all names are qualified to avoid name clashes. --- The first component is the module name and the second component the --- unqualified name as it occurs in the source program. type QName = (String, String) --- Data type to specify the visibility of various entities. data Visibility = Public -- public (exported) entity | Private -- private entity deriving (Eq, Ord, Read, Show) --- The data type for representing type variables. --- They are represented by `(TVar i)` where `i` is a type variable index. type TVarIndex = Int --- Kinded type variables are represented by a tuple of type variable --- index and kind. type TVarWithKind = (TVarIndex, Kind) --- Data type for representing definitions of algebraic data types --- and type synonyms. --- --- A data type definition of the form --- --- data t x1...xn = ...| c t1....tkc |... --- --- is represented by the FlatCurry term --- --- (Type t [i1,...,in] [...(Cons c kc [t1,...,tkc])...]) --- --- where each `ij` is the index of the type variable `xj`. --- --- Note: the type variable indices are unique inside each type declaration --- and are usually numbered from 0 --- --- Thus, a data type declaration consists of the name of the data type, --- a list of type parameters and a list of constructor declarations. data TypeDecl = Type QName Visibility [TVarWithKind] [ConsDecl] | TypeSyn QName Visibility [TVarWithKind] TypeExpr | TypeNew QName Visibility [TVarWithKind] NewConsDecl deriving (Eq, Ord, Read, Show) --- A constructor declaration consists of the name and arity of the --- constructor and a list of the argument types of the constructor. data ConsDecl = Cons QName Int Visibility [TypeExpr] deriving (Eq, Ord, Read, Show) --- A constructor declaration for a newtype consists --- of the name of the constructor --- and the argument type of the constructor. data NewConsDecl = NewCons QName Visibility TypeExpr deriving (Eq, Ord, Read, Show) --- Data type for type expressions. --- A type expression is either a type variable, a function type, --- or a type constructor application. --- --- Note: the names of the predefined type constructors are --- "Int", "Float", "Bool", "Char", "IO", --- "()" (unit type), "(,...,)" (tuple types), "[]" (list type) data TypeExpr = TVar TVarIndex -- type variable | FuncType TypeExpr TypeExpr -- function type t1->t2 | TCons QName [TypeExpr] -- type constructor application -- TCons module name typeargs | ForallType [TVarWithKind] TypeExpr -- forall type deriving (Eq, Ord, Read, Show) data Kind = KStar | KArrow Kind Kind deriving (Eq, Ord, Read, Show) --- Data type for operator declarations. --- An operator declaration `fix p n` in Curry corresponds to the --- FlatCurry term `(Op n fix p)`. data OpDecl = Op QName Fixity Int deriving (Eq, Ord, Read, Show) --- Data types for the different choices for the fixity of an operator. data Fixity = InfixOp | InfixlOp | InfixrOp deriving (Eq, Ord, Read, Show) --- Data type for representing object variables. --- Object variables occurring in expressions are represented by `(Var i)` --- where `i` is a variable index. type VarIndex = Int --- Arity of a function. type Arity = Int --- Data type for representing function declarations. --- --- A function declaration in FlatCurry is a term of the form --- --- (Func name k type (Rule [i1,...,ik] e)) --- --- and represents the function `name` with definition --- --- name :: type --- name x1...xk = e --- --- where each `ij` is the index of the variable `xj`. --- --- Note: the variable indices are unique inside each function declaration --- and are usually numbered from 0 --- --- External functions are represented as --- --- (Func name arity type (External s)) --- --- where s is the external name associated to this function. --- --- Thus, a function declaration consists of the name, arity, type, and rule. data FuncDecl = Func QName Arity Visibility TypeExpr Rule deriving (Eq, Ord, Read, Show) --- A rule is either a list of formal parameters together with an expression --- or an "External" tag. data Rule = Rule [VarIndex] Expr | External String deriving (Eq, Ord, Read, Show) --- Data type for classifying case expressions. --- Case expressions can be either flexible or rigid in Curry. data CaseType = Rigid | Flex -- type of a case expression deriving (Eq, Ord, Read, Show) --- Data type for classifying combinations --- (i.e., a function/constructor applied to some arguments). --- @cons FuncCall - a call to a function where all arguments are provided --- @cons ConsCall - a call with a constructor at the top, all arguments are provided --- @cons FuncPartCall - a partial call to a function (i.e., not all arguments --- are provided) where the parameter is the number of --- missing arguments --- @cons ConsPartCall - a partial call to a constructor (i.e., not all arguments --- are provided) where the parameter is the number of --- missing arguments data CombType = FuncCall | ConsCall | FuncPartCall Arity | ConsPartCall Arity deriving (Eq, Ord, Read, Show) --- Data type for representing expressions. --- --- Remarks: --- --- if-then-else expressions are represented as rigid case expressions: --- --- (if e1 then e2 else e3) --- --- is represented as --- --- (case e1 of { True -> e2; False -> e3}) --- --- Higher-order applications are represented as calls to the (external) --- function `apply`. For instance, the rule --- --- app f x = f x --- --- is represented as --- --- (Rule [0,1] (Comb FuncCall ("Prelude","apply") [Var 0, Var 1])) --- --- A conditional rule is represented as a call to an external function --- `cond` where the first argument is the condition (a constraint). --- For instance, the rule --- --- equal2 x | x=:=2 = True --- --- is represented as --- --- (Rule [0] --- (Comb FuncCall ("Prelude","cond") --- [Comb FuncCall ("Prelude","=:=") [Var 0, Lit (Intc 2)], --- Comb FuncCall ("Prelude","True") []])) --- --- @cons Var - variable (represented by unique index) --- @cons Lit - literal (Int/Float/Char constant) --- @cons Comb - application `(f e1 ... en)` of function/constructor `f` --- with `n`<=arity(`f`) --- @cons Let - introduction of local variables via (recursive) let declarations --- @cons Free - introduction of free local variables --- @cons Or - disjunction of two expressions (used to translate rules --- with overlapping left-hand sides) --- @cons Case - case distinction (rigid or flex) --- @cons Typed - typed expression to represent an expression with a --- type declaration data Expr = Var VarIndex | Lit Literal | Comb CombType QName [Expr] | Let [(VarIndex, Expr)] Expr | Free [VarIndex] Expr | Or Expr Expr | Case CaseType Expr [BranchExpr] | Typed Expr TypeExpr deriving (Eq, Ord, Read, Show) --- Data type for representing branches in a case expression. --- --- Branches "(m.c x1...xn) -> e" in case expressions are represented as --- --- (Branch (Pattern (m,c) [i1,...,in]) e) --- --- where each `ij` is the index of the pattern variable `xj`, or as --- --- (Branch (LPattern (Intc i)) e) --- --- for integers as branch patterns (similarly for other literals --- like float or character constants). data BranchExpr = Branch Pattern Expr deriving (Eq, Ord, Read, Show) --- Data type for representing patterns in case expressions. data Pattern = Pattern QName [VarIndex] | LPattern Literal deriving (Eq, Ord, Read, Show) --- Data type for representing literals occurring in an expression --- or case branch. It is either an integer, a float, or a character constant. data Literal = Intc Int | Floatc Float | Charc Char deriving (Eq, Ord, Read, Show) ----------------------------------------------------------------------- --- Shows a qualified type name as a name relative to a module --- (first argument). Thus, names not defined in this module (except for names --- defined in the prelude) are prefixed with their module name. showQNameInModule :: String -> QName -> String showQNameInModule mod qn@(qmod, name) | qmod == mod || qmod == "Prelude" = name | otherwise = showQName qn --- Shows a qualified name. showQName :: QName -> String showQName (qmod, name) = qmod ++ '.' : name ----------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/src/FlatCurry/XML.curry000066400000000000000000000111111377556325500267400ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library contains functions to convert FlatCurry programs --- into corresponding XML expressions and vice versa. --- This can be used to store Curry programs in a way independent --- of a Curry system or to use a Curry system, like PAKCS, --- as back end by other functional logic programming systems. --- --- @author Sebastian Fischer --- @version October 2015 ------------------------------------------------------------------------------ {-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-missing-signatures #-} module FlatCurry.XML ( flatCurry2XmlFile, flatCurry2Xml, xmlFile2FlatCurry, xml2FlatCurry ) where import FlatCurry.Types import XML import XmlConv -- URL for the FlatCurry DTD: flatCurryDtd = "http://www.informatik.uni-kiel.de/~curry/flatcurrynew.dtd" --- Transforms a FlatCurry program term into a corresponding XML file. flatCurry2XmlFile :: Prog -> String -> IO () flatCurry2XmlFile flatprog filename = writeFile filename $ showXmlDocWithParams [DtdUrl flatCurryDtd] (flatCurry2Xml flatprog) --- Transforms a FlatCurry program term into a corresponding XML expression. flatCurry2Xml :: Prog -> XmlExp flatCurry2Xml = xmlShow cProg --- Reads an XML file with a FlatCurry program and returns --- the FlatCurry program. xmlFile2FlatCurry :: String -> IO Prog xmlFile2FlatCurry filename = readXmlFile filename >>= return . xml2FlatCurry --- Transforms an XML term into a FlatCurry program. xml2FlatCurry :: XmlExp -> Prog xml2FlatCurry = xmlRead cProg -- FlatCurry XML converter specification: cProg = eSeq5 "prog" Prog cModname cImports cTypes cFuncs cOps cModname = eString "module" cImports = eRep "import" (eString "module") cTypes = eRep "types" cType cType = eSeq4 "type" Type cQName cVis cTParams (rep cConsDecl) ! eSeq4 "typesyn" TypeSyn cQName cVis cTParams cTypeExpr ! eSeq4 "typenew" TypeNew cQName cVis cTParams cNewConsDecl cQName = seq2 (\a b -> (a,b)) (aString "module") (aString "name") cVis = adapt (b2v,v2b) (aBool "visibility" "public" "private") b2v b = if b then Public else Private v2b v = v==Public cTParams = eRep "params" cTVarWithKind cConsDecl = eSeq4 "cons" Cons cQName cArity cVis (rep cTypeExpr) cNewConsDecl = eSeq3 "newcons" NewCons cQName cVis cTypeExpr cArity = aInt "arity" cTypeExpr = eSeq2 "functype" FuncType cTypeExpr cTypeExpr ! eSeq2 "tcons" TCons cQName (rep cTypeExpr) ! eSeq1 "tvar" TVar int ! eSeq2 "forall" ForallType cTParams cTypeExpr cTVarWithKind = eSeq2 "tvarwithkind" (,) int cKind cKind = eEmpty "kstar" KStar ! eSeq2 "karrow" KArrow cKind cKind cFuncs = eRep "functions" cFunc cFunc = eSeq5 "func" Func cQName cArity cVis cTypeExpr cRule cRule = eSeq2 "rule" Rule cLHS cRHS ! eSeq1 "external" External string cLHS = element "lhs" cVars cRHS = element "rhs" cExpr cVars = rep cVar cVar = eInt "var" cExpr = eSeq1 "var" Var int ! eSeq1 "lit" Lit cLit ! eSeq2 "funccall" fc cQName cExps ! eSeq2 "conscall" cc cQName cExps ! eSeq3 "funcpartcall" pfc cQName cMissing cExps ! eSeq3 "conspartcall" pcc cQName cMissing cExps ! eSeq2 "free" Free (element "freevars" cVars) cExpr ! eSeq2 "or" Or cExpr cExpr ! eSeq2 "case" cr cExpr (rep cBranch) ! eSeq2 "fcase" cf cExpr (rep cBranch) ! eSeq2 "letrec" Let (rep cBind) cExpr ! eSeq2 "typed" Typed cExpr cTypeExpr cLit = eSeq1 "intc" Intc int ! eSeq1 "floatc" Floatc float ! eSeq1 "charc" Charc (adapt (chr,ord) int) fc = Comb FuncCall cc = Comb ConsCall pfc n m = Comb (FuncPartCall m) n pcc n m = Comb (ConsPartCall m) n cExps = rep cExpr cMissing = aInt "missing" cr = Case Rigid cf = Case Flex cBranch = eSeq2 "branch" Branch cPat cExpr cPat = eSeq2 "pattern" Pattern cQName cVars ! eSeq1 "lpattern" LPattern cLit cBind = eSeq2 "binding" (\a b -> (a,b)) cVar cExpr cOps = eRep "operators" cOp cOp = eSeq3 "op" Op cQName cFixity (aInt "prec") cFixity = adapt (rf,show) (aString "fixity") rf "InfixOp" = InfixOp rf "InfixlOp" = InfixlOp rf "InfixrOp" = InfixrOp curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/test/000077500000000000000000000000001377556325500234745ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/test/TestFlatCurryGoodies.curry000066400000000000000000000024751377556325500306570ustar00rootroot00000000000000--- Some tests for library FlatCurry.Goodies. --- --- To run all tests automatically by the currycheck tool, use the command: --- `curry-check TestFlatCurryGoodies` --- --- @author Sebastian Fischer import FlatCurry.Types import FlatCurry.Files import FlatCurry.Goodies import Test.Prop testIdentityTransformation = identity `returns` True identity = do prog <- readFlatCurry "TestFlatCurryGoodies" return (prog == idProg prog) idProg = trProg prog where prog name imps types funcs ops = Prog name imps (map idType types) (map idFunc funcs) (map idOp ops) idType = trType typ typesyn typenew where typ name vis params cs = Type name vis params (map idCons cs) typesyn name vis params syn = TypeSyn name vis params (idTypeExpr syn) typenew name vis params ncd = TypeNew name vis params (idNewCons ncd) idCons = trCons cons where cons name arity vis args = Cons name arity vis (map idTypeExpr args) idNewCons = trNewCons cons where cons name vis te = NewCons name vis (idTypeExpr te) idTypeExpr = trTypeExpr TVar TCons FuncType ForallType idFunc = trFunc func where func name arity vis t rule = Func name arity vis (idTypeExpr t) (idRule rule) idRule = trRule rule External where rule args exp = Rule args (idExpr exp) idExpr = trExpr Var Lit Comb Let Free Or Case Branch Typed idOp = trOp Op curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/test/TestFlatCurryXML.curry000066400000000000000000000015641377556325500277240ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some tests for library `FlatCurry.XML`. --- --- @author Michael Hanus ------------------------------------------------------------------------------ import FlatCurry.Types import FlatCurry.Files import FlatCurry.XML import XML import Test.Prop -- Shows a program in XML format: showxml mod = do prog <- readFlatCurry mod putStrLn $ showXmlDoc (flatCurry2Xml prog) -- Store a program in XML format: store mod = do prog <- readFlatCurry mod flatCurry2XmlFile prog (mod++"_fcy.xml") putStrLn (mod++"_fcy.xml"++" written") -- Test for equality after XML encoding/decoding: testEqualFcy prog = prog == xml2FlatCurry (flatCurry2Xml prog) readAndTestEqualFcy mod = do prog <- readFlatCurry mod return $ testEqualFcy prog testXML_test_for_rev = (readAndTestEqualFcy "rev") `returns` True curry-tools-v3.3.0/optimize/.cpm/packages/flatcurry/test/rev.curry000066400000000000000000000005341377556325500253600ustar00rootroot00000000000000-- Concatenating two lists: -- (predefined as `++' in the standard prelude) append :: [t] -> [t] -> [t] append [] x = x append (x:xs) ys = x : append xs ys -- Reverse the order of elements in a list: rev :: [t] -> [t] rev [] = [] rev (x:xs) = append (rev xs) [x] goal1 = append [1,2] [3,4] goal2 = rev [1,2,3,4] -- end of program curry-tools-v3.3.0/optimize/.cpm/packages/frontend-exec/000077500000000000000000000000001377556325500232435ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/frontend-exec/LICENSE000066400000000000000000000027351377556325500242570ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/frontend-exec/README.md000066400000000000000000000004251377556325500245230ustar00rootroot00000000000000frontend-exec ============= This package provides the library `System.FrontendExec` containing operations to invoke the front end of the Curry system to compile a given Curry program into various output formats (e.g., AbstractCurry, FlatCurry, AST with position information). curry-tools-v3.3.0/optimize/.cpm/packages/frontend-exec/package.json000066400000000000000000000015041377556325500255310ustar00rootroot00000000000000{ "name": "frontend-exec", "version": "3.3.0", "author": "Michael Hanus ", "synopsis": "Operations to execute the front end of the Curry system", "category": [ "System" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "currypath" : ">= 3.0.0, < 4.0.0", "filepath" : ">= 3.0.0, < 4.0.0", "process" : ">= 3.0.0, < 4.0.0", "propertyfile" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.3.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.FrontendExec" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/frontend-exec.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/frontend-exec/src/000077500000000000000000000000001377556325500240325ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/frontend-exec/src/System/000077500000000000000000000000001377556325500253165ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/frontend-exec/src/System/FrontendExec.curry000066400000000000000000000235601377556325500307760ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This module contains operations to execute the front end of the --- Curry system. --- --- @author Bernd Brassel, Michael Hanus, Bjoern Peemoeller, Finn Teegen --- @version December 2020 ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} module System.FrontendExec (FrontendTarget(..) , FrontendParams(..), defaultParams, rcParams , setQuiet, setExtended, setCpp, addDefinition, setDefinitions , setOverlapWarn, setFullPath, setHtmlDir, setLogfile, addTarget, setSpecials , setFrontendPath , callFrontend, callFrontendWithParams ) where import Curry.Compiler.Distribution ( curryCompiler, curryCompilerMajorVersion , curryCompilerMinorVersion, installDir ) import Data.Char ( toUpper ) import Data.List ( intercalate, nub ) import Data.PropertyFile ( getPropertiesFromFile ) import System.FilePath ( FilePath, (), takeDirectory, takeFileName ) import System.Process ( system ) import System.CurryPath ( curryrcFileName, currySubdir, getLoadPathForModule ) ------------------------------------------------------------------- -- calling the front end ------------------------------------------------------------------- --- Data type for representing the different target files that can be produced --- by the front end of the Curry compiler. --- @cons FCY - FlatCurry file ending with .fcy --- @cons TFCY - Typed FlatCurry file ending with .tfcy --- @cons TAFCY - Type Annotated FlatCurry file ending with .tafcy --- @cons FINT - FlatCurry interface file ending with .fint --- @cons ACY - AbstractCurry file ending with .acy --- @cons UACY - Untyped (without type checking) AbstractCurry file ending with .uacy --- @cons HTML - colored HTML representation of source program --- @cons CY - source representation employed by the frontend --- @cons TOKS - token stream of source program --- @cons AST - abstract syntax tree ending with .sast --- @cons SAST - shortened abstract syntax tree ending with .sast --- @cons COMMS - comments stream ending with .cycom data FrontendTarget = FCY | TFCY | FINT | ACY | UACY | HTML | CY | TOKS | TAFCY | AST | SAST | COMMS deriving (Eq, Show) --- Abstract data type for representing parameters supported by the front end --- of the Curry compiler. -- The parameters are of the form -- FrontendParams Quiet Extended Cpp NoOverlapWarn FullPath HtmlDir LogFile Specials FrontendPath data FrontendParams = FrontendParams { quiet :: Bool -- work silently , extended :: Bool -- support extended Curry syntax , cpp :: Bool -- enable conditional compiling , definitions :: [(String, Int)] -- definitions for conditional compiling , overlapWarn :: Bool -- warn for overlapping rules , fullPath :: Maybe [String] -- the complete list of directory names for loading modules , htmldir :: Maybe String -- output directory (only relevant for HTML target) , logfile :: Maybe String -- store all output (including errors) of the front end in file , targets :: [FrontendTarget] -- additional targets for the front end , specials :: String -- additional special parameters (use with care!) , frontendPath :: String -- the path to the frontend executable } --- The default parameters of the front end. defaultParams :: FrontendParams defaultParams = FrontendParams { quiet = False , extended = True , cpp = False , definitions = defaultDefs , overlapWarn = True , fullPath = Nothing , htmldir = Nothing , logfile = Nothing , targets = [] , specials = "" , frontendPath = installDir "bin" curryCompiler ++ "-frontend" } where defaultDefs = [("__" ++ map toUpper curryCompiler ++ "__", curryCompilerMajorVersion * 100 + curryCompilerMinorVersion)] --- The default parameters of the front end as configured by the compiler --- specific resource configuration file. rcParams :: IO FrontendParams rcParams = do rcfile <- curryrcFileName [mbExtended,mbOverlapWarn] <- getPropertiesFromFile rcfile ["curryextensions","warnoverlapping"] return $ setExtended (mbExtended /= Just "no") $ setOverlapWarn (mbOverlapWarn /= Just "no") $ defaultParams --- Set quiet mode of the front end. setQuiet :: Bool -> FrontendParams -> FrontendParams setQuiet s ps = ps { quiet = s } --- Set extended mode of the front end. setExtended :: Bool -> FrontendParams -> FrontendParams setExtended s ps = ps { extended = s } --- Set cpp mode of the front end. setCpp :: Bool -> FrontendParams -> FrontendParams setCpp s ps = ps { cpp = s } --- Add cpp definition of the front end. addDefinition :: (String, Int) -> FrontendParams -> FrontendParams addDefinition d ps = ps { definitions = definitions ps ++ [d] } --- Set cpp definitions of the front end. setDefinitions :: [(String, Int)] -> FrontendParams -> FrontendParams setDefinitions s ps = ps { definitions = s } --- Set overlap warn mode of the front end. setOverlapWarn :: Bool -> FrontendParams -> FrontendParams setOverlapWarn s ps = ps { overlapWarn = s } --- Set the full path of the front end. --- If this parameter is set, the front end searches all modules --- in this path (instead of using the default path). setFullPath :: [String] -> FrontendParams -> FrontendParams setFullPath s ps = ps { fullPath = Just s } --- Set the htmldir parameter of the front end. --- Relevant for HTML generation. setHtmlDir :: String -> FrontendParams -> FrontendParams setHtmlDir s ps = ps { htmldir = Just s } --- Set the logfile parameter of the front end. --- If this parameter is set, all messages produced by the front end --- are stored in this file. setLogfile :: String -> FrontendParams -> FrontendParams setLogfile s ps = ps { logfile = Just s } --- Set additional specials parameters of the front end. --- These parameters are specific for the current front end and --- should be used with care, since their form might change in the future. setSpecials :: String -> FrontendParams -> FrontendParams setSpecials s ps = ps { specials = s } --- Add an additional front end target. addTarget :: FrontendTarget -> FrontendParams -> FrontendParams addTarget t ps = ps { targets = t : targets ps } --- Sets the path to the frontend executable. setFrontendPath :: String -> FrontendParams -> FrontendParams setFrontendPath s ps = ps { frontendPath = s } --- In order to make sure that compiler generated files (like .fcy, .fint, .acy) --- are up to date, one can call the front end of the Curry compiler --- with this action. --- If the front end returns with an error, an exception is raised. --- @param target - the kind of target file to be generated --- @param progname - the name of the main module of the application to be compiled callFrontend :: FrontendTarget -> String -> IO () callFrontend target p = do params <- rcParams callFrontendWithParams target params p --- In order to make sure that compiler generated files (like .fcy, .fint, .acy) --- are up to date, one can call the front end of the Curry compiler --- with this action where various parameters can be set. --- If the front end returns with an error, an exception is raised. --- @param target - the kind of target file to be generated --- @param params - parameters for the front end --- @param modpath - the name of the main module possibly prefixed with a --- directory where this module resides callFrontendWithParams :: FrontendTarget -> FrontendParams -> String -> IO () callFrontendWithParams target params modpath = do parsecurry <- callParseCurry let lf = maybe "" id (logfile params) tgts = nub (target : targets params) syscall = unwords $ [parsecurry] ++ map showFrontendTarget tgts ++ [showFrontendParams, cppParams, takeFileName modpath] retcode <- if null lf then system syscall else system (syscall ++ " > " ++ lf ++ " 2>&1") if retcode == 0 then return () else ioError (userError "Illegal source program") where callParseCurry = do path <- maybe (getLoadPathForModule modpath) (\p -> return (nub (takeDirectory modpath : p))) (fullPath params) return (quote (frontendPath params) ++ concatMap ((" -i" ++) . quote) path) quote s = '"' : s ++ "\"" showFrontendTarget FCY = "--flat" showFrontendTarget TFCY = "--typed-flat" showFrontendTarget TAFCY = "--type-annotated-flat --flat" -- due to f.e.bug showFrontendTarget FINT = "--flat" showFrontendTarget ACY = "--acy" showFrontendTarget UACY = "--uacy" showFrontendTarget HTML = "--html" showFrontendTarget CY = "--parse-only" showFrontendTarget TOKS = "--tokens" showFrontendTarget AST = "--ast" showFrontendTarget SAST = "--short-ast" showFrontendTarget COMMS = "--comments" showFrontendParams = unwords [ "-o ", currySubdir , if quiet params then runQuiet else "" , if extended params then "--extended" else "" , if cpp params then "--cpp" else "" , if overlapWarn params then "" else "--no-overlap-warn" , maybe "" ("--htmldir="++) (htmldir params) , specials params #ifdef __PAKCS__ , if target `elem` [FCY,TFCY,TAFCY,FINT] then "-Odesugar-newtypes" -- remove when newtypes added to FlatCurry else "" #endif ] runQuiet = "--no-verb --no-warn --no-overlap-warn" cppParams = intercalate " " $ map showDefinition (definitions params) showDefinition (s, v) = "-D" ++ s ++ "=" ++ show v ------------------------------------------------------------------------------ curry-tools-v3.3.0/optimize/.cpm/packages/global/000077500000000000000000000000001377556325500217425ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/global/LICENSE000066400000000000000000000027351377556325500227560ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/global/README.md000066400000000000000000000015061377556325500232230ustar00rootroot00000000000000global: Handling global entities in programs ============================================ This package contains a library to handle global entities. A global entity has a name declared in the program. Its value can be accessed and modified by IO actions. Furthermore, global entities can be declared as persistent so that their values are stored across different program executions. Currently, it is still experimental so that its interface might be slightly changed in the future. A global entity `g` with an initial value `v` of type `t` must be declared by: g :: Global t g = global v spec Here, the type `t` must not contain type variables and `spec` specifies the storage mechanism for the global entity (see type `GlobalSpec` in the library). -------------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/global/package.json000066400000000000000000000013131377556325500242260ustar00rootroot00000000000000{ "name": "global", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library for handling global entities in programs", "category": [ "Programming" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "process" : ">= 3.0.0, < 4.0.0" }, "testsuite": { "src-dir": "test", "modules": [ "TestGlobal" ] }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/global.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/global/src/000077500000000000000000000000001377556325500225315ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/global/src/Global.curry000066400000000000000000000053011377556325500250160ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for handling global entities. --- A global entity has a name declared in the program. --- Its value can be accessed and modified by IO actions. --- Furthermore, global entities can be declared as persistent so that --- their values are stored across different program executions. --- --- Currently, it is still experimental so that its interface might --- be slightly changed in the future. --- --- A global entity `g` with an initial value `v` --- of type `t` must be declared by: --- --- g :: Global t --- g = global v spec --- --- Here, the type `t` must not contain type variables and --- `spec` specifies the storage mechanism for the --- global entity (see type `GlobalSpec`). --- --- --- @author Michael Hanus --- @version February 2017 --- @category general ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} module Global ( Global, GlobalSpec(..), global , readGlobal, safeReadGlobal, writeGlobal) where ---------------------------------------------------------------------- --- The abstract type of a global entity. #ifdef __PAKCS__ data Global a = GlobalDef a GlobalSpec #else external data Global _ #endif --- `global` is only used for the declaration of a global value --- and should not be used elsewhere. In the future, it might become a keyword. global :: a -> GlobalSpec -> Global a #ifdef __PAKCS__ global v s = GlobalDef v s #else global external #endif --- The storage mechanism for the global entity. --- @cons Temporary - the global value exists only during a single execution --- of a program --- @cons Persistent f - the global value is stored persisently in file f --- (which is created and initialized if it does not exists) data GlobalSpec = Temporary | Persistent String --- Reads the current value of a global. readGlobal :: Global a -> IO a readGlobal g = prim_readGlobal $# g prim_readGlobal :: Global a -> IO a prim_readGlobal external --- Safely reads the current value of a global. --- If `readGlobal` fails (e.g., due to a corrupted persistent storage), --- the global is re-initialized with the default value given as --- the second argument. safeReadGlobal :: Global a -> a -> IO a safeReadGlobal g dflt = catch (readGlobal g) (\_ -> writeGlobal g dflt >> return dflt) --- Updates the value of a global. --- The value is evaluated to a ground constructor term before it is updated. writeGlobal :: Global a -> a -> IO () writeGlobal g v = (prim_writeGlobal $# g) $## v prim_writeGlobal :: Global a -> a -> IO () prim_writeGlobal external ------------------------------------------------------------------------ curry-tools-v3.3.0/optimize/.cpm/packages/global/src/Global.kics2000066400000000000000000000147001377556325500246700ustar00rootroot00000000000000import CurryException import Control.Exception as C import Data.IORef import System.IO import System.Directory (doesFileExist) import System.IO.Unsafe import System.Process (system) -- Implementation of Globals in Curry. We use Haskell's IORefs for temporary -- globals where Curry values are stored in the IORefs data C_Global a = Choice_C_Global Cover ID (C_Global a) (C_Global a) | Choices_C_Global Cover ID ([C_Global a]) | Fail_C_Global Cover FailInfo | Guard_C_Global Cover Constraints (C_Global a) | C_Global_Temp (IORef a) -- a temporary global | C_Global_Pers String -- a persistent global with a given (file) name instance Show (C_Global a) where show = error "ERROR: no show for Global" instance Read (C_Global a) where readsPrec = error "ERROR: no read for Global" instance NonDet (C_Global a) where choiceCons = Choice_C_Global choicesCons = Choices_C_Global failCons = Fail_C_Global guardCons = Guard_C_Global try (Choice_C_Global cd i x y) = tryChoice cd i x y try (Choices_C_Global cd i xs) = tryChoices cd i xs try (Fail_C_Global cd info) = Fail cd info try (Guard_C_Global cd c e) = Guard cd c e try x = Val x match choiceF _ _ _ _ _ (Choice_C_Global cd i x y) = choiceF cd i x y match _ narrF _ _ _ _ (Choices_C_Global cd i@(NarrowedID _ _) xs) = narrF cd i xs match _ _ freeF _ _ _ (Choices_C_Global cd i@(FreeID _ _) xs) = freeF cd i xs match _ _ _ failF _ _ (Fail_C_Global cd info) = failF cd info match _ _ _ _ guardF _ (Guard_C_Global cd c e) = guardF cd c e match _ _ _ _ _ valF x = valF x instance Generable (C_Global a) where generate _ _ = error "ERROR: no generator for Global" instance NormalForm (C_Global a) where ($!!) cont g@(C_Global_Temp _) cd cs = cont g cd cs ($!!) cont g@(C_Global_Pers _) cd cs = cont g cd cs ($!!) cont (Choice_C_Global d i g1 g2) cd cs = nfChoice cont d i g1 g2 cd cs ($!!) cont (Choices_C_Global d i gs) cd cs = nfChoices cont d i gs cd cs ($!!) cont (Guard_C_Global d c g) cd cs = guardCons d c ((cont $!! g) cd $! (addCs c cs)) ($!!) _ (Fail_C_Global d info) _ _ = failCons d info ($##) cont g@(C_Global_Temp _) cd cs = cont g cd cs ($##) cont g@(C_Global_Pers _) cd cs = cont g cd cs ($##) cont (Choice_C_Global d i g1 g2) cd cs = gnfChoice cont d i g1 g2 cd cs ($##) cont (Choices_C_Global d i gs) cd cs = gnfChoices cont d i gs cd cs ($##) cont (Guard_C_Global d c g) cd cs = guardCons d c ((cont $## g) cd $! (addCs c cs)) ($##) _ (Fail_C_Global cd info) _ _ = failCons cd info searchNF _ cont g@(C_Global_Temp _) = cont g searchNF _ cont g@(C_Global_Pers _) = cont g instance Unifiable (C_Global a) where (=.=) (C_Global_Temp ref1) (C_Global_Temp ref2) _ _ | ref1 == ref2 = C_True (=.=) (C_Global_Pers f1) (C_Global_Pers f2) _ _ | f1 == f2 = C_True (=.=) _ _ cd _ = Fail_C_Bool cd defFailInfo (=.<=) = (=.=) bind cd i (Choice_C_Global d j l r) = [(ConstraintChoice d j (bind cd i l) (bind cd i r))] bind cd i (Choices_C_Global d j@(FreeID _ _) xs) = bindOrNarrow cd i d j xs bind cd i (Choices_C_Global d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (bind cd i) xs))] bind _ _ (Fail_C_Global _ info) = [Unsolvable info] bind cd i (Guard_C_Global _ cs e) = (getConstrList cs) ++ (bind cd i e) lazyBind cd i (Choice_C_Global d j l r) = [(ConstraintChoice d j (lazyBind cd i l) (lazyBind cd i r))] lazyBind cd i (Choices_C_Global d j@(FreeID _ _) xs) = lazyBindOrNarrow cd i d j xs lazyBind cd i (Choices_C_Global d j@(NarrowedID _ _) xs) = [(ConstraintChoices d j (map (lazyBind cd i) xs))] lazyBind _ _ (Fail_C_Global cd info) = [Unsolvable info] lazyBind cd i (Guard_C_Global _ cs e) = (getConstrList cs) ++ [(i :=: (LazyBind (lazyBind cd i e)))] instance Curry_Prelude.Curry a => Curry_Prelude.Curry (C_Global a) external_d_C_global :: Curry_Prelude.Curry a => a -> C_GlobalSpec -> Cover -> ConstStore -> C_Global a external_d_C_global val C_Temporary _ _ = ref `seq` (C_Global_Temp ref) where ref = unsafePerformIO (newIORef val) external_d_C_global val (C_Persistent cname) _ _ = let name = fromCurry cname :: String in unsafePerformIO (initGlobalFile name >> return (C_Global_Pers name)) where initGlobalFile name = do ex <- doesFileExist name if ex then return () else do writeFile name (show val ++ "\n") system ("chmod 600 " ++ name) return () external_d_C_prim_readGlobal :: Curry_Prelude.Curry a => C_Global a -> Cover -> ConstStore -> Curry_Prelude.C_IO a external_d_C_prim_readGlobal (C_Global_Temp ref) _ _ = fromIO (readIORef ref) external_d_C_prim_readGlobal (C_Global_Pers name) _ _ = fromIO $ exclusiveOnFile name $ do s <- catch (do h <- openFile name ReadMode eof <- hIsEOF h s <- if eof then return "" else hGetLine h hClose h return s) (\e -> throw (IOException (show (e :: C.IOException)))) case reads s of [(val,"")] -> return val _ -> throw (IOException $ "Persistent file `" ++ name ++ "' contains malformed contents:\n" ++ s) external_d_C_prim_writeGlobal :: Curry_Prelude.Curry a => C_Global a -> a -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_writeGlobal (C_Global_Temp ref) val _ _ = toCurry (writeIORef ref val) external_d_C_prim_writeGlobal (C_Global_Pers name) val _ _ = toCurry (exclusiveOnFile name $ writeFile name (show val ++ "\n")) --- Forces the exclusive execution of an action via a lock file. exclusiveOnFile :: String -> IO a -> IO a exclusiveOnFile file action = do exlock <- doesFileExist lockfile if exlock then hPutStrLn stderr (">>> Waiting for removing lock file `" ++ lockfile ++ "'...") else return () system ("lockfile-create --lock-name "++lockfile) C.catch (do actionResult <- action deleteLockFile return actionResult ) (\e -> deleteLockFile >> C.throw (e :: CurryException)) where lockfile = file ++ ".LOCK" deleteLockFile = system $ "lockfile-remove --lock-name " ++ lockfile curry-tools-v3.3.0/optimize/.cpm/packages/global/src/Global.pakcs.pl000066400000000000000000000074061377556325500253750ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module Global: % % initialize the predicate containing the global value if called for the % first time: initGlobalValue(GlobName,'Global.Temporary',Exp,Val) :- evalToken(Eval), user:nf(Exp,Val,Eval,E1), user:waitUntilGround(Val,E1,_), % groundness required GlobalHead =.. [GlobName,_], user:retractClause(GlobalHead,_), NewGlobalCall =.. [GlobName,Val], % temporary globals directly contain its value: assertz(user:NewGlobalCall), !. initGlobalValue(GlobName,'Global.Persistent'(FExp),Exp,FileName) :- evalToken(Eval), user:nf(FExp,FileString,Eval,E0), user:waitUntilGround(FileString,E0,E1), % groundness required string2Atom(FileString,FileName), user:nf(Exp,Val,E1,E2), user:waitUntilGround(Val,E2,_), % groundness required GlobalHead =.. [GlobName,_], user:retractClause(GlobalHead,_), NewGlobalCall =.. [GlobName,FileName], % persistent globals contain the file name where its value is stored: assertz(user:NewGlobalCall), (existsFile(FileName) -> true ; writeGlobalFile(FileName,Val)), !. % read a global value: 'Global.prim_readGlobal'('Global.GlobalDef'(GlobName,'Global.Temporary'),Val) :- GlobalCall =.. [GlobName,Val], call(user:GlobalCall), !. 'Global.prim_readGlobal'('Global.GlobalDef'(GlobName,'Global.Persistent'), Val) :- GlobalCall =.. [GlobName,FileName], call(user:GlobalCall), readGlobalFile(FileName,Val), !. % update a global value: 'Global.prim_writeGlobal'('Global.GlobalDef'(GlobName,'Global.Temporary'), NewVal,'Prelude.()') :- GlobalCall =.. [GlobName,_], (retract(user:GlobalCall) ; user:retractClause(GlobalCall,_)), NewGlobalCall =.. [GlobName,NewVal], assertz(user:NewGlobalCall), !. 'Global.prim_writeGlobal'('Global.GlobalDef'(GlobName,'Global.Persistent'), NewVal,'Prelude.()') :- GlobalCall =.. [GlobName,FileName], call(user:GlobalCall), writeGlobalFile(FileName,NewVal), !. % read the file with the persistent global value: readGlobalFile(FileName,Val) :- lockFileName(FileName,LockFile), lockWithFile(LockFile), on_exception(ErrorMsg, (open(FileName,read,Stream), readStreamLine(Stream,ValString), close(Stream)), ValString=[]), unlockWithFile(LockFile), readShowTerm:readTerm(ValString,qualified,_Rest,Val). % write the file with the persistent global value: writeGlobalFile(FileName,Val) :- lockFileName(FileName,LockFile), lockWithFile(LockFile), (existsFile(FileName) -> appendAtom(FileName,'.bak',BakFileName), renameFile(FileName,BakFileName) ; true), open(FileName,write,Stream), readShowTerm:show_term(Val,qualified,ValString,[]), writeChars(Stream,ValString), put_code(Stream,10), % the additional characters are necessary due to a bug in % SWI-Prolog when reading short files: put_code(Stream,10), put_code(Stream,10), put_code(Stream,10), close(Stream), % make files for storing globals only accessible for the user: appendAtom('chmod 600 ',FileName,ChmodCmd), % ignore errors (might occur in Windows emulators) since not relevant: on_exception(_,shellCmd(ChmodCmd,_),true), unlockWithFile(LockFile). % lockfile for safe file reading/writing: lockFileName(FName,LockFile) :- appendAtom(FName,'.LOCK',LockFile). lockWithFile(LockFile) :- appendAtom('lockfile-create --lock-name ',LockFile,LockCmd), ((existsFile(LockFile), pakcsrc(dynamicmessages,yes)) -> writeErr('>>> Waiting for removing lock file \''), writeErr(LockFile), writeErr('\'...'), nlErr ; true), shellCmd(LockCmd), !. unlockWithFile(LockFile) :- appendAtom('lockfile-remove --lock-name ',LockFile,LockCmd), shellCmd(LockCmd). curry-tools-v3.3.0/optimize/.cpm/packages/global/test/000077500000000000000000000000001377556325500227215ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/global/test/TestGlobal.curry000066400000000000000000000044151377556325500260530ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some tests for library Global --- --- To run all tests automatically by the currycheck tool, use the command: --- "curry-check TestGlobal" --- --- @author Michael Hanus ------------------------------------------------------------------------------ import Global import System.Process ( system ) import Test.Prop ------------------------------------------------------------------------------ -- Testing a simple integer temporary global entity: points :: Global Int points = global (div 1 1) Temporary rwglobal :: IO (Int,Int) rwglobal = do v1 <- readGlobal points writeGlobal points 42 v2 <- readGlobal points return (v1,v2) testSimpleIntReadGlobalWriteGlobal = rwglobal `returns` (1,42) ------------------------------------------------------------------------------ -- Testing a temporary global entity containing a list structure: nats :: Global [Int] nats = global [] Temporary listrwglobal :: IO ([Int],[Int]) listrwglobal = do writeGlobal nats [1..5] v1 <- readGlobal nats writeGlobal nats (v1++v1) v2 <- readGlobal nats return (v1,v2) testSimpleIntlistReadGlobalWriteGlobal = listrwglobal `returns` ([1..5],[1..5]++[1..5]) ------------------------------------------------------------------------------ -- Testing the interaction of two integer temporary global entities: gint1 :: Global Int gint1 = global 0 Temporary gint2 :: Global Int gint2 = global 42 Temporary rwglobals :: IO [Int] rwglobals = do v1 <- readGlobal gint1 v2 <- readGlobal gint2 writeGlobal gint2 99 v3 <- readGlobal gint1 v4 <- readGlobal gint2 writeGlobal gint1 (v4+1) v5 <- readGlobal gint1 v6 <- readGlobal gint2 return [v1,v2,v3,v4,v5,v6] testReadWriteTwoTemporaryGlobals = rwglobals `returns` [0,42,0,99,100,99] ------------------------------------------------------------------------------ -- Testing a simple integer persistent global entity: ppoints :: Global Int ppoints = global (3+4) (Persistent "pointsstore") rwglobalp :: IO (Int,Int) rwglobalp = do v1 <- readGlobal ppoints writeGlobal ppoints 42 v2 <- readGlobal ppoints return (v1,v2) testPersistentIntReadGlobalWriteGlobal = rwglobalp `returns` (7,42) -- finalize: clean testCleanUp = (system "rm -r pointsstore*") `returns` 0 curry-tools-v3.3.0/optimize/.cpm/packages/io-extra/000077500000000000000000000000001377556325500222325ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/io-extra/LICENSE000066400000000000000000000027351377556325500232460ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/io-extra/package.json000066400000000000000000000014241377556325500245210ustar00rootroot00000000000000{ "name": "io-extra", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library with some useful extensions to the IO monad.", "category": [ "IO" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base": ">= 3.0.0, < 4.0.0", "process": ">= 3.0.0, < 4.0.0", "directory":">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.IOExts" ], "testsuite": { "src-dir": "test", "modules": [ "TestConnect" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/io-extra.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/io-extra/src/000077500000000000000000000000001377556325500230215ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/io-extra/src/System/000077500000000000000000000000001377556325500243055ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/io-extra/src/System/IOExts.curry000066400000000000000000000136041377556325500265520ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library with some useful extensions to the IO monad. --- --- @author Michael Hanus --- @version January 2017 ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} module System.IOExts ( -- execution of shell commands execCmd, evalCmd, connectToCommand -- file access , readCompleteFile,updateFile, exclusiveIO -- associations , setAssoc,getAssoc -- IORef , IORef, newIORef, readIORef, writeIORef, modifyIORef ) where #ifdef __PAKCS__ import Data.Char (isAlphaNum) import System.Directory (removeFile) #endif import System.IO import System.Process import Data.IORef import Control.Monad --- Executes a command with a new default shell process. --- The standard I/O streams of the new process (stdin,stdout,stderr) --- are returned as handles so that they can be explicitly manipulated. --- They should be closed with IO.hClose since they are not --- closed automatically when the process terminates. --- @param cmd - the shell command to be executed --- @return the handles of the input/output/error streams of the new process execCmd :: String -> IO (Handle, Handle, Handle) execCmd cmd = prim_execCmd $## cmd prim_execCmd :: String -> IO (Handle, Handle, Handle) prim_execCmd external --- Executes a command with the given arguments as a new default shell process --- and provides the input via the process' stdin input stream. --- The exit code of the process and the contents written to the standard --- I/O streams stdout and stderr are returned. --- @param cmd - the shell command to be executed --- @param args - the command's arguments --- @param input - the input to be written to the command's stdin --- @return the exit code and the contents written to stdout and stderr evalCmd :: String -> [String] -> String -> IO (Int, String, String) #ifdef __PAKCS__ evalCmd cmd args input = do pid <- getPID let tmpfile = "/tmp/PAKCS_evalCMD"++show pid (hi,ho,he) <- execCmd (unwords (map wrapArg (cmd:args)) ++ " ; (echo $? > "++tmpfile++")") unless (null input) (hPutStrLn hi input) hClose hi outs <- hGetEOF ho errs <- hGetEOF he ecodes <- readCompleteFile tmpfile removeFile tmpfile return (read ecodes, outs, errs) where wrapArg str | null str = "''" -- goodChar is a pessimistic predicate, such that if an argument is -- non-empty and only contains goodChars, then there is no need to -- do any quoting or escaping | all goodChar str = str | otherwise = '\'' : foldr escape "'" str where escape c s | c == '\'' = "'\\''" ++ s | otherwise = c : s goodChar c = isAlphaNum c || c `elem` "-_.,/" --- Reads from an input handle until EOF and returns the input. hGetEOF :: Handle -> IO String hGetEOF h = do eof <- hIsEOF h if eof then hClose h >> return "" else do c <- hGetChar h cs <- hGetEOF h return (c:cs) #else evalCmd cmd args input = ((prim_evalCmd $## cmd) $## args) $## input prim_evalCmd :: String -> [String] -> String -> IO (Int, String, String) prim_evalCmd external #endif --- Executes a command with a new default shell process. --- The input and output streams of the new process is returned --- as one handle which is both readable and writable. --- Thus, writing to the handle produces input to the process and --- output from the process can be retrieved by reading from this handle. --- The handle should be closed with IO.hClose since they are not --- closed automatically when the process terminates. --- @param cmd - the shell command to be executed --- @return the handle connected to the input/output streams --- of the new process connectToCommand :: String -> IO Handle connectToCommand cmd = prim_connectToCmd $## cmd prim_connectToCmd :: String -> IO Handle prim_connectToCmd external --- An action that reads the complete contents of a file and returns it. --- This action can be used instead of the (lazy) readFile --- action if the contents of the file might be changed. --- @param file - the name of the file --- @return the complete contents of the file readCompleteFile :: String -> IO String readCompleteFile file = do s <- readFile file f s (return s) where f [] r = r f (_:cs) r = f cs r --- An action that updates the contents of a file. --- @param f - the function to transform the contents --- @param file - the name of the file updateFile :: (String -> String) -> String -> IO () updateFile f file = do s <- readCompleteFile file writeFile file (f s) --- Forces the exclusive execution of an action via a lock file. --- For instance, (exclusiveIO "myaction.lock" act) ensures that --- the action "act" is not executed by two processes on the same --- system at the same time. --- @param lockfile - the name of a global lock file --- @param action - the action to be exclusively executed --- @return the result of the execution of the action exclusiveIO :: String -> IO a -> IO a exclusiveIO lockfile action = do system ("lockfile-create --lock-name "++lockfile) catch (do actionResult <- action deleteLockFile return actionResult ) (\e -> deleteLockFile >> ioError e) where deleteLockFile = system $ "lockfile-remove --lock-name " ++ lockfile --- Defines a global association between two strings. --- Both arguments must be evaluable to ground terms before applying --- this operation. setAssoc :: String -> String -> IO () setAssoc key val = (prim_setAssoc $## key) $## val prim_setAssoc :: String -> String -> IO () prim_setAssoc external --- Gets the value associated to a string. --- Nothing is returned if there does not exist an associated value. getAssoc :: String -> IO (Maybe String) getAssoc key = prim_getAssoc $## key prim_getAssoc :: String -> IO (Maybe String) prim_getAssoc external curry-tools-v3.3.0/optimize/.cpm/packages/io-extra/src/System/IOExts.kics2000066400000000000000000000045511377556325500264220ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses #-} import Data.IORef import System.IO.Unsafe (unsafePerformIO) -- for global associations import System.Process (readProcessWithExitCode, runInteractiveCommand) import Control.Concurrent (forkIO) import System.IO external_d_C_prim_execCmd :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple3 Curry_IO.C_Handle Curry_IO.C_Handle Curry_IO.C_Handle) external_d_C_prim_execCmd str _ _ = toCurry (\s -> do (h1,h2,h3,_) <- runInteractiveCommand s return (OneHandle h1, OneHandle h2, OneHandle h3)) str external_d_C_prim_evalCmd :: Curry_Prelude.C_String -> Curry_Prelude.OP_List Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple3 Curry_Prelude.C_Int Curry_Prelude.C_String Curry_Prelude.C_String) external_d_C_prim_evalCmd cmd args input _ _ = toCurry readProcessWithExitCode cmd args input external_d_C_prim_connectToCmd :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_IO.C_Handle external_d_C_prim_connectToCmd str _ _ = toCurry (\s -> do (hin,hout,herr,_) <- runInteractiveCommand s forkIO (forwardError herr) return (InOutHandle hout hin)) str forwardError :: Handle -> IO () forwardError h = do eof <- hIsEOF h if eof then return () else hGetLine h >>= hPutStrLn stderr >> forwardError h ----------------------------------------------------------------------- -- Implementation of global associations as simple association lists -- (could be later improved by a more efficient implementation, e.g., maps) type Assocs = [(String,String)] assocs :: IORef Assocs assocs = unsafePerformIO (newIORef []) external_d_C_prim_setAssoc :: Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_setAssoc str1 str2 _ _ = toCurry (\key val -> do as <- readIORef assocs writeIORef assocs ((key,val):as)) str1 str2 external_d_C_prim_getAssoc :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_Maybe (Curry_Prelude.C_String)) external_d_C_prim_getAssoc str _ _ = toCurry (\key -> do as <- readIORef assocs return (lookup key as)) str curry-tools-v3.3.0/optimize/.cpm/packages/io-extra/src/System/IOExts.pakcs.pl000066400000000000000000000016711377556325500271220ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Prolog implementation of builtins of module System.IOExts: % :- dynamic globalAssoc/2. 'System.IOExts.prim_setAssoc'(Key,Val,'Prelude.()') :- string2Atom(Key,KeyA), (retract(globalAssoc(KeyA,_)) -> true ; true), assertz(globalAssoc(KeyA,Val)), !. 'System.IOExts.prim_getAssoc'(Key,R) :- string2Atom(Key,KeyA), (globalAssoc(KeyA,Val) -> R='Prelude.Just'(Val) ; R='Prelude.Nothing'), !. % shell command execution: 'System.IOExts.prim_execCmd'(CmdString,'Prelude.(,,)'(StdIn,StdOut,StdErr)) :- string2Atom(CmdString,Cmd), execCommand(Cmd,StdIn,StdOut,StdErr). % shell command execution: 'System.IOExts.prim_connectToCmd'(CmdString, '$stream'('$inoutstream'(StdOut,StdIn))) :- string2Atom(CmdString,Cmd), execCommand(Cmd,StdIn,StdOut,std). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% curry-tools-v3.3.0/optimize/.cpm/packages/io-extra/test/000077500000000000000000000000001377556325500232115ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/io-extra/test/TestConnect.curry000066400000000000000000000005061377556325500265310ustar00rootroot00000000000000-- Testing operations from library IOExts: import System.IO import System.IOExts import Test.Prop -- Execute shell command show the first output line of its execution: getExec cmd = do hdl <- connectToCommand cmd s <- hGetLine hdl hClose hdl return s testConnectToCommand = (getExec "echo abcde") `returns` "abcde" curry-tools-v3.3.0/optimize/.cpm/packages/process/000077500000000000000000000000001377556325500221605ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/process/LICENSE000066400000000000000000000027351377556325500231740ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/process/package.json000066400000000000000000000011461377556325500244500ustar00rootroot00000000000000{ "name": "process", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "A library for process manipulation and information.", "category": [ "System" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.Process" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/process.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/process/src/000077500000000000000000000000001377556325500227475ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/process/src/System/000077500000000000000000000000001377556325500242335ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/process/src/System/Process.curry000066400000000000000000000021621377556325500267400ustar00rootroot00000000000000module System.Process ( getPID, system, exitWith, sleep ) where import System.Environment --- Returns the process identifier of the current Curry process. getPID :: IO Int getPID external --- Executes a shell command and return with the exit code of the command. --- An exit status of zero means successful execution. system :: String -> IO Int system cmd = prim_system $## escapedCmd where win = isWindows -- This is a work around for GHC ticket #5376 -- (http://hackage.haskell.org/trac/ghc/ticket/5376) escapedCmd = if win then '\"' : cmd ++ "\"" else cmd prim_system :: String -> IO Int prim_system external --- Terminates the execution of the current Curry program --- and returns the exit code given by the argument. --- An exit code of zero means successful execution. exitWith :: Int -> IO _ exitWith exitcode = prim_exitWith $# exitcode prim_exitWith :: Int -> IO _ prim_exitWith external --- The evaluation of the action (sleep n) puts the Curry process --- asleep for n seconds. sleep :: Int -> IO () sleep n = prim_sleep $# n prim_sleep :: Int -> IO () prim_sleep external curry-tools-v3.3.0/optimize/.cpm/packages/process/src/System/Process.kics2000066400000000000000000000035141377556325500266110ustar00rootroot00000000000000{-# LANGUAGE CPP, ForeignFunctionInterface, MultiParamTypeClasses #-} import Control.Exception as C (IOException, handle) import System.Exit (ExitCode (..), exitWith) import System.Process (system) #if defined(mingw32_HOST_OS) || defined(__MINGW32__) import System.Win32.Process #else import System.Posix.Process (getProcessID) #endif -- #endimport - do not remove this line! #if defined(mingw32_HOST_OS) || defined(__MINGW32__) foreign import stdcall unsafe "windows.h GetCurrentProcessId" getProcessID :: IO ProcessId #endif external_d_C_getPID :: Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_getPID _ _ = toCurry $ do pid <- getProcessID return (fromIntegral pid :: Int) external_d_C_prim_system :: Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.C_Int external_d_C_prim_system str _ _ = toCurry system str instance ConvertCurryHaskell Curry_Prelude.C_Int ExitCode where toCurry ExitSuccess = toCurry (0 :: Int) toCurry (ExitFailure i) = toCurry i fromCurry j = let i = fromCurry j :: Int in if i == 0 then ExitSuccess else ExitFailure i external_d_C_prim_exitWith :: Curry_Prelude.Curry a => Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO a external_d_C_prim_exitWith c _ _ = fromIO (exitWith (fromCurry c)) external_d_C_prim_sleep :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_sleep x _ _ = toCurry (\i -> system ("sleep " ++ show (i :: Int)) >> return ()) x -- TODO external_d_C_isWindows :: Cover -> ConstStore -> Curry_Prelude.C_Bool #if defined(mingw32_HOST_OS) || defined(__MINGW32__) external_d_C_isWindows _ _ = Curry_Prelude.C_True #else external_d_C_isWindows _ _ = Curry_Prelude.C_False #endif curry-tools-v3.3.0/optimize/.cpm/packages/process/src/System/Process.pakcs.pl000066400000000000000000000006021377556325500273040ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module System.Process: % 'System.Process.getPID'(Pid) :- currentPID(Pid). 'System.Process.prim_system'(S,Status) :- string2Atom(S,Cmd), shellCmd(Cmd,Status). 'System.Process.prim_exitWith'(Code,_) :- halt(Code). 'System.Process.prim_sleep'(S,'Prelude.()') :- sleepSeconds(S). curry-tools-v3.3.0/optimize/.cpm/packages/propertyfile/000077500000000000000000000000001377556325500232265ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/propertyfile/LICENSE000066400000000000000000000027351377556325500242420ustar00rootroot00000000000000Copyright (c) 2018, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/propertyfile/README.md000066400000000000000000000005551377556325500245120ustar00rootroot00000000000000propertyfile ============ This package provides a library to read and update files containing properties or configurations in the usual equational syntax. A property is defined by a line of the form prop=value where `prop` starts with a letter. All other lines (e.g., blank lines or lines starting with `#` are considered as comment lines and are ignored. curry-tools-v3.3.0/optimize/.cpm/packages/propertyfile/package.json000066400000000000000000000013371377556325500255200ustar00rootroot00000000000000{ "name": "propertyfile", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Read and update files containing properties in equational syntax", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base": ">= 3.0.0, < 4.0.0", "directory": ">= 3.0.0, < 4.0.0", "io-extra": ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Data.PropertyFile" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/propertyfile.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/propertyfile/src/000077500000000000000000000000001377556325500240155ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/propertyfile/src/Data/000077500000000000000000000000001377556325500246665ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/propertyfile/src/Data/PropertyFile.curry000066400000000000000000000063001377556325500303770ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A library to read and update files containing properties in the usual --- equational syntax, i.e., a property is defined by a line of the form --- `prop=value` where `prop` starts with a letter. --- All other lines (e.g., blank lines or lines starting with `#` are --- considered as comment lines and are ignored. --- --- @author Michael Hanus --- @version August 2006 --- @category general ------------------------------------------------------------------------------ module Data.PropertyFile ( readPropertyFile, updatePropertyFile , getPropertyFromFile, getPropertiesFromFile ) where import Data.Char import System.Directory import System.IOExts ------------------------------------------------------------------------------ --- Reads a property file and returns the list of properties. --- Returns empty list if the property file does not exist. readPropertyFile :: String -> IO [(String,String)] readPropertyFile file = do pfexists <- doesFileExist file if pfexists then do rcs <- readCompleteFile file -- to avoid open file handles return $ splitEqs . filter (\l->not (null l) && isAlpha (head l)) . lines $ rcs else return [] where splitEqs [] = [] splitEqs (eq:eqs) = case break (=='=') eq of (prop,_:val) -> (prop,val) : splitEqs eqs _ -> splitEqs eqs --- Update a property in a property file or add it, if it is not already --- there. --- @param file - the name of the property file --- @param pname - the name of the property --- @param pvalue - the new value of the property updatePropertyFile :: String -> String -> String -> IO () updatePropertyFile file pname pval = do props <- readPropertyFile file if lookup pname props == Nothing then appendFile file (pname++"="++pval++"\n") else changePropertyInFile file pname pval --- Change a property in a property file. changePropertyInFile :: String -> String -> String -> IO () changePropertyInFile file pname pval = do updateFile (\rcs -> unlines . map changeProp . lines $ rcs) file where changeProp l = let (s1,s2) = break (=='=') l in if null l || not (isAlpha (head l)) || null s2 then l else if s1==pname then s1++"="++pval else l ------------------------------------------------------------------------------ --- Looks up the value of a property stored in a property file. --- Uppercase/lowercase is ignored for the property names. getPropertyFromFile :: String -> String -> IO (Maybe String) getPropertyFromFile propfile propname = do props <- readPropertyFile propfile return $ lookup (map toLower propname) (map (\ (a, b) -> (map toLower a, b)) props) --- Looks up the values of properties stored in a property file. --- Uppercase/lowercase is ignored for the variable names. getPropertiesFromFile :: String -> [String] -> IO [Maybe String] getPropertiesFromFile propfile propnames = do props <- readPropertyFile propfile return (map (flip lookup (map (\ (a, b) -> (map toLower a, b)) props)) (map (map toLower) propnames)) ------------------------------------------------------------------------------ curry-tools-v3.3.0/optimize/.cpm/packages/queue/000077500000000000000000000000001377556325500216265ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/queue/LICENSE000066400000000000000000000027351377556325500226420ustar00rootroot00000000000000Copyright (c) 2018, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/queue/README.md000066400000000000000000000002111377556325500230770ustar00rootroot00000000000000queue ===== This package contains a library implementing double-ended queues supporting access at both ends in constant amortized time. curry-tools-v3.3.0/optimize/.cpm/packages/queue/package.json000066400000000000000000000014201377556325500241110ustar00rootroot00000000000000{ "name": "queue", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library with double-ended queues supporting access at both ends in constant amortized time", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "random" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Data.Queue" ], "testsuite": { "src-dir": "test", "modules": [ "TestQueue" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/queue.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/queue/src/000077500000000000000000000000001377556325500224155ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/queue/src/Data/000077500000000000000000000000001377556325500232665ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/queue/src/Data/Queue.curry000066400000000000000000000073361377556325500254510ustar00rootroot00000000000000------------------------------------------------------------------------------ --- An implementation of double-ended queues supporting access at both --- ends in constant amortized time. --- --- @author Bernd Brassel, Olaf Chitil, Michael Hanus, Sebastian Fischer, --- Bjoern Peemoeller --- @version December 2018 ------------------------------------------------------------------------------ module Data.Queue ( -- Abstract data type, constructors and queries Queue, empty, cons, snoc, isEmpty, deqLength -- Selectors , deqHead, deqTail, deqLast, deqInit, deqReverse, rotate, matchHead, matchLast -- conversion from and to lists , listToDeq, deqToList ) where --- The datatype of a queue. data Queue a = S Int [a] Int [a] --- The empty queue. empty :: Queue _ empty = S 0 [] 0 [] --- Inserts an element at the front of the queue. cons :: a -> Queue a -> Queue a cons x (S lenf f lenr r) = check (lenf + 1) (x : f) lenr r --- Inserts an element at the end of the queue. snoc :: a -> Queue a -> Queue a snoc x (S lenf f lenr r) = deqReverse (check (lenr + 1) (x : r) lenf f) --- Is the queue empty? isEmpty :: Queue _ -> Bool isEmpty (S lenf _ lenr _) = lenf + lenr == 0 --- Returns the number of elements in the queue. deqLength :: Queue _ -> Int deqLength (S lenf _ lenr _) = lenf + lenr --- The first element of the queue. deqHead :: Queue a -> a deqHead (S lenf f _ r) = head (if lenf == 0 then r else f) --- Removes an element at the front of the queue. deqTail :: Queue a -> Queue a deqTail (S _ [] _ _) = empty deqTail (S lenf (_:fs) lenr r) = deqReverse (check lenr r (lenf - 1) fs) --- The last element of the queue. deqLast :: Queue a -> a deqLast (S _ f lenr r) = head (if lenr == 0 then f else r) --- Removes an element at the end of the queue. deqInit :: Queue a -> Queue a deqInit (S _ _ _ [] ) = empty deqInit (S lenf f lenr (_:rs)) = check lenf f (lenr - 1) rs --- Reverses a double ended queue. deqReverse :: Queue a -> Queue a deqReverse (S lenf f lenr r) = S lenr r lenf f --- Moves the first element to the end of the queue. rotate :: Queue a -> Queue a rotate q = snoc (deqHead q) (deqTail q) --- Matches the front of a queue. --- `matchHead q` is equivalent to --- `if isEmpty q then Nothing else Just (deqHead q, deqTail q)` --- but more efficient. matchHead :: Queue a -> Maybe (a, Queue a) matchHead (S _ [] _ [] ) = Nothing matchHead (S _ [] _ [x] ) = Just (x, empty) matchHead (S _ [] _ (_:_:_)) = error $ "Data.Queue.matchHead: illegal queue" matchHead (S lenf (x:xs) lenr r ) = Just (x, deqReverse (check lenr r (lenf - 1) xs)) --- Matches the end of a queue. --- `matchLast q` is equivalent to --- `if isEmpty q then Nothing else Just (deqLast q,deqInit q)` --- but more efficient. matchLast :: Queue a -> Maybe (a,Queue a) matchLast (S _ [] _ [] ) = Nothing matchLast (S _ [x] _ [] ) = Just (x, empty) matchLast (S _ (_:_:_) _ [] ) = error $ "Data.Queue.matchLast: illegal queue" matchLast (S lenf f lenr (x:xs)) = Just (x, check lenf f (lenr - 1) xs) --- Transforms a list to a double ended queue. listToDeq :: [a] -> Queue a listToDeq xs = check (length xs) xs 0 [] --- Transforms a double ended queue to a list. deqToList :: Queue a -> [a] deqToList (S _ xs _ ys) = xs ++ reverse ys --- Check for invariant: The length of the first list is smaller than --- three times the length of the second plus 1. check :: Int -> [a] -> Int -> [a] -> Queue a check lenf f lenr r | lenf <= 3 * lenr + 1 = S lenf f lenr r | otherwise = S lenf' f' lenr' r' where len = lenf + lenr lenf' = len `div` 2 lenr' = len - lenf' (f', rf') = splitAt lenf' f r' = r ++ reverse rf' curry-tools-v3.3.0/optimize/.cpm/packages/queue/test/000077500000000000000000000000001377556325500226055ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/queue/test/TestQueue.curry000066400000000000000000000031161377556325500256200ustar00rootroot00000000000000import Data.List import Test.Prop import System.Random import Data.Queue deq f = f . listToDeq deqs f = deqToList . f . listToDeq testHead = eq (deq deqHead) head testLast = eq (deq deqLast) last testCons = eq (deqs (cons 73)) (73:) testTail = eq (deqs (deqTail)) tail testSnoc = eq (deqs (snoc 73)) (++[73]) testInit = eq (deqs deqInit) init where init [x] = [] init (x:y:ys) = x : init (y:ys) testReverse = eq (deqs deqReverse) reverse testLength = eq (deq deqLength) length testRotate = eq (deqs rotate) (\ (x:xs) -> xs ++ [x]) ------------------------------------------------------------------------------ -- Random test: --- Tests a given predicate on a list of distinct random numbers. --- In case of a failure, the list of random numbers is returned --- in order to see the test cases in the CurryTest tool. test :: ([Int] -> Bool) -> PropIO test f = (rndList lenRnds >>= \xs -> return (if f xs then Nothing else Just xs)) `returns` Nothing --- Tests whether two operations return equal results --- on a list of distinct random numbers. --- In case of a failure, the list of random numbers is returned --- in order to see the test cases in the CurryTest tool. eq :: Eq a => ([Int] -> a) -> ([Int] -> a) -> PropIO eq f g = test (\x -> (f x)==(g x)) --- generate a list of at most n random numbers (without duplicated elements) rndList :: Int -> IO [Int] rndList n = getRandomSeed >>= return . nub . take n . (flip nextIntRange 100000) --- maximal length of test lists lenRnds :: Int lenRnds = 1000 ------------------------------------------------------------------------------ curry-tools-v3.3.0/optimize/.cpm/packages/random/000077500000000000000000000000001377556325500217625ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/random/LICENSE000066400000000000000000000027351377556325500227760ustar00rootroot00000000000000Copyright (c) 2018, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/random/README.md000066400000000000000000000001571377556325500232440ustar00rootroot00000000000000random ====== This package contains the library `System.Random` for pseudo-random number generation in Curry. curry-tools-v3.3.0/optimize/.cpm/packages/random/package.json000066400000000000000000000013151377556325500242500ustar00rootroot00000000000000{ "name": "random", "version": "3.0.0", "author": "Sergio Antoy ", "maintainer": "Michael Hanus ", "synopsis": "Library for pseudo-random number generation", "category": [ "Programming", "Numeric" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base": ">= 3.0.0, < 4.0.0", "time": ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "System.Random" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/random.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/random/src/000077500000000000000000000000001377556325500225515ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/random/src/System/000077500000000000000000000000001377556325500240355ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/random/src/System/Random.curry000066400000000000000000000153521377556325500263510ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for pseudo-random number generation in Curry. --- --- This library provides operations for generating pseudo-random --- number sequences. --- For any given seed, the sequences generated by the operations --- in this module should be **identical** to the sequences --- generated by the `java.util.Random package`. --- ------------------------------------------------------------------------------ --- The KiCS2 implementation is based on an algorithm taken from --- . --- There is an assumption that all operations are implicitly --- executed mod 2^32 (unsigned 32-bit integers) !!! --- GHC computes between -2^29 and 2^29-1, thus the sequence --- is NOT as random as one would like. --- --- m_w = ; /* must not be zero */ --- m_z = ; /* must not be zero */ --- --- uint get_random() --- { --- m_z = 36969 * (m_z & 65535) + (m_z >> 16); --- m_w = 18000 * (m_w & 65535) + (m_w >> 16); --- return (m_z << 16) + m_w; /* 32-bit result */ --- } --- ------------------------------------------------------------------------------ --- The PAKCS implementation is a linear congruential pseudo-random number --- generator described in --- Donald E. Knuth, _The Art of Computer Programming_, --- Volume 2: _Seminumerical Algorithms_, section 3.2.1. --- ------------------------------------------------------------------------------ --- @author Sergio Antoy (with extensions by Michael Hanus) --- @version June 2017 ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} module System.Random ( nextInt, nextIntRange, nextBoolean, getRandomSeed , shuffle ) where import System.CPUTime ( getCPUTime ) import Data.Time ( CalendarTime(..), getClockTime, toUTCTime ) #ifdef __PAKCS__ ------------------------------------------------------------------ -- Private Operations ------------------------------------------------------------------ -- a few constants multiplier :: Int multiplier = 25214903917 addend :: Int addend = 11 powermask :: Int powermask = 48 mask :: Int mask = 281474976710656 -- 2^powermask intsize :: Int intsize = 32 intspan :: Int intspan = 4294967296 -- 2^intsize intlimit :: Int intlimit = 2147483648 -- 2^(intsize-1) -- the basic sequence of random values sequence :: Int -> [Int] sequence seed = next : sequence next where next = nextseed seed -- auxiliary private operations nextseed :: Int -> Int nextseed seed = (seed * multiplier + addend) `rem` mask xor :: Int -> Int -> Int xor x y = if (x==0) && (y==0) then 0 else lastBit + 2 * restBits where lastBit = if (x `rem` 2) == (y `rem` 2) then 0 else 1 restBits = xor (x `quot` 2) (y `quot` 2) power :: Int -> Int -> Int power base exp = binary 1 base exp where binary x b e = if (e == 0) then x else binary (x * if (e `rem` 2 == 1) then b else 1) (b * b) (e `quot` 2) nextIntBits :: Int -> Int -> [Int] nextIntBits seed bits = map adjust list where init = (xor seed multiplier) `rem` mask list = sequence init shift = power 2 (powermask - bits) adjust x = if arg > intlimit then arg - intspan else arg where arg = (x `quot` shift) `rem` intspan #else zfact :: Int zfact = 36969 wfact :: Int wfact = 18000 two16 :: Int two16 = 65536 large :: Int large = 536870911 -- 2^29 - 1 #endif ------------------------------------------------------------------ -- Public Operations ------------------------------------------------------------------ --- Returns a sequence of pseudorandom, integer values. --- --- @param seed - The seed of the random sequence. nextInt :: Int -> [Int] #ifdef __PAKCS__ nextInt seed = nextIntBits seed intsize #else nextInt seed = let ns = if seed == 0 then 1 else seed next2 mw mz = let mza = zfact * (mz `mod` two16) + (mz * two16) mwa = wfact * (mw `mod` two16) + (mw * two16) tmp = (mza `div` two16 + mwa) res = if tmp < 0 then tmp+large else tmp in res : next2 mwa mza in next2 ns ns #endif --- Returns a pseudorandom sequence of values --- between 0 (inclusive) and the specified value (exclusive). --- --- @param seed - The seed of the random sequence. --- @param n - The bound on the random number to be returned. --- Must be positive. nextIntRange :: Int -> Int -> [Int] #ifdef __PAKCS__ nextIntRange seed n | n>0 = if power_of_2 n then map adjust_a seq else map adjust_b (filter adjust_c seq) where seq = nextIntBits seed (intsize - 1) adjust_a x = (n * x) `quot` intlimit adjust_b x = x `rem` n adjust_c x = x - (x `rem` n) + (n - 1) >= 0 power_of_2 k = k == 2 || k > 2 && k `rem` 2 == 0 && power_of_2 (k `quot` 2) #else nextIntRange seed n | n>0 = map (`mod` n) (nextInt seed) #endif --- Returns a pseudorandom sequence of boolean values. --- --- @param seed - The seed of the random sequence. nextBoolean :: Int -> [Bool] #ifdef __PAKCS__ nextBoolean seed = map (/= 0) (nextIntBits seed 1) #else nextBoolean seed = map (/= 0) (nextInt seed) #endif --- Returns a time-dependent integer number as a seed for really random numbers. --- Should only be used as a seed for pseudorandom number sequence --- and not as a random number since the precision is limited to milliseconds getRandomSeed :: IO Int getRandomSeed = getClockTime >>= \time -> getCPUTime >>= \msecs -> let (CalendarTime y mo d h m s _) = toUTCTime time #ifdef __PAKCS__ in return ((y+mo+d+h+(m+1)*(s+1)*(msecs+1)) `rem` mask) #else in return ((y+mo+d+h+(m+1)*(s+1)*(msecs+1)) `mod` two16) #endif --- Computes a random permutation of the given list. --- --- @param rnd random seed --- @param l lists to shuffle --- @return shuffled list --- shuffle :: Int -> [a] -> [a] shuffle rnd xs = shuffleWithLen (nextInt rnd) (length xs) xs shuffleWithLen :: [Int] -> Int -> [a] -> [a] shuffleWithLen [] _ _ = error "Internal error in Random.shuffleWithLen" shuffleWithLen (r:rs) len xs | len == 0 = [] | otherwise = z : shuffleWithLen rs (len-1) (ys++zs) where #ifdef __PAKCS__ (ys,z:zs) = splitAt (abs r `rem` len) xs #else (ys,z:zs) = splitAt (abs r `mod` len) xs #endif {- Simple tests and examples testInt = take 20 (nextInt 0) testIntRange = take 120 (nextIntRange 0 6) testBoolean = take 20 (nextBoolean 0) reallyRandom = do seed <- getRandomSeed putStrLn (show (take 20 (nextIntRange seed 100))) -} curry-tools-v3.3.0/optimize/.cpm/packages/read-legacy/000077500000000000000000000000001377556325500226575ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/read-legacy/LICENSE000066400000000000000000000027351377556325500236730ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/read-legacy/package.json000066400000000000000000000011541377556325500251460ustar00rootroot00000000000000{ "name": "read-legacy", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "A library for reading and writing from or to strings.", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "ReadShowTerm" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/read-legacy.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/read-legacy/src/000077500000000000000000000000001377556325500234465ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/read-legacy/src/ReadShowTerm.curry000066400000000000000000000144231377556325500271040ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for converting ground terms to strings and vice versa. --- --- @author Michael Hanus --- @version April 2005 ------------------------------------------------------------------------------ module ReadShowTerm(showTerm,showQTerm,readQTerm,readsQTerm, readsUnqualifiedTerm,readUnqualifiedTerm,readsTerm,readTerm, readQTermFile,readQTermListFile, writeQTermFile,writeQTermListFile) where import Data.Char(isSpace) --- Transforms a ground(!) term into a string representation --- in standard prefix notation. --- Thus, showTerm suspends until its argument is ground. --- This function is similar to the prelude function show --- but can read the string back with readUnqualifiedTerm --- (provided that the constructor names are unique without the module --- qualifier). showTerm :: _ -> String showTerm x = prim_showTerm $## x prim_showTerm :: _ -> String prim_showTerm external --- Transforms a ground(!) term into a string representation --- in standard prefix notation. --- Thus, showTerm suspends until its argument is ground. --- Note that this function differs from the prelude function show --- since it prefixes constructors with their module name --- in order to read them back with readQTerm. showQTerm :: _ -> String showQTerm x = prim_showQTerm $## x prim_showQTerm :: _ -> String prim_showQTerm external --- Transform a string containing a term in standard prefix notation --- without module qualifiers into the corresponding data term. --- The first argument is a non-empty list of module qualifiers that are tried to --- prefix the constructor in the string in order to get the qualified constructors --- (that must be defined in the current program!). --- In case of a successful parse, the result is a one element list --- containing a pair of the data term and the remaining unparsed string. readsUnqualifiedTerm :: [String] -> String -> [(_,String)] readsUnqualifiedTerm [] _ = error "ReadShowTerm.readsUnqualifiedTerm: list of module prefixes is empty" readsUnqualifiedTerm (prefix:prefixes) s = readsUnqualifiedTermWithPrefixes (prefix:prefixes) s readsUnqualifiedTermWithPrefixes :: [String] -> String -> [(_,String)] readsUnqualifiedTermWithPrefixes prefixes s = (prim_readsUnqualifiedTerm $## prefixes) $## s prim_readsUnqualifiedTerm :: [String] -> String -> [(_,String)] prim_readsUnqualifiedTerm external --- Transforms a string containing a term in standard prefix notation --- without module qualifiers into the corresponding data term. --- The first argument is a non-empty list of module qualifiers that are tried to --- prefix the constructor in the string in order to get the qualified constructors --- (that must be defined in the current program!). --- --- Example: readUnqualifiedTerm ["Prelude"] "Just 3" --- evaluates to (Just 3) readUnqualifiedTerm :: [String] -> String -> _ readUnqualifiedTerm prefixes s = case result of [(term,tail)] -> if all isSpace tail then term else error ("ReadShowTerm.readUnqualifiedTerm: no parse, unmatched string after term: "++tail) [] -> error "ReadShowTerm.readUnqualifiedTerm: no parse" _ -> error "ReadShowTerm.readUnqualifiedTerm: ambiguous parse" where result = readsUnqualifiedTerm prefixes s --- For backward compatibility. Should not be used since their use can be problematic --- in case of constructors with identical names in different modules. readsTerm :: String -> [(_,String)] readsTerm s = prim_readsUnqualifiedTerm [] $## s --- For backward compatibility. Should not be used since their use can be problematic --- in case of constructors with identical names in different modules. readTerm :: String -> _ readTerm s = case result of [(term,tail)] -> if all isSpace tail then term else error ("ReadShowTerm.readTerm: no parse, unmatched string after term: "++tail) [] -> error "ReadShowTerm.readTerm: no parse" _ -> error "ReadShowTerm.readTerm: ambiguous parse" where result = prim_readsUnqualifiedTerm [] $## s --- Transforms a string containing a term in standard prefix notation --- with qualified constructor names into the corresponding data term. --- In case of a successful parse, the result is a one element list --- containing a pair of the data term and the remaining unparsed string. readsQTerm :: String -> [(_,String)] readsQTerm s = prim_readsQTerm $## s prim_readsQTerm :: String -> [(_,String)] prim_readsQTerm external --- Transforms a string containing a term in standard prefix notation --- with qualified constructor names into the corresponding data term. readQTerm :: String -> _ readQTerm s = case result of [(term,tail)] -> if all isSpace tail then term else error "ReadShowTerm.readQTerm: no parse" [] -> error "ReadShowTerm.readQTerm: no parse" _ -> error "ReadShowTerm.readQTerm: ambiguous parse" where result = readsQTerm s --- Reads a file containing a string representation of a term --- in standard prefix notation and returns the corresponding data term. readQTermFile :: String -> IO _ readQTermFile file = readFile file >>= return . readQTerm --- Reads a file containing lines with string representations of terms --- of the same type and returns the corresponding list of data terms. readQTermListFile :: String -> IO [_] readQTermListFile file = readFile file >>= return . map readQTerm . lines --- Writes a ground term into a file in standard prefix notation. --- @param filename - The name of the file to be written. --- @param term - The term to be written to the file as a string. writeQTermFile :: String -> _ -> IO () writeQTermFile filename term = writeFile filename (showQTerm term) --- Writes a list of ground terms into a file. --- Each term is written into a separate line which might be useful --- to modify the file with a standard text editor. --- @param filename - The name of the file to be written. --- @param terms - The list of terms to be written to the file. writeQTermListFile :: String -> [_] -> IO () writeQTermListFile filename terms = writeFile filename (unlines (map showQTerm terms)) curry-tools-v3.3.0/optimize/.cpm/packages/read-legacy/src/ReadShowTerm.kics2000066400000000000000000000020401377556325500267430ustar00rootroot00000000000000external_d_C_prim_showTerm :: Show a => a -> Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_prim_showTerm t _ _ = toCurry (show t) external_d_C_prim_showQTerm :: Show a => a -> Cover -> ConstStore -> Curry_Prelude.C_String external_d_C_prim_showQTerm t _ _ = toCurry (show t) external_d_C_prim_readsUnqualifiedTerm :: Read a => Curry_Prelude.OP_List Curry_Prelude.C_String -> Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 a Curry_Prelude.C_String) external_d_C_prim_readsUnqualifiedTerm _ = external_d_C_prim_readsQTerm external_d_C_prim_readsQTerm :: Read a => Curry_Prelude.C_String -> Cover -> ConstStore -> Curry_Prelude.OP_List (Curry_Prelude.OP_Tuple2 a Curry_Prelude.C_String) external_d_C_prim_readsQTerm s _ _ = toCurryPairs (reads (fromCurry s)) where toCurryPairs [] = Curry_Prelude.OP_List toCurryPairs ((v,s):xs) = Curry_Prelude.OP_Cons (Curry_Prelude.OP_Tuple2 v (toCurry s)) (toCurryPairs xs) curry-tools-v3.3.0/optimize/.cpm/packages/read-legacy/src/ReadShowTerm.pakcs.pl000066400000000000000000000010651377556325500274510ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Prolog implementation of builtins of module ReadShowTerm: % 'ReadShowTerm.prim_showQTerm'(Term,String) :- readShowTerm:prim_showQTerm(Term,String). 'ReadShowTerm.prim_showTerm'(Term,String) :- readShowTerm:prim_showTerm(Term,String). 'ReadShowTerm.prim_readsQTerm'(String,Term) :- readShowTerm:prim_readsQTerm(String,Term). 'ReadShowTerm.prim_readsUnqualifiedTerm'(Prefixes,String,Term) :- readShowTerm:prim_readsUnqualifiedTerm(Prefixes,String,Term). curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/000077500000000000000000000000001377556325500231315ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/LICENSE000066400000000000000000000027351377556325500241450ustar00rootroot00000000000000Copyright (c) 2018, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/README.md000066400000000000000000000002461377556325500244120ustar00rootroot00000000000000redblacktree ============ This package contains libraries implementing red-black trees and efficient access structures, like tables and sets, using red-black trees. curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/package.json000066400000000000000000000014641377556325500254240ustar00rootroot00000000000000{ "name": "redblacktree", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Libraries implementing red-black trees for tables and sets", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "random" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Data.RedBlackTree", "Data.Set.RBTree", "Data.Table.RBTree" ], "testsuite": { "src-dir": "test", "modules": [ "TestRedBlackTree" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/redblacktree.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/src/000077500000000000000000000000001377556325500237205ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/src/Data/000077500000000000000000000000001377556325500245715ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/src/Data/RedBlackTree.curry000066400000000000000000000221711377556325500301510ustar00rootroot00000000000000--------------------------------------------------------------------------- --- Library with an implementation of red-black trees: --- --- Serves as the base for both TableRBT and SetRBT --- All the operations on trees are generic, i.e., one has to provide --- order predicates on elements. --- --- @author Johannes Koj, Michael Hanus, Bernd Brassel --- @version December 2018 ---------------------------------------------------------------------------- module Data.RedBlackTree ( RedBlackTree, empty, isEmpty, lookup, update , toList, sortBy, newTreeLike, setInsertEquivalence, delete ) where ---------------------------------------------------------------------------- -- the main interface: --- A red-black tree consists of a tree structure and three order predicates. --- These predicates generalize the red black tree. They define --- 1) equality when inserting into the tree
--- eg for a set eqInsert is (==), --- for a multiset it is (\ _ _ -> False) --- for a lookUp-table it is ((==) . fst) --- 2) equality for looking up values --- eg for a set eqLookUp is (==), --- for a multiset it is (==) --- for a lookUp-table it is ((==) . fst) --- 3) the (less than) relation for the binary search tree data RedBlackTree a = RedBlackTree (a -> a -> Bool) -- equality for insertion (a -> a -> Bool) -- equality for lookup (a -> a -> Bool) -- lessThan for search (Tree a) -- contents --- The three relations are inserted into the structure by function empty. --- Returns an empty tree, i.e., an empty red-black tree --- augmented with the order predicates. empty :: (a -> a -> Bool) -> (a -> a -> Bool) -> (a -> a -> Bool) -> RedBlackTree a empty eqInsert eqLookUp lessThan = RedBlackTree eqInsert eqLookUp lessThan Empty --- Test on emptyness isEmpty :: RedBlackTree _ -> Bool isEmpty (RedBlackTree _ _ _ Empty) = True isEmpty (RedBlackTree _ _ _ (Tree _ _ _ _)) = False --- Creates a new empty red black tree from with the same ordering as a give one. newTreeLike :: RedBlackTree a -> RedBlackTree a newTreeLike (RedBlackTree eqIns eqLk lt _) = RedBlackTree eqIns eqLk lt Empty --- Returns an element if it is contained in a red-black tree. --- @param p - a pattern for an element to look up in the tree --- @param t - a red-black tree --- @return the contained True if p matches in t lookup :: a -> RedBlackTree a -> Maybe a lookup p (RedBlackTree _ eqLk lt t) = lookupTree eqLk lt p t lookupTree :: (a -> a -> Bool) -> (a -> a -> Bool) -> a -> Tree a -> Maybe a lookupTree _ _ _ Empty = Nothing lookupTree eq lt p (Tree _ e l r) | eq p e = Just e | lt p e = lookupTree eq lt p l | otherwise = lookupTree eq lt p r --- Updates/inserts an element into a RedBlackTree. update :: a -> RedBlackTree a -> RedBlackTree a update e (RedBlackTree eqIns eqLk lt t) = RedBlackTree eqIns eqLk lt (updateTree eqIns lt e t) updateTree :: (a -> a -> Bool) -> (a -> a -> Bool) -> a -> Tree a -> Tree a updateTree eq lt e t = let (Tree _ e2 l r) = upd t in Tree Black e2 l r where upd Empty = Tree Red e Empty Empty upd (Tree c e2 l r) | eq e e2 = Tree c e l r | lt e e2 = balanceL (Tree c e2 (upd l) r) | otherwise = balanceR (Tree c e2 l (upd r)) --- Deletes entry from red black tree. delete :: a -> RedBlackTree a -> RedBlackTree a delete e (RedBlackTree eqIns eqLk lt t) = RedBlackTree eqIns eqLk lt (blackenRoot (deleteTree eqLk lt e t)) where blackenRoot Empty = Empty blackenRoot (Tree _ x l r) = Tree Black x l r deleteTree :: (a -> a -> Prelude.Bool) -> (a -> a -> Prelude.Bool) -> a -> Tree a -> Tree a deleteTree _ _ _ Empty = Empty -- no error for non existence deleteTree eq lt e (Tree c e2 l r) | eq e e2 = if isEmptyTree l then addColor c r else if isEmptyTree r then addColor c l else let el = rightMost l in delBalanceL (Tree c el (deleteTree eq lt el l) r) | lt e e2 = delBalanceL (Tree c e2 (deleteTree eq lt e l) r) | otherwise = delBalanceR (Tree c e2 l (deleteTree eq lt e r)) where addColor DoublyBlack tree = tree -- should not occur addColor Red tree = tree addColor Black Empty = Empty addColor Black (Tree Red x lx rx) = Tree Black x lx rx addColor Black (Tree Black x lx rx) = Tree DoublyBlack x lx rx addColor Black (Tree DoublyBlack x lx rx) = Tree DoublyBlack x lx rx rightMost Empty = error "RedBlackTree.rightMost" rightMost (Tree _ x _ rx) = if isEmptyTree rx then x else rightMost rx --- Transforms a red-black tree into an ordered list of its elements. toList :: RedBlackTree a -> [a] toList (RedBlackTree _ _ _ t) = tree2listTree t tree2listTree :: Tree a -> [a] tree2listTree tree = t2l tree [] where t2l Empty es = es t2l (Tree _ e l r) es = t2l l (e : t2l r es) --- Generic sort based on insertion into red-black trees. --- The first argument is the order for the elements. sortBy :: Eq a => (a -> a -> Bool) -> [a] -> [a] sortBy cmp xs = toList (foldr update (empty (\_ _->False) (==) cmp) xs) --- For compatibility with old version only setInsertEquivalence :: (a -> a -> Bool) -> RedBlackTree a -> RedBlackTree a setInsertEquivalence eqIns (RedBlackTree _ eqLk lt t) = RedBlackTree eqIns eqLk lt t ---------------------------------------------------------------------------- -- implementation of red-black trees: rbt :: RedBlackTree a -> Tree a rbt (RedBlackTree _ _ _ t) = t --- The colors of a node in a red-black tree. data Color = Red | Black | DoublyBlack deriving Eq --- The structure of red-black trees. data Tree a = Tree Color a (Tree a) (Tree a) | Empty isEmptyTree :: Tree _ -> Bool isEmptyTree Empty = True isEmptyTree (Tree _ _ _ _) = False isBlack :: Tree _ -> Bool isBlack Empty = True isBlack (Tree c _ _ _) = c == Black isRed :: Tree _ -> Bool isRed Empty = False isRed (Tree c _ _ _) = c == Red isDoublyBlack :: Tree _ -> Bool isDoublyBlack Empty = True isDoublyBlack (Tree c _ _ _) = c == DoublyBlack left :: Tree a -> Tree a left Empty = error "RedBlackTree.left" left (Tree _ _ l _) = l right :: Tree a -> Tree a right Empty = error "RedBlackTree.right" right (Tree _ _ _ r) = r singleBlack :: Tree a -> Tree a singleBlack Empty = Empty singleBlack (Tree Red x l r) = Tree Red x l r singleBlack (Tree Black x l r) = Tree Black x l r singleBlack (Tree DoublyBlack x l r) = Tree Black x l r --- for the implementation of balanceL and balanceR refer to picture 3.5, page 27, --- Okasaki "Purely Functional Data Structures" balanceL :: Tree a -> Tree a balanceL tree | isRed leftTree && isRed (left leftTree) = let Tree _ z (Tree _ y (Tree _ x a b) c) d = tree in Tree Red y (Tree Black x a b) (Tree Black z c d) | isRed leftTree && isRed (right leftTree) = let Tree _ z (Tree _ x a (Tree _ y b c)) d = tree in Tree Red y (Tree Black x a b) (Tree Black z c d) | otherwise = tree where leftTree = left tree balanceR :: Tree a -> Tree a balanceR tree | isRed rightTree && isRed (right rightTree) = let Tree _ x a (Tree _ y b (Tree _ z c d)) = tree in Tree Red y (Tree Black x a b) (Tree Black z c d) | isRed rightTree && isRed (left rightTree) = let Tree _ x a (Tree _ z (Tree _ y b c) d) = tree in Tree Red y (Tree Black x a b) (Tree Black z c d) | otherwise = tree where rightTree = right tree --- balancing after deletion delBalanceL :: Tree a -> Tree a delBalanceL tree = if isDoublyBlack (left tree) then reviseLeft tree else tree reviseLeft :: Tree a -> Tree a reviseLeft tree | isEmptyTree r = tree | blackr && isRed (left r) = let Tree col x a (Tree _ z (Tree _ y b c) d) = tree in Tree col y (Tree Black x (singleBlack a) b) (Tree Black z c d) | blackr && isRed (right r) = let Tree col x a (Tree _ y b (Tree _ z c d)) = tree in Tree col y (Tree Black x (singleBlack a) b) (Tree Black z c d) | blackr = let Tree col x a (Tree _ y b c) = tree in Tree (if col==Red then Black else DoublyBlack) x (singleBlack a) (Tree Red y b c) | otherwise = let Tree _ x a (Tree _ y b c) = tree in Tree Black y (reviseLeft (Tree Red x a b)) c where r = right tree blackr = isBlack r delBalanceR :: Tree a -> Tree a delBalanceR tree = if isDoublyBlack (right tree) then reviseRight tree else tree reviseRight :: Tree a -> Tree a reviseRight tree | isEmptyTree l = tree | blackl && isRed (left l) = let Tree col x (Tree _ y (Tree _ z d c) b) a = tree in Tree col y (Tree Black z d c) (Tree Black x b (singleBlack a)) | blackl && isRed (right l) = let Tree col x (Tree _ z d (Tree _ y c b)) a = tree in Tree col y (Tree Black z d c) (Tree Black x b (singleBlack a)) | blackl = let Tree col x (Tree _ y c b) a = tree in Tree (if col==Red then Black else DoublyBlack) x (Tree Red y c b) (singleBlack a) | otherwise = let Tree _ x (Tree _ y c b) a = tree in Tree Black y c (reviseRight (Tree Red x b a)) where l = left tree blackl = isBlack l curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/src/Data/Set/000077500000000000000000000000001377556325500253245ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/src/Data/Set/RBTree.curry000066400000000000000000000053061377556325500275410ustar00rootroot00000000000000---------------------------------------------------------------------------- --- Library with an implementation of sets as red-black trees. --- --- All the operations on sets are generic, i.e., one has to provide --- an explicit order predicate `(<)` (less-than) on elements. --- --- @author Johannes Koj, Michael Hanus, Bernd Brassel --- @version December 2018 ---------------------------------------------------------------------------- module Data.Set.RBTree where import qualified Data.RedBlackTree as RBT import Data.Maybe (isJust) import Prelude hiding (empty) type SetRBT a = RBT.RedBlackTree a --- Returns an empty set, i.e., an empty red-black tree --- augmented with an order predicate. empty :: Eq a => (a -> a -> Bool) -> SetRBT a empty = RBT.empty (==) (==) --- Returns an empty set that uses the Ord's ordering predicate. emptyOrd :: Ord a => SetRBT a emptyOrd = empty (<) --- Test for an empty set. null :: SetRBT _ -> Bool null = RBT.isEmpty --- Returns true if an element is contained in a (red-black tree) set. --- @param e - an element to be checked for containment --- @param s - a set (represented as a red-black tree) --- @return True if e is contained in s member :: a -> SetRBT a -> Bool member e = isJust . (RBT.lookup e) --- Inserts an element into a set if it is not already there. insert :: a -> SetRBT a -> SetRBT a insert = RBT.update --- Inserts an element into a multiset. --- Thus, the same element can have several occurrences in the multiset. insertMulti :: Eq a => a -> SetRBT a -> SetRBT a insertMulti e = RBT.setInsertEquivalence (==) . RBT.update e . RBT.setInsertEquivalence (\ _ _ -> False) --- delete an element from a set. --- Deletes only a single element from a multi set delete :: a -> SetRBT a -> SetRBT a delete = RBT.delete --- Transforms a (red-black tree) set into an ordered list of its elements. toList :: SetRBT a -> [a] toList = RBT.toList --- Computes the union of two (red-black tree) sets. --- This is done by inserting all elements of the first set into the --- second set. union :: SetRBT a -> SetRBT a -> SetRBT a union s1 s2 = foldr insert s2 (toList s1) --- Computes the intersection of two (red-black tree) sets. --- This is done by inserting all elements of the first set --- contained in the second set into a new set, which order --- is taken from the first set. intersection :: SetRBT a -> SetRBT a -> SetRBT a intersection s1 s2 = foldr insert (RBT.newTreeLike s1) (filter (`member` s2) (toList s1)) --- Generic sort based on insertion into red-black trees. --- The first argument is the order for the elements. sortBy :: Eq a => (a -> a -> Bool) -> [a] -> [a] sortBy = RBT.sortBy curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/src/Data/Table/000077500000000000000000000000001377556325500256205ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/src/Data/Table/RBTree.curry000066400000000000000000000035421377556325500300350ustar00rootroot00000000000000--------------------------------------------------------------------------- --- Library with an implementation of tables as red-black trees: --- --- A table is a finite mapping from keys to values. --- All the operations on tables are generic, i.e., one has to provide --- an explicit order predicate on elements. --- Each inner node in the red-black tree contains a key-value association. --- --- @author Johannes Koj, Michael Hanus, Bernd Brassel --- @version December 2018 ---------------------------------------------------------------------------- module Data.Table.RBTree where import qualified Data.RedBlackTree as RBT import Prelude hiding (empty) ---------------------------------------------------------------------------- -- the main interface: type TableRBT key a = RBT.RedBlackTree (key,a) --- Returns an empty table, i.e., an empty red-black tree. empty :: Eq key => (key -> key -> Bool) -> TableRBT key _ empty lt = RBT.empty (\ x y -> fst x == fst y) (\ x y -> fst x == fst y) (\ x y -> lt (fst x) (fst y)) --- tests whether a given table is empty isEmpty :: TableRBT _ _ -> Bool isEmpty = RBT.isEmpty --- Looks up an entry in a table. --- @param k - a key under which a value is stored --- @param t - a table (represented as a red-black tree) --- @return (Just v) if v is the value stored with key k, --- otherwise Nothing is returned. lookup :: key -> TableRBT key a -> Maybe a lookup k = maybe Nothing (Just . snd) . RBT.lookup (k,failed) --- Inserts or updates an element in a table. update :: key -> a -> TableRBT key a -> TableRBT key a update k e = RBT.update (k,e) --- Transforms the nodes of red-black tree into a list. toList :: TableRBT key a -> [(key,a)] toList = RBT.toList delete :: key -> TableRBT key a -> TableRBT key a delete key = RBT.delete (key,failed) -- end of TableRBT curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/test/000077500000000000000000000000001377556325500241105ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/redblacktree/test/TestRedBlackTree.curry000066400000000000000000000023641377556325500303320ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Some tests for library RedBlackTree. --- --- To run all tests automatically by the currycheck tool, use the command: --- "curry check TestRedBlackTree" --- --- @author Bernd Brassel, Michael Hanus --- @version December 2018 ------------------------------------------------------------------------------ import Data.List (nub) import Test.Prop import System.Random import Data.RedBlackTree as RBT intList2Tree = foldr update (RBT.empty (\ _ _ -> False) (==) (<)) rndTree n = getRandomSeed >>= return . nub . take n . (flip nextIntRange 100000) >>= \is -> return (intList2Tree is,is) sorted [] = True sorted [_] = True sorted (x:y:xs) = x < y && sorted (y:xs) rndDels n x = getRandomSeed >>= return . take n . (flip nextIntRange x) deleteTest t _ [] = t deleteTest t is (x:xs) = deleteTest (delete (is !! x) t) is xs testIO m n = rndTree m >>= \ (t,is) -> rndDels n (length is) >>= \ ds -> let newt = deleteTest t is ds in return (sorted (toList newt)) -- Create tree with 1000 random entries, then randomly delete 100. -- Test, if result is sorted. testCreateRBTreeAndDeleteAndCheckSorted = (testIO 1000 100) `returns` True curry-tools-v3.3.0/optimize/.cpm/packages/scc/000077500000000000000000000000001377556325500212525ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/scc/LICENSE000066400000000000000000000026771377556325500222730ustar00rootroot00000000000000Copyright (c) 1998-2007, Wolfgang Lux All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. None of the names of the copyright holders and 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 THE COPYRIGHT OWNER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/scc/README.md000066400000000000000000000001361377556325500225310ustar00rootroot00000000000000scc === This package provides a library `Data.SCC` to compute strongly connected components. curry-tools-v3.3.0/optimize/.cpm/packages/scc/package.json000066400000000000000000000013021377556325500235340ustar00rootroot00000000000000{ "name": "scc", "version": "3.0.0", "author": "Wolfgang Lux ", "maintainer": "Michael Hanus ", "synopsis": "Computing strongly connected components", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "redblacktree" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Data.SCC" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/scc.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/scc/src/000077500000000000000000000000001377556325500220415ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/scc/src/Data/000077500000000000000000000000001377556325500227125ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/scc/src/Data/SCC.curry000066400000000000000000000060251377556325500244130ustar00rootroot00000000000000--- ---------------------------------------------------------------------------- --- Computing strongly connected components --- --- Copyright (c) 2000 - 2003, Wolfgang Lux --- See LICENSE for the full license. --- --- The function `scc` computes the strongly connected components of a list --- of entities in two steps. First, the list is topologically sorted --- "downwards" using the *defines* relation. --- Then the resulting list is sorted "upwards" using the *uses* relation --- and partitioned into the connected components. Both relations --- are computed within this module using the bound and free names of each --- declaration. --- --- In order to avoid useless recomputations, the code in the module first --- decorates the declarations with their bound and free names and a --- unique number. The latter is only used to provide a trivial ordering --- so that the declarations can be used as set elements. --- --- @author Wolfgang Lux --- ---------------------------------------------------------------------------- module Data.SCC (scc) where import Data.Set.RBTree (empty, member, insert) import Prelude hiding (empty) data Node a b = Node Int [b] [b] a deriving Eq cmpNode :: Node a b -> Node a b -> Bool cmpNode n1 n2 = key n1 < key n2 key :: Node a b -> Int key (Node k _ _ _) = k bvs :: Node a b -> [b] bvs (Node _ bs _ _) = bs fvs :: Node a b -> [b] fvs (Node _ _ fs _) = fs node :: Node a b -> a node (Node _ _ _ n) = n --- Computes the strongly connected components of a list --- of entities. To be flexible, we distinguish the nodes and --- the entities defined in this node. --- --- @param defines - maps each node to the entities defined in this node --- @param uses - maps each node to the entities used in this node --- @param nodes - the list of nodes which should be sorted into --- strongly connected components --- @return the strongly connected components of the list of nodes scc :: (Eq a, Eq b) => (a -> [b]) -- ^ entities defined by node -> (a -> [b]) -- ^ entities used by node -> [a] -- ^ list of nodes -> [[a]] -- ^ strongly connected components scc bvs' fvs' = map (map node) . tsort' . tsort . zipWith wrap [0 ..] where wrap i n = Node i (bvs' n) (fvs' n) n tsort :: (Eq a, Eq b) => [Node a b] -> [Node a b] tsort xs = snd (dfs xs (empty cmpNode) []) where dfs [] marks stack = (marks, stack) dfs (x : xs') marks stack | x `member` marks = dfs xs' marks stack | otherwise = dfs xs' marks' (x : stack') where (marks', stack') = dfs (defs x) (x `insert` marks) stack defs x1 = filter (any (`elem` fvs x1) . bvs) xs tsort' :: (Eq a, Eq b) => [Node a b] -> [[Node a b]] tsort' xs = snd (dfs xs (empty cmpNode) []) where dfs [] marks stack = (marks, stack) dfs (x : xs') marks stack | x `member` marks = dfs xs' marks stack | otherwise = dfs xs' marks' ((x : concat stack') : stack) where (marks', stack') = dfs (uses x) (x `insert` marks) [] uses x1 = filter (any (`elem` bvs x1) . fvs) xs curry-tools-v3.3.0/optimize/.cpm/packages/socket/000077500000000000000000000000001377556325500217725ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/socket/LICENSE000066400000000000000000000027351377556325500230060ustar00rootroot00000000000000Copyright (c) 2018, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/socket/README.md000066400000000000000000000001571377556325500232540ustar00rootroot00000000000000socket ====== This package contains the library `Network.Socket` to support network programming with sockets. curry-tools-v3.3.0/optimize/.cpm/packages/socket/examples/000077500000000000000000000000001377556325500236105ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/socket/examples/addserver.curry000066400000000000000000000025161377556325500266610ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A simple "addition" server to test the Socket library. --- --- @author Michael Hanus --- @version November 2020 ------------------------------------------------------------------------------ import Network.Socket import System.IO -- Choose a free port number: portnr :: Int portnr = 32145 sendTo host msg = do h <- connectToSocket host portnr hPutStr h msg hClose h stopServer host = sendTo host "TERMINATE\n" -- An "addition" server: addServer = do socket <- listenOn portnr putStrLn $ "Serving port: " ++ show portnr addServeSocket socket addServeSocket socket = do (chost,stream) <- accept socket putStrLn $ "Connection from "++chost serverLoop stream where serverLoop h = do l1 <- hGetLine h if l1=="TERMINATE" then do hClose h close socket else do l2 <- hGetLine h hPutStrLn h (show ((read l1 :: Int) + (read l2 :: Int))) hClose h addServeSocket socket addClient :: String -> Int -> Int -> IO () addClient host x y = do h <- connectToSocket host portnr hPutStr h (unlines (map show [x,y])) hFlush h answer <- hGetLine h putStrLn $ "Answer: "++answer hClose h {- Test with PAKCS: :fork addServer addClient "localhost" 3 4 stopServer "localhost" -} curry-tools-v3.3.0/optimize/.cpm/packages/socket/examples/addtimeoutserver.curry000066400000000000000000000027641377556325500302750ustar00rootroot00000000000000------------------------------------------------------------------------------ --- A simple "addition" server to test the Socket library with time limits --- on socket connections. --- --- @author Michael Hanus --- @version November 2020 ------------------------------------------------------------------------------ import System.IO import Network.Socket -- Choose a free port number: portnr = 32145 sendTo host msg = do h <- connectToSocket host portnr hPutStr h msg hClose h stopServer host = sendTo host "TERMINATE\n" -- An "addition" server: addServer = do socket <- listenOn portnr putStrLn $ "Serving port: " ++ show portnr addServeSocket socket addServeSocket socket = do conn <- waitForSocketAccept socket 1000 addServeSocketTest socket conn addServeSocketTest socket Nothing = do putStrLn "Timeout" addServeSocket socket addServeSocketTest socket (Just (chost,stream)) = do putStrLn $ "Connection from "++chost serverLoop stream where serverLoop h = do l1 <- hGetLine h if l1=="TERMINATE" then do hClose h close socket else do l2 <- hGetLine h hPutStrLn h (show ((read l1 :: Int) + (read l2 :: Int))) hClose h addServeSocket socket addClient host x y = do h <- connectToSocket host portnr hPutStr h (unlines (map show [x,y])) hFlush h answer <- hGetLine h putStrLn $ "Answer: "++answer hClose h {- Test with PAKCS: :fork addServer addClient "localhost" 3 4 stopServer "localhost" -} curry-tools-v3.3.0/optimize/.cpm/packages/socket/examples/httpget.curry000066400000000000000000000013611377556325500263560ustar00rootroot00000000000000-- A simple example showing the direct connection to Unix sockets -- by using the `Network.Socket` library. import System.IO import Network.Socket(connectToSocket) -- An I/O action that shows the answer of a web server to the -- request of a document: httpGet :: String -> String -> IO () httpGet host doc = do str <- connectToSocket host 80 hPutStr str ("GET " ++ doc ++ " HTTP/1.0\n\n") hFlush str showStreamContents str -- Show the complete contents of an output stream: showStreamContents :: Handle -> IO () showStreamContents str = do b <- hIsEOF str if b then return () else do l <- hGetLine str putStrLn l showStreamContents str -- A test: main :: IO () main = httpGet "www.google.com" "/index.html" curry-tools-v3.3.0/optimize/.cpm/packages/socket/package.json000066400000000000000000000011421377556325500242560ustar00rootroot00000000000000{ "name": "socket", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library for programming with sockets", "category": [ "Network" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Network.Socket" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/socket.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/socket/src/000077500000000000000000000000001377556325500225615ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/socket/src/Network/000077500000000000000000000000001377556325500242125ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/socket/src/Network/Socket.curry000066400000000000000000000061721377556325500265360ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library to support network programming with sockets. --- In standard applications, the server side uses the operations --- `listenOn` and `socketAccept` to provide some service --- on a socket, and the client side uses the operation --- `connectToSocket` to request a service. --- --- @author Michael Hanus --- @version December 2018 ------------------------------------------------------------------------------ module Network.Socket (Socket, listenOn, listenOnFresh, accept, waitForSocketAccept, close, connectToSocket) where import System.IO (Handle) --- The abstract type of sockets. external data Socket --------------------------------------------------------------------- -- Server side operations: --- Creates a server side socket bound to a given port number. listenOn :: Int -> IO Socket listenOn port = prim_listenOn $# port prim_listenOn :: Int -> IO Socket prim_listenOn external --- Creates a server side socket bound to a free port. --- The port number and the socket is returned. listenOnFresh :: IO (Int,Socket) listenOnFresh external --- Returns a connection of a client to a socket. --- The connection is returned as a pair consisting of a string identifying --- the client (the format of this string is implementation-dependent) --- and a handle to a stream communication with the client. --- The handle is both readable and writable. --- Only IPv4 connections are currently possible. accept :: Socket -> IO (String,Handle) accept s = prim_socketAccept $## s prim_socketAccept :: Socket -> IO (String,Handle) prim_socketAccept external --- Waits until a connection of a client to a socket is available. --- If no connection is available within the time limit, it returns Nothing, --- otherwise the connection is returned as a pair consisting --- of a string identifying the client --- (the format of this string is implementation-dependent) --- and a handle to a stream communication with the client. --- @param socket - a socket --- @param timeout - milliseconds to wait for input (< 0 : no time out) waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle)) waitForSocketAccept s timeout = (prim_waitForSocketAccept $## s) $# timeout prim_waitForSocketAccept :: Socket -> Int -> IO (Maybe (String,Handle)) prim_waitForSocketAccept external --- Closes a server socket. close :: Socket -> IO () close s = prim_sClose $## s prim_sClose :: Socket -> IO () prim_sClose external --------------------------------------------------------------------- -- Client side operations: --- Creates a new connection to a Unix socket. --- Only IPv4 connections are currently possible. --- @param host - the host name of the connection --- @param port - the port number of the connection --- @return the handle of the stream (connected to the port port@host) --- which is both readable and writable connectToSocket :: String -> Int -> IO Handle connectToSocket host port = (prim_connectToSocket $## host) $# port prim_connectToSocket :: String -> Int -> IO Handle prim_connectToSocket external --------------------------------------------------------------------- curry-tools-v3.3.0/optimize/.cpm/packages/socket/src/Network/Socket.kics2000066400000000000000000000114411377556325500264000ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses, CPP #-} import Control.Concurrent import Control.Monad (when) import System.IO #if __GLASGOW_HASKELL__ < 780 import Network #endif import Network.Socket hiding (sClose) type C_Socket = PrimData Socket ------------------------------------------------- #if __GLASGOW_HASKELL__ < 780 acceptOld :: Socket -> IO (Handle, HostName, PortNumber) acceptOld = Network.accept instance ConvertCurryHaskell Curry_Prelude.C_Int PortID where toCurry (PortNumber i) = toCurry (toInteger i) fromCurry i = PortNumber (fromInteger (fromCurry i)) external_d_C_listenOnFresh :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_Int C_Socket) external_d_C_listenOnFresh _ _ = toCurry listenOnFreshPort where listenOnFreshPort :: IO (PortID,Socket) listenOnFreshPort = do s <- listenOn (PortNumber aNY_PORT) p <- socketPort s return (p,s) ------------------------------------------------- #else ------------------------------------------------- acceptOld :: Socket -> IO (Handle, HostName, PortNumber) acceptOld sock = do (s, peer) <- Network.Socket.accept sock p <- socketPort s h <- socketToHandle s ReadWriteMode -- s is invalid after this point. return (h, show peer, p) listenOn :: PortNumber -> IO Socket listenOn pn = do -- AI_PASSIVE is needed when the address should be used for bind/listenOn -- AF_INET forces IPv4. This is crucial, because some -- systems crashed with the old Implementation that allowed IPv6 -- As soon as IPv6 is needed, someone has to look into this issue again. let hints = defaultHints { addrFlags = [AI_PASSIVE], addrFamily = AF_INET } addr:_ <- getAddrInfo (Just hints) Nothing (Just (show pn)) sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) setSocketOption sock ReuseAddr 1 fd <- fdSocket sock setCloseOnExecIfNeeded fd Network.Socket.bind sock (addrAddress addr) listen sock maxListenQueue return sock sClose :: Socket -> IO () sClose = close connectTo :: HostName -> PortNumber -> IO Handle connectTo s a = do -- for AF_INET see above let hints = defaultHints { addrFamily = AF_INET } addr:_ <- getAddrInfo (Just hints) (Just s) (Just (show a)) sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) connect sock (addrAddress addr) socketToHandle sock ReadWriteMode instance ConvertCurryHaskell Curry_Prelude.C_Int PortNumber where toCurry i = toCurry (toInteger i) fromCurry i = fromInteger (fromCurry i) external_d_C_listenOnFresh :: Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_Int C_Socket) external_d_C_listenOnFresh _ _ = toCurry listenOnFreshPort where listenOnFreshPort :: IO (PortNumber,Socket) listenOnFreshPort = do s <- listenOn defaultPort p <- socketPort s return (p,s) #endif ------------------------------------------------- external_d_C_prim_listenOn :: Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO C_Socket external_d_C_prim_listenOn i _ _ = toCurry listenOn i external_d_C_prim_socketAccept :: C_Socket -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.OP_Tuple2 Curry_Prelude.C_String Curry_IO.C_Handle) external_d_C_prim_socketAccept socket _ _ = toCurry (\s -> acceptOld s >>= \ (h,s,_) -> return (s,OneHandle h)) socket external_d_C_prim_waitForSocketAccept :: C_Socket -> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO (Curry_Prelude.C_Maybe (Curry_Prelude.OP_Tuple2 (Curry_Prelude.OP_List Curry_Prelude.C_Char) Curry_IO.C_Handle)) external_d_C_prim_waitForSocketAccept s i _ _ = toCurry wait s i wait :: Socket -> Int -> IO (Maybe (String, CurryHandle)) wait s t = if t < 0 then acceptOld s >>= \ (h, s, _) -> return (Just (s, OneHandle h)) else do mv <- newEmptyMVar tacc <- forkIO (acceptOld s >>= \ (h, s, _) -> putMVar mv (Just (s, OneHandle h))) ttim <- forkIO (delay ((fromIntegral t :: Integer) * 1000) >> putMVar mv Nothing) res <- takeMVar mv maybe (killThread tacc) (\_ -> killThread ttim) res return res -- Like 'threadDelay', but not bounded by an 'Int' delay :: Integer -> IO () delay time = do let maxWait = min time $ toInteger (maxBound :: Int) threadDelay $ fromInteger maxWait when (maxWait /= time) $ delay (time - maxWait) external_d_C_prim_sClose :: C_Socket -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_Prelude.OP_Unit external_d_C_prim_sClose s _ _ = toCurry sClose s external_d_C_prim_connectToSocket :: Curry_Prelude.C_String -> Curry_Prelude.C_Int -> Cover -> ConstStore -> Curry_Prelude.C_IO Curry_IO.C_Handle external_d_C_prim_connectToSocket str i _ _ = toCurry (\ s i -> connectTo s i >>= return . OneHandle) str i curry-tools-v3.3.0/optimize/.cpm/packages/socket/src/Network/Socket.pakcs.pl000066400000000000000000000027061377556325500271040ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Prolog implementation of builtins of module Network.Socket: % % create a server side socket bound to a port number. 'Network.Socket.prim_listenOn'(Port,Socket) :- listenOnNewSocket(Port,_,Socket). % create a server side socket with a fresh port. 'Network.Socket.prim_listenOnFresh'('Prelude.(,)'(Port,Socket)) :- listenOnNewSocket(Port,_,Socket). % return the first connection to a socket as a read/write stream: 'Network.Socket.prim_socketAccept'(Socket, 'Prelude.(,)'(ClientS,'$stream'('$inoutstream'(InStream,OutStream)))) :- socketAccept(Socket,Client,InStream,OutStream), atom2String(Client,ClientS), !. % return a connection to a socket within a time limit as a read/write stream, % otherwise Nothing: 'Network.Socket.prim_waitForSocketAccept'(Socket,TimeOut,Result) :- (waitForSocketClientStream(Socket,TimeOut,Client,InStream,OutStream) -> atom2String(Client,ClientS), Result = 'Prelude.Just'('Prelude.(,)'(ClientS, '$stream'('$inoutstream'(InStream,OutStream)))) ; Result = 'Prelude.Nothing'). % Closes a server socket. 'Network.Socket.prim_sClose'(Socket,'Prelude.()') :- socketClose(Socket). % open a connection to a Unix socket: 'Network.Socket.prim_connectToSocket'(SHst,SNr, '$stream'('$inoutstream'(InStream,OutStream))) :- string2Atom(SHst,Host), !, connect2socket(Host,SNr,InStream,OutStream). curry-tools-v3.3.0/optimize/.cpm/packages/time/000077500000000000000000000000001377556325500214405ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/time/LICENSE000066400000000000000000000027351377556325500224540ustar00rootroot00000000000000Copyright (c) 2020, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/time/package.json000066400000000000000000000012251377556325500237260ustar00rootroot00000000000000{ "name": "time", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "Library for handling date and time information.", "category": [ "Data" ], "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Data.Time" ], "testsuite": { "src-dir": "test", "modules": [ "TestTime" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/time.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/time/src/000077500000000000000000000000001377556325500222275ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/time/src/Data/000077500000000000000000000000001377556325500231005ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/time/src/Data/Time.curry000066400000000000000000000143251377556325500250710ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for handling date and time information. --- --- @author Michael Hanus --- @version January 2018 ------------------------------------------------------------------------------ module Data.Time ( ClockTime, CalendarTime(..) , ctYear, ctMonth, ctDay, ctHour, ctMin, ctSec, ctTZ , getClockTime, getLocalTime, toUTCTime, toClockTime, toCalendarTime , clockTimeToInt, calendarTimeToString, toDayString, toTimeString , addSeconds, addMinutes, addHours, addDays, addMonths, addYears , daysOfMonth, validDate, compareCalendarTime, compareClockTime ) where --- ClockTime represents a clock time in some internal representation. data ClockTime = CTime Int deriving (Eq, Ord, Show, Read) --- A calendar time is presented in the following form: --- (CalendarTime year month day hour minute second timezone) --- where timezone is an integer representing the timezone as a difference --- to UTC time in seconds. data CalendarTime = CalendarTime Int Int Int Int Int Int Int deriving (Eq, Ord, Show, Read) --- The year of a calendar time. ctYear :: CalendarTime -> Int ctYear (CalendarTime y _ _ _ _ _ _) = y --- The month of a calendar time. ctMonth :: CalendarTime -> Int ctMonth (CalendarTime _ m _ _ _ _ _) = m --- The day of a calendar time. ctDay :: CalendarTime -> Int ctDay (CalendarTime _ _ d _ _ _ _) = d --- The hour of a calendar time. ctHour :: CalendarTime -> Int ctHour (CalendarTime _ _ _ h _ _ _) = h --- The minute of a calendar time. ctMin :: CalendarTime -> Int ctMin (CalendarTime _ _ _ _ m _ _) = m --- The second of a calendar time. ctSec :: CalendarTime -> Int ctSec (CalendarTime _ _ _ _ _ s _) = s --- The time zone of a calendar time. The value of the --- time zone is the difference to UTC time in seconds. ctTZ :: CalendarTime -> Int ctTZ (CalendarTime _ _ _ _ _ _ tz) = tz --- Returns the current clock time. getClockTime :: IO ClockTime getClockTime external --- Returns the local calendar time. getLocalTime :: IO CalendarTime getLocalTime = do ctime <- getClockTime toCalendarTime ctime --- Transforms a clock time into a unique integer. --- It is ensured that clock times that differs in at least one second --- are mapped into different integers. clockTimeToInt :: ClockTime -> Int clockTimeToInt (CTime i) = i --- Transforms a clock time into a calendar time according to the local time --- (if possible). Since the result depends on the local environment, --- it is an I/O operation. toCalendarTime :: ClockTime -> IO CalendarTime toCalendarTime ctime = prim_toCalendarTime $## ctime prim_toCalendarTime :: ClockTime -> IO CalendarTime prim_toCalendarTime external --- Transforms a clock time into a standard UTC calendar time. --- Thus, this operation is independent on the local time. toUTCTime :: ClockTime -> CalendarTime toUTCTime ctime = prim_toUTCTime $## ctime prim_toUTCTime :: ClockTime -> CalendarTime prim_toUTCTime external --- Transforms a calendar time (interpreted as UTC time) into a clock time. toClockTime :: CalendarTime -> ClockTime toClockTime d = prim_toClockTime $## d prim_toClockTime :: CalendarTime -> ClockTime prim_toClockTime external --- Transforms a calendar time into a readable form. calendarTimeToString :: CalendarTime -> String calendarTimeToString ctime@(CalendarTime y mo d _ _ _ _) = shortMonths!!(mo-1) ++ " " ++ show d ++ " " ++ toTimeString ctime ++ " " ++ show y where shortMonths = ["Jan","Feb","Mar","Apr","May","Jun", "Jul","Aug","Sep","Oct","Nov","Dec"] --- Transforms a calendar time into a string containing the day, e.g., --- "September 23, 2006". toDayString :: CalendarTime -> String toDayString (CalendarTime y mo d _ _ _ _) = longMonths!!(mo-1) ++ " " ++ show d ++ ", " ++ show y where longMonths = ["January","February","March","April","May","June","July", "August","September","October","November","December"] --- Transforms a calendar time into a string containing the time. toTimeString :: CalendarTime -> String toTimeString (CalendarTime _ _ _ h mi s _) = digit2 h ++":"++ digit2 mi ++":"++ digit2 s where digit2 n = if n<10 then ['0',chr(ord '0' + n)] else show n --- Adds seconds to a given time. addSeconds :: Int -> ClockTime -> ClockTime addSeconds n (CTime ctime) = CTime (ctime + n) --- Adds minutes to a given time. addMinutes :: Int -> ClockTime -> ClockTime addMinutes n (CTime ctime) = CTime (ctime + (n*60)) --- Adds hours to a given time. addHours :: Int -> ClockTime -> ClockTime addHours n (CTime ctime) = CTime (ctime + (n*3600)) --- Adds days to a given time. addDays :: Int -> ClockTime -> ClockTime addDays n (CTime ctime) = CTime (ctime + (n*86400)) --- Adds months to a given time. addMonths :: Int -> ClockTime -> ClockTime addMonths n ctime = let CalendarTime y mo d h mi s tz = toUTCTime ctime nmo = (mo-1+n) `mod` 12 + 1 in if nmo>0 then addYears ((mo-1+n) `div` 12) (toClockTime (CalendarTime y nmo d h mi s tz)) else addYears ((mo-1+n) `div` 12 - 1) (toClockTime (CalendarTime y (nmo+12) d h mi s tz)) --- Adds years to a given time. addYears :: Int -> ClockTime -> ClockTime addYears n ctime = if n==0 then ctime else let CalendarTime y mo d h mi s tz = toUTCTime ctime in toClockTime (CalendarTime (y+n) mo d h mi s tz) --- Gets the days of a month in a year. daysOfMonth :: Int -> Int -> Int daysOfMonth mo yr = if mo/=2 then [31,28,31,30,31,30,31,31,30,31,30,31] !! (mo-1) else if yr `mod` 4 == 0 && (yr `mod` 100 /= 0 || yr `mod` 400 == 0) then 29 else 28 --- Is a date consisting of year/month/day valid? validDate :: Int -> Int -> Int -> Bool validDate y m d = m > 0 && m < 13 && d > 0 && d <= daysOfMonth m y --- Compares two dates (don't use it, just for backward compatibility!). compareDate :: CalendarTime -> CalendarTime -> Ordering compareDate = compareCalendarTime --- Compares two calendar times. compareCalendarTime :: CalendarTime -> CalendarTime -> Ordering compareCalendarTime ct1 ct2 = compareClockTime (toClockTime ct1) (toClockTime ct2) --- Compares two clock times. compareClockTime :: ClockTime -> ClockTime -> Ordering compareClockTime (CTime time1) (CTime time2) | time1time2 = GT | otherwise = EQ curry-tools-v3.3.0/optimize/.cpm/packages/time/src/Data/Time.kics2000066400000000000000000000050431377556325500247350ustar00rootroot00000000000000{-# LANGUAGE MultiParamTypeClasses #-} import qualified System.Time as T import qualified Data.Time.Clock as Clock import qualified Data.Time.Calendar as Cal instance ConvertCurryHaskell C_ClockTime T.ClockTime where fromCurry (C_CTime i) = T.TOD (fromCurry i) 0 toCurry (T.TOD i _) = C_CTime (toCurry i) instance ConvertCurryHaskell C_CalendarTime T.CalendarTime where fromCurry (C_CalendarTime y m d h min s tz) = T.CalendarTime (fromCurry y) (toEnum (fromCurry m - 1)) (fromCurry d) (fromCurry h) (fromCurry min) (fromCurry s) 0 undefined undefined undefined (fromCurry tz) undefined toCurry (T.CalendarTime y m d h min s _ _ _ _ tz _) = C_CalendarTime (toCurry y) (toCurry (fromEnum m + 1)) (toCurry d) (toCurry h) (toCurry min) (toCurry s) (toCurry tz) instance ConvertCurryHaskell C_ClockTime Clock.UTCTime where fromCurry ct = let (T.CalendarTime y m d h min s _ _ _ _ tz _) = T.toUTCTime (fromCurry ct) in fromIntegral tz `Clock.addUTCTime` Clock.UTCTime (Cal.fromGregorian (toInteger y) (fromEnum m + 1) d) (Clock.secondsToDiffTime (toInteger ((h * 60 + min) * 60 + s))) toCurry (Clock.UTCTime day diff) = let (y,m,d) = Cal.toGregorian day in toCurry (T.addToClockTime (T.TimeDiff 0 0 0 0 0 (round (toRational diff)) 0) (T.toClockTime (T.CalendarTime (fromIntegral y) (toEnum (m - 1)) d 0 0 0 0 undefined undefined undefined 0 undefined))) external_d_C_getClockTime :: Cover -> ConstStore -> Curry_Prelude.C_IO C_ClockTime external_d_C_getClockTime _ _ = toCurry T.getClockTime external_d_C_prim_toCalendarTime :: C_ClockTime -> Cover -> ConstStore -> Curry_Prelude.C_IO C_CalendarTime external_d_C_prim_toCalendarTime ct _ _ = toCurry T.toCalendarTime ct external_d_C_prim_toUTCTime :: C_ClockTime -> Cover -> ConstStore -> C_CalendarTime external_d_C_prim_toUTCTime ct _ _ = toCurry T.toUTCTime ct external_d_C_prim_toClockTime :: C_CalendarTime -> Cover -> ConstStore -> C_ClockTime external_d_C_prim_toClockTime ct _ _ = toCurry T.toClockTime ct curry-tools-v3.3.0/optimize/.cpm/packages/time/src/Data/Time.pakcs.pl000066400000000000000000000014771377556325500254440ustar00rootroot00000000000000%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Definitions of builtins of module Data.Time: % 'Data.Time.getClockTime'('Data.Time.CTime'(CTime)) :- currentClockTime(CTime). 'Data.Time.prim_toCalendarTime'('Data.Time.CTime'(ClockTime), 'Data.Time.CalendarTime'(Year,Month,Day,Hour,Min,Sec,TZ)) :- clocktime2localtime(ClockTime,Year,Month,Day,Hour,Min,Sec,TZ). 'Data.Time.prim_toUTCTime'('Data.Time.CTime'(ClockTime), 'Data.Time.CalendarTime'(Year,Month,Day,Hour,Min,Sec,0)) :- clocktime2utctime(ClockTime,Year,Month,Day,Hour,Min,Sec). 'Data.Time.prim_toClockTime'('Data.Time.CalendarTime'(Year,Month,Day,Hour, Min,Sec,TZ), 'Data.Time.CTime'(CTime)) :- date2clocktime(Year,Month,Day,Hour,Min,Sec,TZ,CTime). curry-tools-v3.3.0/optimize/.cpm/packages/time/test/000077500000000000000000000000001377556325500224175ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/time/test/TestTime.curry000066400000000000000000000012551377556325500252460ustar00rootroot00000000000000----------------------------------------------------------------------------- -- A few tests for module Data.Time ----------------------------------------------------------------------------- module TestTime where import Test.Prop import Data.Time aTime :: CalendarTime aTime = CalendarTime 2020 2 5 13 51 4 3600 testDayString :: Prop testDayString = toDayString aTime -=- "February 5, 2020" testTimeString :: Prop testTimeString = toTimeString aTime -=- "13:51:04" testDaysOfMonth1 :: Prop testDaysOfMonth1 = daysOfMonth 2 2020 -=- 29 testDaysOfMonth2 :: Prop testDaysOfMonth2 = daysOfMonth 2 1900 -=- 28 testDaysOfMonth3 :: Prop testDaysOfMonth3 = daysOfMonth 2 2000 -=- 29 curry-tools-v3.3.0/optimize/.cpm/packages/wl-pprint/000077500000000000000000000000001377556325500224365ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/wl-pprint/LICENSE000066400000000000000000000027351377556325500234520ustar00rootroot00000000000000Copyright (c) 2017, All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/wl-pprint/README.md000066400000000000000000000011561377556325500237200ustar00rootroot00000000000000wl-pprint ========= This package provides pretty printing combinators for Curry. It uses the interface of Daan Leijen's library for Haskell (http://www.cs.uu.nl/~daan/download/pprint/pprint.html). The linear-time bounded implementation is based on an approach by Olaf Chitil (http://www.cs.kent.ac.uk/pubs/2006/2381/index.html). Note that the implementation of `fill` and `fillBreak` is not linear-time bounded Besides well-known pretty printing combinators, this library also supports ANSI escape codes for formatting and colorisation of documents in text terminals (see https://en.wikipedia.org/wiki/ANSI_escape_code). curry-tools-v3.3.0/optimize/.cpm/packages/wl-pprint/package.json000066400000000000000000000020141377556325500247210ustar00rootroot00000000000000{ "name": "wl-pprint", "version": "3.0.0", "author": "Sebastian Fischer , Bjoern Peemoeller , Jan Rasmus Tikovsky ", "synopsis": "Pretty printing combinators for Curry (inspired by Leijen's library for Haskell)", "category": [ "Printing" ], "description": "This package includes a library providing general combinators for pretty printing. The interface is inspired by Daan Leijen's pretty printing library for Haskell and the linear-time bounded implementation is based on an approach by Olaf Chitil.", "license": "BSD-3-Clause", "licenseFile": "LICENSE", "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "queue": ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "Text.Pretty" ], "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/wl-pprint.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/.cpm/packages/wl-pprint/src/000077500000000000000000000000001377556325500232255ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/wl-pprint/src/Text/000077500000000000000000000000001377556325500241515ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/wl-pprint/src/Text/Pretty.curry000066400000000000000000001154231377556325500265340ustar00rootroot00000000000000------------------------------------------------------------------------------ --- This library provides pretty printing combinators. --- The interface is that of --- [Daan Leijen's library](), (<+>), ($$), (<$+$>), (), (<$$>), (), (<$!$>), -- list combinators compose, hsep, vsep, vsepBlank, fillSep, sep, hcat, vcat, fillCat, cat, punctuate, encloseSep, encloseSepSpaced, hEncloseSep, fillEncloseSep, fillEncloseSepSpaced, list, listSpaced, set, setSpaced, tupled, tupledSpaced, semiBraces, semiBracesSpaced, -- bracketing combinators enclose, squotes, dquotes, bquotes, parens, parensIf, angles, braces, brackets, -- fillers fill, fillBreak, -- primitive type documents bool, char, string, int, float, -- character documents lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket, squote, dquote, semi, colon, comma, space, dot, backslash, equals, larrow, rarrow, doubleArrow, doubleColon, bar, at, tilde, -- formatting combinators bold, faint, blinkSlow, blinkRapid, italic, underline, crossout, inverse, -- colorisation combinators black, red, green, yellow, blue, magenta, cyan, white, bgBlack, bgRed, bgGreen, bgYellow, bgBlue, bgMagenta, bgCyan, bgWhite, -- Pretty class Pretty (..) ) where import Text.PrettyImpl infixl 5 $$, <$$>, , , <$!$>, <$+$> infixl 6 <>, <+> --- Standard printing with a column length of 80. pPrint :: Doc -> String pPrint = showWidth 80 --- The empty document --- @return an empty document empty :: Doc empty = Doc Empty --- Is the document empty? isEmpty :: Doc -> Bool isEmpty (Doc d) = isEmptyText (d EOD) where isEmptyText t = case t of Empty EOD -> True _ -> False --- The document `(text s)` contains the literal string `s`. --- The string shouldn't contain any newline ('\n') characters. --- If the string contains newline characters, --- the function `string` should be used. --- @param s - a string without newline (`'\n'`) characters --- @return a document which contains the literal string text :: String -> Doc text s = Doc (Text s) --- The document `(linesep s)` advances to the next line and indents --- to the current nesting level. Document `(linesep s)` --- behaves like `(text s)` if the line break is undone by `group`. --- @param s - a string --- @return a document which advances to the next line or behaves --- like `(text s)` linesep :: String -> Doc linesep = Doc . LineBreak . Just --- The document `hardline` advances to the next line and indents --- to the current nesting level. `hardline` cannot be undone by `group`. --- @return a document which advances to the next line hardline :: Doc hardline = Doc (LineBreak Nothing) --- The document `line` advances to the next line and indents to the current --- nesting level. Document `line` behaves like `(text " ")` if the line break --- is undone by `group`. --- @return a document which advances to the next line or behaves --- like `(text " ")` line :: Doc line = linesep " " --- The document `linebreak` advances to the next line and indents to --- the current nesting level. Document `linebreak` behaves like `(text "")` --- if the line break is undone by `group`. --- @return a document which advances to the next line or behaves like --- `(text "")` linebreak :: Doc linebreak = linesep "" --- The document `softline` behaves like `space` if the resulting output --- fits the page, otherwise it behaves like `line`. --- `softline = group line` --- @return a document which behaves like `space` or `line` softline :: Doc softline = group line --- The document `softbreak` behaves like `(text "")` if the resulting output --- fits the page, otherwise it behaves like `line`. --- `softbreak = group linebreak` --- @return a document which behaves like `(text "")` or `line` softbreak :: Doc softbreak = group linebreak --- The combinator `group` is used to specify alternative layouts. --- The document `(group x)` undoes all line breaks in document `x`. --- The resulting line is added to the current line if that fits the page. --- Otherwise, the document `x` is rendered without any changes. --- @param d - a document --- @return document d without line breaks if that fits the page. group :: Doc -> Doc group d = Doc (OpenGroup . deDoc d . CloseGroup) --- The document `(nest i d)` renders document `d` with the current --- indentation level increased by `i` (See also `hang`, --- `align` and `indent`). --- --- nest 2 (text "hello" $$ text "world") $$ text "!" --- --- outputs as: --- --- hello --- world --- ! --- --- @param i - an integer which increases the indentation level --- @param d - a document --- @return document d with an indentation level increased by i nest :: Int -> Doc -> Doc nest i d = Doc (OpenNest (Inc i) . deDoc d . CloseNest) --- The combinator `hang` implements hanging indentation. --- The document `(hang i d)` renders document `d` with a nesting level set --- to the current column plus `i`. The following example uses hanging --- indentation for some text: --- --- test = hang 4 --- (fillSep --- (map text --- (words "the hang combinator indents these words !"))) --- --- Which lays out on a page with a width of 20 characters as: --- --- the hang combinator --- indents these --- words ! --- --- The hang combinator is implemented as: --- --- hang i x = align (nest i x) --- --- @param i - an integer which increases the indentation level --- @param d - a document --- @return document d with an indentation level set to the current column plus i hang :: Int -> Doc -> Doc hang i x = align (nest i x) --- The document `(align d)` renders document `d with the nesting level --- set to the current column. It is used for example to implement `hang`. --- --- As an example, we will put a document right above another one, --- regardless of the current nesting level: --- --- x $$ y = align (x $$ y) --- test = text "hi" <+> (text "nice" $$ text "world") --- --- which will be layed out as: --- --- hi nice --- world --- --- @param d - a document --- @return document d with the nesting level set to the current column align :: Doc -> Doc align d = Doc (OpenNest Align . deDoc d . CloseNest) --- The document `(indent i d)` indents document `d` with `i` spaces. --- --- test = indent 4 (fillSep (map text --- (words "the indent combinator indents these words !"))) --- --- Which lays out with a page width of 20 as: --- --- the indent --- combinator --- indents these --- words ! --- --- @param i - an integer which increases the indentation level --- @param d - a document --- @return document d with an indentation level set to the current column --- plus i indent :: Int -> Doc -> Doc indent i d = hang i (spaces i <> d) --- The document `(combine c d1 d2)` combines document `d1` and `d2` with --- document `c` in between using `(<>)` with identity `empty`. --- Thus, the following equations hold. --- --- combine c d1 empty == d1 --- combine c empty d2 == d2 --- combine c d1 d2 == d1 <> c <> d2 if neither d1 nor d2 are empty --- --- @param c - the middle document --- @param d1 - the left document --- @param d2 - the right document --- @return concatenation of d1 and d2 with c in between unless one --- of the documents is empty combine :: Doc -> Doc -> Doc -> Doc combine c d1 d2 | isEmpty d1 = d2 | isEmpty d2 = d1 | otherwise = enclose d1 d2 c --- The document `(x <> y)` concatenates document `x` and document `y`. --- It is an associative operation having `empty` as a left and right unit. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y without seperator with identity empty (<>) :: Doc -> Doc -> Doc d1 <> d2 | isEmpty d1 = d2 | isEmpty d2 = d1 | otherwise = Doc (deDoc d1 . deDoc d2) --- The document `(x <+> y)` concatenates document `x` and `y` with a --- `space` in between with identity `empty`. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a space in between (<+>) :: Doc -> Doc -> Doc (<+>) = combine space --- The document `(x $$ y)` concatenates document x and y with a --- `line` in between with identity `empty`. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a line in between ($$) :: Doc -> Doc -> Doc ($$) = combine line --- The document `(x <$+$> y)` concatenates document `x` and `y` with a --- blank line in between with identity `empty`. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a blank line in between (<$+$>) :: Doc -> Doc -> Doc (<$+$>) = combine (line <> linebreak) --- The document `(x y)` concatenates document `x` and `y` with --- a `softline` in between with identity `empty`. --- This effectively puts `x` and `y` either next to each other --- (with a `space` in between) or underneath each other. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a softline in between () :: Doc -> Doc -> Doc () = combine softline --- The document `(x <$$> y)` concatenates document `x` and `y` with a --- `linebreak` in between with identity `empty`. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a linebreak in between (<$$>) :: Doc -> Doc -> Doc (<$$>) = combine linebreak --- The document `(x y)` concatenates document `x` and `y` with a --- `softbreak` in between with identity `empty`. --- This effectively puts `x` and `y` either right next to each other --- or underneath each other. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a softbreak in between () :: Doc -> Doc -> Doc () = combine softbreak --- The document `(x <$!$> y)` concatenates document `x` and `y` with a --- `hardline` in between with identity `empty`. --- This effectively puts `x` and `y` underneath each other. --- @param x - the first document --- @param y - the second document --- @return concatenation of x and y with a hardline in between (<$!$>) :: Doc -> Doc -> Doc (<$!$>) = combine hardline --- The document `(compose f xs)` concatenates all documents `xs` --- with function `f`. --- Function `f` should be like `(<+>)`, `($$)` and so on. --- @param f - a combiner function --- @param xs - a list of documents --- @return concatenation of documents compose :: (Doc -> Doc -> Doc) -> [Doc] -> Doc compose _ [] = empty compose op ds@(_:_) = foldr1 op ds -- no seperator at the end --- The document `(hsep xs)` concatenates all documents `xs` --- horizontally with `(<+>)`. --- @param xs - a list of documents --- @return horizontal concatenation of documents hsep :: [Doc] -> Doc hsep = compose (<+>) --- The document `(vsep xs)` concatenates all documents `xs` vertically with --- `($$)`. If a group undoes the line breaks inserted by `vsep`, --- all documents are separated with a `space`. --- --- someText = map text (words ("text to lay out")) --- test = text "some" <+> vsep someText --- --- This is layed out as: --- --- some text --- to --- lay --- out --- --- The `align` combinator can be used to align the documents --- under their first element: --- --- test = text "some" <+> align (vsep someText) --- --- This is printed as: --- --- some text --- to --- lay --- out --- --- @param xs - a list of documents --- @return vertical concatenation of documents vsep :: [Doc] -> Doc vsep = compose ($$) --- The document `vsep xs` concatenates all documents `xs` vertically with --- `(<$+$>)`. If a group undoes the line breaks inserted by `vsepBlank`, --- all documents are separated with a `space`. --- @param xs - a list of documents --- @return vertical concatenation of documents vsepBlank :: [Doc] -> Doc vsepBlank = compose (<$+$>) --- The document `(fillSep xs)` concatenates documents `xs` horizontally with --- `()` as long as its fits the page, than inserts a --- `line` and continues doing that for all documents in `xs`. --- `fillSep xs = foldr () empty xs` --- @param xs - a list of documents --- @return horizontal concatenation of documents fillSep :: [Doc] -> Doc fillSep = compose () --- The document `(sep xs)` concatenates all documents `xs` either horizontally --- with `(<+>)`, if it fits the page, or vertically --- with `($$)`. --- `sep xs = group (vsep xs)` --- @param xs - a list of documents --- @return horizontal concatenation of documents, if it fits the page, --- or vertical concatenation else sep :: [Doc] -> Doc sep = group . vsep --- The document `(hcat xs)` concatenates all documents `xs` horizontally --- with `(<>)`. --- @param xs - a list of documents --- @return horizontal concatenation of documents hcat :: [Doc] -> Doc hcat = compose (<>) --- The document `(vcat xs)` concatenates all documents `xs` vertically --- with `(<$$>)`. If a `group` undoes the line breaks inserted by `vcat`, --- all documents are directly concatenated. --- @param xs - a list of documents --- @return vertical concatenation of documents vcat :: [Doc] -> Doc vcat = compose (<$$>) --- The document `(fillCat xs)` concatenates documents `xs` horizontally --- with `()` as long as its fits the page, than inserts a `linebreak` --- and continues doing that for all documents in `xs`. --- `fillCat xs = foldr () empty xs` --- @param xs - a list of documents --- @return horizontal concatenation of documents fillCat :: [Doc] -> Doc fillCat = compose () --- The document `(cat xs)` concatenates all documents `xs` either horizontally --- with `(<>)`, if it fits the page, or vertically with --- `(<$$>)`. --- `cat xs = group (vcat xs)` --- @param xs - a list of documents --- @return horizontal concatenation of documents cat :: [Doc] -> Doc cat = group . vcat --- `(punctuate p xs)` concatenates all documents `xs` with document `p` except --- for the last document. --- --- someText = map text ["words","in","a","tuple"] --- test = parens (align (cat (punctuate comma someText))) --- --- This is layed out on a page width of 20 as: --- --- (words,in,a,tuple) --- --- But when the page width is 15, it is layed out as: --- --- (words, --- in, --- a, --- tuple) --- --- (If you want put the commas in front of their elements instead of at the --- end, you should use `tupled` or, in general, `encloseSep`.) --- @param p - a document as seperator --- @param xs - a list of documents --- @return concatenation of documents with p in between punctuate :: Doc -> [Doc] -> [Doc] punctuate d ds = go ds where go [] = [] go [x] = [x] go (x:xs@(_:_)) = (x <> d) : go xs --- The document `(encloseSep l r s xs)` concatenates the documents `xs` --- seperated by `s` and encloses the resulting document by `l` and `r`. --- The documents are rendered horizontally if that fits the page. Otherwise --- they are aligned vertically. All seperators are put in front of the --- elements. --- --- For example, the combinator `list` can be defined with `encloseSep`: --- --- list xs = encloseSep lbracket rbracket comma xs --- test = text "list" <+> (list (map int [10,200,3000])) --- --- Which is layed out with a page width of 20 as: --- --- list [10,200,3000] --- --- But when the page width is 15, it is layed out as: --- --- list [10 --- ,200 --- ,3000] --- --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseSep l r _ [] = l <> r encloseSep l r s (d:ds) = align (enclose l r (cat (d : map (s <>) ds))) --- The document `(encloseSepSpaced l r s xs)` concatenates the documents `xs` --- seperated by `s` and encloses the resulting document by `l` and `r`. --- In addition, after each occurrence of `s`, after `l`, and before `r`, --- a `space` is inserted. --- The documents are rendered horizontally if that fits the page. Otherwise --- they are aligned vertically. All seperators are put in front of the --- elements. --- --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r encloseSepSpaced :: Doc -> Doc -> Doc -> [Doc] -> Doc encloseSepSpaced l r s = encloseSep (l <> space) (space <> r) (s <> space) --- The document `(hEncloseSep l r s xs)` concatenates the documents `xs` --- seperated by `s` and encloses the resulting document by `l` and `r`. --- --- The documents are rendered horizontally. --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r hEncloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc hEncloseSep l r _ [] = l <> r hEncloseSep l r s (d:ds) = align (enclose l r (hcat (d : map (s <>) ds))) --- The document `(fillEncloseSep l r s xs)` concatenates the documents `xs` --- seperated by `s` and encloses the resulting document by `l` and `r`. --- --- The documents are rendered horizontally if that fits the page. --- Otherwise they are aligned vertically. --- All seperators are put in front of the elements. --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r fillEncloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc fillEncloseSep l r _ [] = l <> r fillEncloseSep l r s (d:ds) = align (enclose l r (fillCat (d : map (s <>) ds))) --- The document `(fillEncloseSepSpaced l r s xs)` concatenates the documents --- `xs` seperated by `s` and encloses the resulting document by `l` and `r`. --- In addition, after each occurrence of `s`, after `l`, and before `r`, --- a `space` is inserted. --- --- The documents are rendered horizontally if that fits the page. --- Otherwise, they are aligned vertically. --- All seperators are put in front of the elements. --- @param l - left document --- @param r - right document --- @param s - a document as seperator --- @param xs - a list of documents --- @return concatenation of l, xs (with s in between) and r fillEncloseSepSpaced :: Doc -> Doc -> Doc -> [Doc] -> Doc fillEncloseSepSpaced l r s = fillEncloseSep (l <> space) (space <> r) (s <> space) --- The document `(list xs)` comma seperates the documents `xs` and encloses --- them in square brackets. The documents are rendered horizontally if --- that fits the page. Otherwise they are aligned vertically. --- All comma seperators are put in front of the elements. --- @param xs - a list of documents --- @return comma seperated documents xs and enclosed in square brackets list :: [Doc] -> Doc list = encloseSep lbracket rbracket comma --- Spaced version of `list` listSpaced :: [Doc] -> Doc listSpaced = encloseSepSpaced lbracket rbracket comma --- The document `(set xs)` comma seperates the documents `xs` and encloses --- them in braces. The documents are rendered horizontally if --- that fits the page. Otherwise they are aligned vertically. --- All comma seperators are put in front of the elements. --- @param xs - a list of documents --- @return comma seperated documents xs and enclosed in braces set :: [Doc] -> Doc set = encloseSep lbrace rbrace comma --- Spaced version of `set` setSpaced :: [Doc] -> Doc setSpaced = encloseSepSpaced lbrace rbrace comma --- The document `(tupled xs)` comma seperates the documents `xs` and encloses --- them in parenthesis. The documents are rendered horizontally if that fits --- the page. Otherwise they are aligned vertically. --- All comma seperators are put in front of the elements. --- @param xs - a list of documents --- @return comma seperated documents xs and enclosed in parenthesis tupled :: [Doc] -> Doc tupled = encloseSep lparen rparen comma --- Spaced version of `tupled` tupledSpaced :: [Doc] -> Doc tupledSpaced = encloseSepSpaced lparen rparen comma --- The document `(semiBraces xs)` seperates the documents `xs` with semi colons --- and encloses them in braces. The documents are rendered horizontally --- if that fits the page. Otherwise they are aligned vertically. --- All semi colons are put in front of the elements. --- @param xs - a list of documents --- @return documents xs seperated with semi colons and enclosed in braces semiBraces :: [Doc] -> Doc semiBraces = encloseSep lbrace rbrace semi --- Spaced version of `semiBraces` semiBracesSpaced :: [Doc] -> Doc semiBracesSpaced = encloseSepSpaced lbrace rbrace semi --- The document `(enclose l r x)` encloses document `x` between --- documents `l` and `r` using `(<>)`. --- `enclose l r x = l <> x <> r` --- @param l - the left document --- @param r - the right document --- @param x - the middle document --- @return concatenation of l, x and r enclose :: Doc -> Doc -> Doc -> Doc enclose l r d = l <> d <> r --- Document `(squotes x)` encloses document `x` with single quotes `"'"`. --- @param x - a document --- @return document x enclosed by single quotes squotes :: Doc -> Doc squotes = enclose squote squote --- Document `(dquotes x)` encloses document `x` with double quotes. --- @param x - a document --- @return document x enclosed by double quotes dquotes :: Doc -> Doc dquotes = enclose dquote dquote --- Document `(bquotes x)` encloses document `x` with back quotes `"\`"`. --- @param x - a document --- @return document x enclosed by `\`` quotes bquotes :: Doc -> Doc bquotes = enclose bquote bquote --- Document `(parens x)` encloses document `x` in parenthesis, --- `"("` and `")"`. --- @param x - a document --- @return document x enclosed in parenthesis parens :: Doc -> Doc parens = enclose lparen rparen --- Document `(parensIf x)` encloses document `x` in parenthesis,`"("` and `")"`, --- iff the condition is true. --- @param x - a document --- @return document x enclosed in parenthesis iff the condition is true parensIf :: Bool -> Doc -> Doc parensIf b s = if b then parens s else s --- Document `(angles x)` encloses document `x` in angles, `"<"` and `">"`. --- @param x - a document --- @return document x enclosed in angles angles :: Doc -> Doc angles = enclose langle rangle --- Document `(braces x)` encloses document `x` in braces, `"{"` and `"}"`. --- @param x - a document --- @return document x enclosed in braces braces :: Doc -> Doc braces = enclose lbrace rbrace --- Document `(brackets x)` encloses document `x` in square brackets, --- `"["` and `"]"`. --- @param x - a document --- @return document x enclosed in square brackets brackets :: Doc -> Doc brackets = enclose lbracket rbracket --- The document `(bool b)` shows the boolean `b` using `text`. --- @param b - a boolean --- @return a document which contains the boolean b bool :: Bool -> Doc bool b = text (show b) --- The document `(char c)` contains the literal character `c`. --- The character should not be a newline (`\n`), --- the function `line` should be used for line breaks. --- @param c - a character (not `\n`) --- @return a document which contains the literal character c char :: Char -> Doc char c = text [c] --- The document `(string s)` concatenates all characters in `s` using --- `line` for newline characters and `char` for all other characters. --- It is used instead of `text` whenever the text contains newline characters. --- @param s - a string --- @return a document which contains the string s string :: String -> Doc string = hcat . map (\c -> if elem c ['\n','\r'] then line else char c) --- The document `(int i)` shows the literal integer `i` using `text`. --- @param i - an integer --- @return a document which contains the integer i int :: Int -> Doc int n = text (show n) --- The document `(float f)` shows the literal float `f` using `text`. --- @param f - a float --- @return a document which contains the float f float :: Float -> Doc float x = text (show x) --- The document `lparen` contains a left parenthesis, `"("`. --- @return a document which contains a left parenthesis lparen :: Doc lparen = char '(' --- The document `rparen` contains a right parenthesis, `")"`. --- @return a document which contains a right parenthesis rparen :: Doc rparen = char ')' --- The document `langle` contains a left angle, `"<"`. --- @return a document which contains a left angle langle :: Doc langle = char '<' --- The document `rangle` contains a right angle, `">"`. --- @return a document which contains a right angle rangle :: Doc rangle = char '>' --- The document `lbrace` contains a left brace, `"{"`. --- @return a document which contains a left brace lbrace :: Doc lbrace = char '{' --- The document `rbrace` contains a right brace, `"}"`. --- @return a document which contains a right brace rbrace :: Doc rbrace = char '}' --- The document `lbracket` contains a left square bracket, `"["`. --- @return a document which contains a left square bracket lbracket :: Doc lbracket = char '[' --- The document `rbracket` contains a right square bracket, `"]"`. --- @return a document which contains a right square bracket rbracket :: Doc rbracket = char ']' --- The document `squote` contains a single quote, `"'"`. --- @return a document which contains a single quote squote :: Doc squote = char '\'' --- The document `dquote` contains a double quote. --- @return a document which contains a double quote dquote :: Doc dquote = char '"' --- The document `dquote` contains a `'`'` quote. --- @return a document which contains a `'`'` quote bquote :: Doc bquote = char '`' --- The document `semi` contains a semi colon, `";"`. --- @return a document which contains a semi colon semi :: Doc semi = char ';' --- The document `colon` contains a colon, `":"`. --- @return a document which contains a colon colon :: Doc colon = char ':' --- The document `comma` contains a comma, `","`. --- @return a document which contains a comma comma :: Doc comma = char ',' --- The document `space` contains a single space, `" "`. --- --- x <+> y = x <> space <> y --- --- @return a document which contains a single space space :: Doc space = char ' ' --- The document `(spaces n)` contains `n` spaces, when `n` is greater than 0. --- Otherwise the document is empty. --- --- @return a document which contains n spaces or the empty document, --- if n <= 0 spaces :: Int -> Doc spaces n | n <= 0 = empty | otherwise = text $ replicate n ' ' --- The document `dot` contains a single dot, `"."`. --- @return a document which contains a single dot dot :: Doc dot = char '.' --- The document `backslash` contains a back slash, `"\\"`. --- @return a document which contains a back slash backslash :: Doc backslash = char '\\' --- The document `equals` contains an equal sign, `"="`. --- @return a document which contains an equal equals :: Doc equals = char '=' --- The document `larrow` contains a left arrow sign, `"<-"`. --- @return a document which contains a left arrow sign larrow :: Doc larrow = text "<-" --- The document `rarrow` contains a right arrow sign, `"->"`. --- @return a document which contains a right arrow sign rarrow :: Doc rarrow = text "->" --- The document `doubleArrow` contains an double arrow sign, `"=>"`. --- @return a document which contains an double arrow sign doubleArrow :: Doc doubleArrow = text "=>" --- The document `doubleColon` contains a double colon sign, `"::"`. --- @return a document which contains a double colon sign doubleColon :: Doc doubleColon = text "::" --- The document `bar` contains a vertical bar sign, `"|"`. --- @return a document which contains a vertical bar sign bar :: Doc bar = char '|' --- The document `at` contains an at sign, `"@"`. --- @return a document which contains an at sign at :: Doc at = char '@' --- The document `tilde` contains a tilde sign, `"~"`. --- @return a document which contains a tilde sign tilde :: Doc tilde = char '~' --- The document `(fill i d)` renders document `d`. It than appends --- `space`s until the width is equal to `i`. If the width of `d` is --- already larger, nothing is appended. This combinator is quite --- useful in practice to output a list of bindings. The following --- example demonstrates this. --- --- types = [("empty","Doc") --- ,("nest","Int -> Doc -> Doc") --- ,("linebreak","Doc")] --- --- ptype (name,tp) --- = fill 6 (text name) <+> text "::" <+> text tp --- --- test = text "let" <+> align (vcat (map ptype types)) --- --- Which is layed out as: --- --- let empty :: Doc --- nest :: Int -> Doc -> Doc --- linebreak :: Doc --- --- Note that `fill` is not guaranteed to be linear-time bounded since it has to --- compute the width of a document before pretty printing it fill :: Int -> Doc -> Doc fill i d = d <> fill' where w = width d fill' = if w >= i then empty else spaces (i - w) --- The document `(fillBreak i d)` first renders document `d`. It --- than appends `space`s until the width is equal to `i`. If the --- width of `d` is already larger than `i`, the nesting level is --- increased by `i` and a `line` is appended. When we redefine `ptype` --- in the previous example to use `fillBreak`, we get a useful --- variation of the previous output: --- --- ptype (name,tp) --- = fillBreak 6 (text name) <+> text "::" <+> text tp --- --- The output will now be: --- --- let empty :: Doc --- nest :: Int -> Doc -> Doc --- linebreak --- :: Doc --- --- Note that `fillBreak` is not guaranteed to be linear-time bounded since it --- has to compute the width of a document before pretty printing it fillBreak :: Int -> Doc -> Doc fillBreak i d = d <> fill' where w = width d fill' = if w >= i then nest i linebreak else spaces (i - w) --- Compute the width of a given document width :: Doc -> Int width (Doc d) = width' 0 (d EOD) where width' w EOD = w width' w (Empty ts) = width' w ts width' w (Text s ts) = width' (w + lengthVis s) ts width' w (LineBreak Nothing ts) = width' w ts width' w (LineBreak (Just s) ts) = width' (w + lengthVis s) ts width' w (OpenGroup ts) = width' w ts width' w (CloseGroup ts) = width' w ts width' w (OpenNest _ ts) = width' w ts width' w (CloseNest ts) = width' w ts width' w (OpenFormat _ ts) = width' w ts width' w (CloseFormat ts) = width' w ts -- ----------------------------------------------------------------------------- -- Formatting combinators -- ----------------------------------------------------------------------------- --- The document `(bold d)` displays document `d` with bold text --- @param d - a document --- @return document d displayed with bold text bold :: Doc -> Doc bold d = Doc (OpenFormat (SetIntensity Bold) . deDoc d . CloseFormat) --- The document `(faint d)` displays document `d` with faint text --- @param d - a document --- @return document d displayed with faint text faint :: Doc -> Doc faint d = Doc (OpenFormat (SetIntensity Faint) . deDoc d . CloseFormat) --- The document `(blinkSlow d)` displays document `d` with slowly blinking text --- (rarely supported) --- @param d - a document --- @return document d displayed with slowly blinking text blinkSlow :: Doc -> Doc blinkSlow d = Doc (OpenFormat (SetBlinkMode Slow) . deDoc d . CloseFormat) --- The document `(blinkRapid d)` displays document `d` with rapidly blinking --- text (rarely supported) --- @param d - a document --- @return document d displayed with rapidly blinking text blinkRapid :: Doc -> Doc blinkRapid d = Doc (OpenFormat (SetBlinkMode Rapid) . deDoc d . CloseFormat) --- The document `(italic d)` displays document `d` with italicized text --- (rarely supported) --- @param d - a document --- @return document d displayed with italicized text italic :: Doc -> Doc italic d = Doc (OpenFormat (SetItalicized True) . deDoc d . CloseFormat) --- The document `(underline d)` displays document `d` with underlined text --- @param d - a document --- @return document d displayed with underlined text underline :: Doc -> Doc underline d = Doc (OpenFormat (SetUnderlined True) . deDoc d . CloseFormat) --- The document `(crossout d)` displays document `d` with crossed out text --- @param d - a document --- @return document d displayed with crossed out text crossout :: Doc -> Doc crossout d = Doc (OpenFormat (SetCrossedout True) . deDoc d . CloseFormat) --- The document `(inverse d)` displays document `d` with inversed coloring, --- i.e. use text color of `d` as background color and background color of `d` --- as text color --- @param d - a document --- @return document d displayed with inversed coloring inverse :: Doc -> Doc inverse d = Doc (OpenFormat (InverseColoring True) . deDoc d . CloseFormat) -- ----------------------------------------------------------------------------- -- Colorisation combinators -- ----------------------------------------------------------------------------- -- foreground colors --- The document `(black d)` displays document `d` with black text color --- @param d - a document --- @return document d displayed with black text color black :: Doc -> Doc black d = Doc (OpenFormat (SetForeground Black) . deDoc d . CloseFormat) --- The document `(red d)` displays document `d` with red text color --- @param d - a document --- @return document d displayed with red text color red :: Doc -> Doc red d = Doc (OpenFormat (SetForeground Red) . deDoc d . CloseFormat) --- The document `(green d)` displays document `d` with green text color --- @param d - a document --- @return document d displayed with green text color green :: Doc -> Doc green d = Doc (OpenFormat (SetForeground Green) . deDoc d . CloseFormat) --- The document `(yellow d)` displays document `d` with yellow text color --- @param d - a document --- @return document d displayed with yellow text color yellow :: Doc -> Doc yellow d = Doc (OpenFormat (SetForeground Yellow) . deDoc d . CloseFormat) --- The document `(blue d)` displays document `d` with blue text color --- @param d - a document --- @return document d displayed with blue text color blue :: Doc -> Doc blue d = Doc (OpenFormat (SetForeground Blue) . deDoc d . CloseFormat) --- The document `(magenta d)` displays document `d` with magenta text color --- @param d - a document --- @return document d displayed with magenta text color magenta :: Doc -> Doc magenta d = Doc (OpenFormat (SetForeground Magenta) . deDoc d . CloseFormat) --- The document `(cyan d)` displays document `d` with cyan text color --- @param d - a document --- @return document d displayed with cyan text color cyan :: Doc -> Doc cyan d = Doc (OpenFormat (SetForeground Cyan) . deDoc d . CloseFormat) --- The document `(white d)` displays document `d` with white text color --- @param d - a document --- @return document d displayed with white text color white :: Doc -> Doc white d = Doc (OpenFormat (SetForeground White) . deDoc d . CloseFormat) -- background colors --- The document `(bgBlack d)` displays document `d` with black background color --- @param d - a document --- @return document d displayed with black background color bgBlack :: Doc -> Doc bgBlack d = Doc (OpenFormat (SetBackground Black) . deDoc d . CloseFormat) --- The document `(bgRed d)` displays document `d` with red background color --- @param d - a document --- @return document d displayed with red background color bgRed :: Doc -> Doc bgRed d = Doc (OpenFormat (SetBackground Red) . deDoc d . CloseFormat) --- The document `(bgGreen d)` displays document `d` with green background color --- @param d - a document --- @return document d displayed with green background color bgGreen :: Doc -> Doc bgGreen d = Doc (OpenFormat (SetBackground Green) . deDoc d . CloseFormat) --- The document `(bgYellow d)` displays document `d` with yellow background --- color --- @param d - a document --- @return document d displayed with yellow background color bgYellow :: Doc -> Doc bgYellow d = Doc (OpenFormat (SetBackground Yellow) . deDoc d . CloseFormat) --- The document `(bgBlue d)` displays document `d` with blue background color --- @param d - a document --- @return document d displayed with blue background color bgBlue :: Doc -> Doc bgBlue d = Doc (OpenFormat (SetBackground Blue) . deDoc d . CloseFormat) --- The document `(bgMagenta d)` displays document `d` with magenta background --- color --- @param d - a document --- @return document d displayed with magenta background color bgMagenta :: Doc -> Doc bgMagenta d = Doc (OpenFormat (SetBackground Magenta) . deDoc d . CloseFormat) --- The document `(bgCyan d)` displays document `d` with cyan background color --- @param d - a document --- @return document d displayed with cyan background color bgCyan :: Doc -> Doc bgCyan d = Doc (OpenFormat (SetBackground Cyan) . deDoc d . CloseFormat) --- The document `(bgWhite d)` displays document `d` with white background color --- @param d - a document --- @return document d displayed with white background color bgWhite :: Doc -> Doc bgWhite d = Doc (OpenFormat (SetBackground White) . deDoc d . CloseFormat) -------------------------------------------------------------------------------- -- Pretty type class and instances for basic types -------------------------------------------------------------------------------- class Pretty a where pretty :: a -> Doc prettyList :: [a] -> Doc prettyList = list . map pretty instance Pretty a => Pretty [a] where pretty = prettyList instance Pretty Doc where pretty = id instance Pretty () where pretty () = text "()" instance Pretty Bool where pretty = bool instance Pretty Char where pretty = char prettyList = string instance Pretty Int where pretty = int instance Pretty Float where pretty = float instance (Pretty a, Pretty b) => Pretty (a,b) where pretty (x,y) = tupled [pretty x, pretty y] curry-tools-v3.3.0/optimize/.cpm/packages/wl-pprint/src/Text/PrettyImpl.curry000066400000000000000000000435361377556325500273630ustar00rootroot00000000000000--- Implementation of the Pretty library using --- [linear-time, bounded implementation](http://www.cs.kent.ac.uk/pubs/2006/2381/index.html) --- by Olaf Chitil. --- --- @author Sebastian Fischer, Bjoern Peemoeller, Jan Tikovsky --- @version December 2018 ------------------------------------------------------------------------------ module Text.PrettyImpl where import qualified Data.Queue as Q (Queue, cons, empty, matchHead, matchLast) -- The abstract data type Doc represents pretty documents. data Doc = Doc (Tokens -> Tokens) -- Extract the internal representation from a document. deDoc :: Doc -> Tokens -> Tokens deDoc (Doc d) = d type Horizontal = Bool type Remaining = Int type Width = Int type Position = Int type StartPosition = Position type EndPosition = Position type Out = Remaining -> Margins -> FormatHistory -> String -- Type of a `group output function`: Takes information whether group content -- should be formatted horizontally or vertically and a continuation to output -- parts of the document which come after the group type OutGroupPrefix = Horizontal -> Out -> Out type Margins = [Int] -- A nesting is either an alignment or a relative indentation data Nesting = Align | Inc Int -- text colorisation data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White | Default -- console intensity data Intensity = Faint | Normal | Bold -- support of blinking text data BlinkMode = Off | Slow | Rapid -- text formatting statement data FormatStm = SetForeground Color | SetBackground Color | SetIntensity Intensity | SetBlinkMode BlinkMode | SetItalicized Bool | SetUnderlined Bool | SetCrossedout Bool | InverseColoring Bool type FormatHistory = [FormatStm] resetFormat :: FormatHistory -> (FormatStm, FormatHistory) resetFormat [] = error "Pretty.resetFormat2: illegal format history" resetFormat (stm:stms) = case stm of SetForeground _ -> (SetForeground (prevFGColor stms), stms) SetBackground _ -> (SetBackground (prevBGColor stms), stms) SetIntensity _ -> (SetIntensity (prevIntensity stms), stms) SetBlinkMode _ -> (SetBlinkMode (prevBlinkMode stms), stms) SetItalicized b -> (SetItalicized (not b), stms) SetUnderlined b -> (SetUnderlined (not b), stms) SetCrossedout b -> (SetCrossedout (not b), stms) InverseColoring b -> (InverseColoring (not b), stms) -- Find previous foreground color in history prevFGColor :: FormatHistory -> Color prevFGColor history = case history of [] -> Default (SetForeground c : _ ) -> c (_ : hs) -> prevFGColor hs -- Find previous background color in history prevBGColor :: FormatHistory -> Color prevBGColor history = case history of [] -> Default (SetBackground c : _ ) -> c (_ : hs) -> prevBGColor hs -- Find previous text intensity in history prevIntensity :: FormatHistory -> Intensity prevIntensity history = case history of [] -> Normal (SetIntensity i : _ ) -> i (_ : hs) -> prevIntensity hs -- Find previous blinking mode in history prevBlinkMode :: FormatHistory -> BlinkMode prevBlinkMode history = case history of [] -> Off (SetBlinkMode b : _ ) -> b (_ : hs) -> prevBlinkMode hs applyFormat :: FormatStm -> String applyFormat (SetForeground c) = txtMode (colorMode c) applyFormat (SetBackground c) = txtMode (colorMode c + 10) applyFormat (SetIntensity i) = txtMode (intensityMode i) applyFormat (SetBlinkMode b) = txtMode (blinkMode b) applyFormat (SetItalicized b) = txtMode (if b then 3 else 23) applyFormat (SetUnderlined b) = txtMode (if b then 4 else 24) applyFormat (SetCrossedout b) = txtMode (if b then 9 else 29) applyFormat (InverseColoring b) = txtMode (if b then 7 else 27) -- Text mode txtMode :: Int -> String txtMode m = csiCmd ++ show m ++ "m" where csiCmd :: String csiCmd = '\ESC' : '[' : "" -- Color mode colorMode :: Color -> Int colorMode c = case c of Black -> 30 Red -> 31 Green -> 32 Yellow -> 33 Blue -> 34 Magenta -> 35 Cyan -> 36 White -> 37 Default -> 39 -- Intensity mode intensityMode :: Intensity -> Int intensityMode i = case i of Faint -> 2 Normal -> 22 Bold -> 1 -- Blink mode blinkMode :: BlinkMode -> Int blinkMode b = case b of Off -> 25 Slow -> 5 Rapid -> 6 -- Token sequence. Note that the data type linearizes a document so that -- a fragment is usually followed by a remaining document. data Tokens = EOD -- end of document | Empty Tokens -- empty document | Text String Tokens -- string | LineBreak (Maybe String) Tokens -- linebreak that will be replaced by the -- separator if the linebreak is undone | OpenGroup Tokens -- Beginning of a group | CloseGroup Tokens -- End of a group | OpenNest Nesting Tokens -- Beginning of a nesting | CloseNest Tokens -- End of a nesting | OpenFormat FormatStm Tokens -- Beginning of a formatting statement | CloseFormat Tokens -- End of a formatting statement applyNesting :: Nesting -> Width -> Remaining -> Margins -> Margins applyNesting Align w r ms = (w - r) : ms applyNesting (Inc i) _ _ ms = case ms of m:_ -> (m + i) : ms _ -> error "Pretty.applyNesting: empty margin list" unApplyNesting :: Margins -> Margins unApplyNesting [] = error "Pretty.unApplyNesting: empty margin list" unApplyNesting (_:ms) = ms addSpaces :: Int -> Tokens -> String addSpaces m ts = case ts of LineBreak _ _ -> "" EOD -> "" Empty ts' -> addSpaces m ts' OpenGroup ts' -> addSpaces m ts' CloseGroup ts' -> addSpaces m ts' OpenNest _ ts' -> addSpaces m ts' CloseNest ts' -> addSpaces m ts' OpenFormat _ ts' -> addSpaces m ts' CloseFormat ts' -> addSpaces m ts' Text _ _ -> replicate m ' ' -- Normalise a token sequence using the following rewriting rules: -- -- CloseGroup (Text s ts) => Text s (CloseGroup ts) -- OpenGroup (Text s ts) => Text s (OpenGroup ts) -- OpenGroup (CloseGroup ts) => ts -- -- Rewriting moves `Text` tokens in and out of groups. The set of `lines` -- "belonging" to each group, i.e., the set of layouts, is left unchanged. normalise :: Tokens -> Tokens normalise = go id where go co EOD = co EOD go co (Empty ts) = go co ts -- there should be no deferred opening brackets go co (OpenGroup ts) = go (co . open) ts go co (CloseGroup ts) = go (co . CloseGroup) ts go co (LineBreak ms ts) = (co . LineBreak ms . go id) ts go co (Text s ts) = Text s (go co ts) go co (OpenNest n ts) = OpenNest n (go co ts) go co (CloseNest ts) = CloseNest (go co ts) go co (OpenFormat f ts) = OpenFormat f (go co ts) go co (CloseFormat ts) = CloseFormat (go co ts) open t = case t of CloseGroup ts -> ts _ -> OpenGroup t -- Transform a document into a group-closed document by normalising its token -- sequence. -- A document is called group-closed, if between the end of every `group` and -- the next `text` document there is always a `line` document. doc2Tokens :: Doc -> Tokens doc2Tokens (Doc d) = normalise (d EOD) --- `(showWidth w d)` pretty prints document `d` with a page width of `w` characters --- @param w - width of page --- @param d - a document --- @return pretty printed document showWidth :: Width -> Doc -> String showWidth w d = noGroup (doc2Tokens d) w 1 w [0] [] -- Compute number of visible ASCII characters lengthVis :: String -> Int lengthVis = Prelude.length . filter isVisible where isVisible c = ord c `notElem` ([5, 6, 7] ++ [16 .. 31]) -- Basic pretty printing algorithm: -- -- 1. Determine for each group in the document its width, i.e. the space it -- requires for printing if it was printed horizontally, all in one line. -- 2. Traverse document tree and keep track of remaining free space in current -- output line. -- At the start of a group compare remaining space with width of the group: -- If the width is smaller or equal, the group is formatted horizontally, -- otherwise vertically. -- Determine widths of all groups and produce actual layout by traversing token -- sequence a single time using continuations: -- At the start of each group construct a `group output function` which receives -- formate information and information about the remaining space at the -- beginning of the group. -- Since groups can be nested we don't want to update a width value for each -- surrounding group when processing a token. Instead we introduce an absolute -- measure of a token's position: The width of a group is the difference between -- the position of its `CloseGroup` token and the position of its `OpenGroup` token. -- When traversing the document only the `group output function` of the -- innermost group is extended. All the other `group output function`s are -- passed on unchanged. When we come across a `CloseGroup` token we merge the -- function for the innermost group with the function for the next inner group. -- noGroup is used when there is currently no deferred group noGroup :: Tokens -> Width -> Position -> Out noGroup EOD _ _ _ _ _ = "" -- should not occur: noGroup (Empty ts) w p r ms fs = noGroup ts w p r ms fs noGroup (Text t ts) w p r ms fs = t ++ noGroup ts w (p + l) (r - l) ms fs where l = lengthVis t noGroup (LineBreak _ ts) w p _ ms fs = case ms of [] -> error "Pretty.noGroup: illegal line" m:_ -> '\n' : addSpaces m ts ++ noGroup ts w (p + 1) (w - m) ms fs noGroup (OpenGroup ts) w p r ms fs = oneGroup ts w p (p + r) (\_ c -> c) r ms fs noGroup (CloseGroup ts) w p r ms fs = noGroup ts w p r ms fs -- may have been pruned noGroup (OpenNest n ts) w p r ms fs = noGroup ts w p r (applyNesting n w r ms) fs noGroup (CloseNest ts) w p r ms fs = noGroup ts w p r (unApplyNesting ms) fs noGroup (OpenFormat f ts) w p r ms fs = applyFormat f ++ noGroup ts w p r ms (f:fs) noGroup (CloseFormat ts) w p r ms fs = applyFormat f ++ noGroup ts w p r ms ofs where (f, ofs) = resetFormat fs -- oneGroup is used when there is one deferred group -- Whenever the tokens `Text` or `LineBreak` are processed, -- i.e. the current position is increased, -- pruneOne checks whether whether the group still fits the line -- Furthermore the `group output function` is extended with the current token oneGroup :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Out oneGroup EOD _ _ _ _ = error "Pretty.oneGroup: EOD" -- should not occur: oneGroup (Empty ts) w p e outGrpPre = oneGroup ts w p e outGrpPre oneGroup (Text s ts) w p e outGrpPre = pruneOne ts w (p + l) e (\h cont -> outGrpPre h (outText cont)) where l = lengthVis s outText cont r ms fs = s ++ cont (r - l) ms fs oneGroup (LineBreak Nothing ts) w p _ outGrpPre = outGrpPre False (outLine (noGroup ts w p)) where outLine _ _ [] _ = error "Pretty.oneGroup.outLine: empty margins" outLine cont _ ms@(m:_) fs = '\n' : addSpaces m ts ++ cont (w - m) ms fs oneGroup (LineBreak (Just s) ts) w p e outGrpPre = pruneOne ts w (p + l) e (\h cont -> outGrpPre h (outLine h cont)) where l = lengthVis s outLine _ _ _ [] _ = error "Pretty.oneGroup.outLine: empty margins" outLine h cont r ms@(m:_) fs = if h then s ++ cont (r - l) ms fs else '\n' : addSpaces m ts ++ cont (w - m) ms fs oneGroup (OpenGroup ts) w p e outGrpPre = multiGroup ts w p e outGrpPre Q.empty p (\_ cont -> cont) oneGroup (CloseGroup ts) w p e outGrpPre = outGrpPre (p <= e) (noGroup ts w p) oneGroup (OpenNest n ts) w p e outGrpPre = oneGroup ts w p e (\h cont -> outGrpPre h (\r ms fs -> cont r (applyNesting n w r ms) fs)) oneGroup (CloseNest ts) w p e outGrpPre = oneGroup ts w p e (\h cont -> outGrpPre h (\r ms fs -> cont r (unApplyNesting ms) fs)) oneGroup (OpenFormat f ts) w p e outGrpPre = oneGroup ts w p e (\h cont -> outGrpPre h (outFormat cont)) where outFormat cont r ms fs = applyFormat f ++ cont r ms (f:fs) oneGroup (CloseFormat ts) w p e outGrpPre = oneGroup ts w p e (\h cont -> outGrpPre h (outUnformat cont)) where outUnformat cont r ms fs = applyFormat f ++ cont r ms ofs where (f, ofs) = resetFormat fs -- multiGroup is used when there are at least two deferred groups -- Whenever the tokens `Text` or `LineBreak` are processed, i.e. the current position -- is increased, pruneMulti checks whether whether the outermost group still -- fits the line. -- Furthermore the `group output function` of the innermost group is extended -- with the current token. -- When we come across a `OpenGroup` token during traversal of the token sequence, -- the current innermost `group output function` is added to the queue. -- Reaching a `CloseGroup` token it is checked whether the queue still contains a -- deferred `group output function`: If the queue is empty, there is only one -- group left, otherwise there are at least two groups left. -- In both cases the function for the innermost group is merged with the -- function for the next inner group multiGroup :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Q.Queue (StartPosition, OutGroupPrefix) -> StartPosition -> OutGroupPrefix -> Out multiGroup EOD _ _ _ _ _ _ _ = error "Pretty.multiGroup: EOD" -- should not occur: multiGroup (Empty ts) w p e outGrpPreOuter qs s outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs s outGrpPreInner multiGroup (Text t ts) w p e outGrpPreOuter qs s outGrpPreInner = pruneMulti ts w (p+l) e outGrpPreOuter qs s (\h cont -> outGrpPreInner h (outText cont)) where l = lengthVis t outText cont r ms fs = t ++ cont (r-l) ms fs multiGroup (LineBreak Nothing ts) w p _ outGrpPreOuter qs _ outGrpPreInner = pruneAll outGrpPreOuter qs where pruneAll outGrpPreOuter' qs' = outGrpPreOuter' False (\r -> (case Q.matchLast qs' of Nothing -> outGrpPreInner False (outLine (noGroup ts w p)) Just ((_,outGrpPre),qss) -> pruneAll outGrpPre qss) r) outLine _ _ [] _ = error "Pretty.oneGroup.outLine: empty margins" outLine cont _ ms@(m:_) fs = '\n' : addSpaces m ts ++ cont (w - m) ms fs multiGroup (LineBreak (Just s) ts) w p e outGrpPreOuter qs si outGrpPreInner = pruneMulti ts w (p + l) e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (outLine h cont)) where l = lengthVis s outLine _ _ _ [] _ = error "Pretty.multiGroup.outLine: empty margins" outLine h cont r ms@(m:_) fs = if h then s ++ cont (r-l) ms fs else '\n': addSpaces m ts ++ cont (w-m) ms fs multiGroup (OpenGroup ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter (Q.cons (si,outGrpPreInner) qs) p (\_ cont -> cont) multiGroup (CloseGroup ts) w p e outGrpPreOuter qs si outGrpPreInner = case Q.matchHead qs of Nothing -> oneGroup ts w p e (\h cont -> outGrpPreOuter h (\ri -> outGrpPreInner (p<=si+ri) cont ri)) Just ((s,outGrpPre),qs') -> multiGroup ts w p e outGrpPreOuter qs' s (\h cont -> outGrpPre h (\ri -> outGrpPreInner (p<=si+ri) cont ri)) multiGroup (OpenNest n ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (\r ms fs -> cont r (applyNesting n w r ms) fs)) multiGroup (CloseNest ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (\r ms fs -> cont r (unApplyNesting ms) fs)) multiGroup (OpenFormat f ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (outFormat cont)) where outFormat cont r ms fs = applyFormat f ++ cont r ms (f:fs) multiGroup (CloseFormat ts) w p e outGrpPreOuter qs si outGrpPreInner = multiGroup ts w p e outGrpPreOuter qs si (\h cont -> outGrpPreInner h (outUnformat cont)) where outUnformat cont r ms fs = applyFormat f ++ cont r ms ofs where (f, ofs) = resetFormat fs -- pruneOne checks whether the outermost group (in this case there is only one -- group) still fits in the current line. If it doesn't fit, it applies the -- corresponding `group output function` (the group is formatted vertically) -- and continues processing the token sequence pruneOne :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Out pruneOne ts w p e outGrpPre | p <= e = oneGroup ts w p e outGrpPre | otherwise = outGrpPre False (noGroup ts w p) -- pruneMulti checks whether the outermost group (in this case there are at -- least two groups) still fits in the current line. If it doesn't fit, it -- applies the corresponding `group output function` (the last queue entry) and -- continues checking whether the next outermost group fits pruneMulti :: Tokens -> Width -> Position -> EndPosition -> OutGroupPrefix -> Q.Queue (StartPosition, OutGroupPrefix) -> StartPosition -> OutGroupPrefix -> Out pruneMulti ts w p e outGrpPreOuter qs si outGrpPreInner | p <= e = multiGroup ts w p e outGrpPreOuter qs si outGrpPreInner | otherwise = outGrpPreOuter False (\r -> (case Q.matchLast qs of Nothing -> pruneOne ts w p (si+r) outGrpPreInner Just ((s,outGrpPre),qs') -> pruneMulti ts w p (s+r) outGrpPre qs' si outGrpPreInner) r) -------------------------------------------------------------------------------- -- Debugging -------------------------------------------------------------------------------- -- inspect the token sequence of a document inspect :: Doc -> Tokens inspect (Doc d) = normalise (d EOD) curry-tools-v3.3.0/optimize/.cpm/packages/xml/000077500000000000000000000000001377556325500213025ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/xml/LICENSE000066400000000000000000000027351377556325500223160ustar00rootroot00000000000000Copyright (c) 2017, Michael Hanus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the names of the copyright holders 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 THE COPYRIGHT HOLDER OR CONTRIBUTORS 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. curry-tools-v3.3.0/optimize/.cpm/packages/xml/README.md000066400000000000000000000016101377556325500225570ustar00rootroot00000000000000# xml - Libraries for XML processing This package contains libraries for processing XML data, like reading and writing XML files, converting, or querying XML documents. Currently, it contains the following libraries: * `XML`: This module defines a datatype for representing XML data and operations for reading and writing XML data, e.g., which is stored in files. * `XmlConv`: This module provides type-based combinators to construct XML converters. * `XCuery`: This module defines combinators to search in XML documents. It is a literate Curry program which contains the paper [Declarative Processing of Semistructured Web Data](http://dx.doi.org/10.4230/LIPIcs.ICLP.2011.198) which appeared in the Technical Communications of the 27th International Conference on Logic Programming (ICLP 2011), Leibniz International Proceedings in Informatics (LIPIcs), Vol. 11, pp. 198-208, 2011 curry-tools-v3.3.0/optimize/.cpm/packages/xml/examples/000077500000000000000000000000001377556325500231205ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/xml/examples/XmlMatching.curry000066400000000000000000000064411377556325500264260ustar00rootroot00000000000000-- Some examples for matching in XML documents based on the `XCuery` library. -- -- Note that this module requires the installation -- of the package `setfunctions`! import Control.SetFunctions import XML import XCuery import Test.Prop -- Some sample XML documents: entry1 :: XmlExp entry1 = xml "entry" [xml "name" [xtxt "Hanus"], xml "first" [xtxt "Michael"], xml "phone" [xtxt "+49-431-8807271"], xml "email" [xtxt "mh@informatik.uni-kiel.de"], xml "email" [xtxt "hanus@acm.org"]] entry2 :: XmlExp entry2 = xml "entry" [xml "phone" [xtxt "+1-987-742-9388"], xml "name" [xtxt "Smith"], xml "first" [xtxt "William"], xml "nickname" [xtxt "Bill"]] contacts :: XmlExp contacts = xml "contacts" [entry1,entry2] -- Search for names and their phone numbers: getNamePhone :: XmlExp -> String getNamePhone (xml "entry" (with [xml "name" [xtxt name], xml "phone" [xtxt phone]])) = name ++ ": " ++ phone test1 = getNamePhone entry1 -=- "Hanus: +49-431-8807271" test2 = failing $ getNamePhone entry2 -- due to wrong order of phone/name -- Search for names and their phone numbers appearing in any order: getAnyNamePhone :: XmlExp -> String getAnyNamePhone (xml "entry" (with (anyorder [xml "phone" [xtxt phone], xml "name" [xtxt name]]))) = name ++ ": " ++ phone test3 = getAnyNamePhone entry2 -=- "Smith: +1-987-742-9388" -- Search for some email occurring anywhere (deep) in a document: getEmail :: XmlExp -> String getEmail (deepXml "email" [xtxt email]) = email test4 = getEmail contacts <~> ("hanus@acm.org" ? "mh@informatik.uni-kiel.de") -- Get all emails: allEmails :: [String] allEmails = sortValues ((set1 getEmail) contacts) test5 = allEmails -=- ["hanus@acm.org","mh@informatik.uni-kiel.de"] -- Negated patterns: constructive negation using `withOthers` combinator: -- get name/phone of all persons without email: getNamePhoneWithoutEmail :: XmlExp -> String getNamePhoneWithoutEmail (deepXml "entry" (withOthers (anyorder [xml "name" [xtxt name], xml "phone" [xtxt phone]]) others)) | "email" `noTagOf` others = name ++ ": " ++ phone noTagOf :: String -> [XmlExp] -> Bool noTagOf tag xmlexps = all (\xe -> tag /= (tagOf xe)) xmlexps test6 = getNamePhoneWithoutEmail contacts <~> "Smith: +1-987-742-9388" --- Transformation of contact data into the form (phone,fullname): transPhone :: XmlExp -> XmlExp transPhone (deepXml "entry" (with (anyorder ([xml "name" [xtxt name], xml "first" [xtxt first], xml "phone" [xtxt phone]])))) = xml "phonename" [xml "phone" [xtxt phone], xml "fullname" [xtxt (first++" "++name)]] phoneTable :: XmlExp phoneTable = xml "table" (sortValues ((set1 transPhone) contacts)) -- Collect results: -- Get all names with number of email addresses getEmails :: XmlExp -> (String,Int) getEmails (deepXml "entry" (withOthers [xml "name" [xtxt name]] others)) = (name, length (sortValues ((set1 emailOf) others))) emailOf :: [XmlExp] -> [XmlExp] emailOf (with [xml "email" email]) = email test8 = getEmails contacts <~> (("Hanus",2) ? ("Smith",0)) curry-tools-v3.3.0/optimize/.cpm/packages/xml/package.json000066400000000000000000000021071377556325500235700ustar00rootroot00000000000000{ "name": "xml", "version": "3.0.0", "author": "Michael Hanus ", "maintainer": "Michael Hanus ", "synopsis": "Libraries for XML processing", "category": [ "Data", "Web" ], "dependencies": { "base" : ">= 3.0.0, < 4.0.0", "read-legacy": ">= 3.0.0, < 4.0.0" }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "exportedModules": [ "XML", "XmlConv", "XCuery" ], "description": "This package contains libraries for processing XML data, like reading and writing XML files, converting, or querying XML documents.", "license": "BSD-3-Clause", "licenseFile": "LICENSE", "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/xml.git", "tag": "$version" }, "testsuite": [ { "src-dir": "src", "modules": [ "XML","XCuery" ] }, { "src-dir": "src", "options": "--nosource", "modules": [ "XmlConv" ] } ] } curry-tools-v3.3.0/optimize/.cpm/packages/xml/src/000077500000000000000000000000001377556325500220715ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/.cpm/packages/xml/src/XCuery.lcurry000066400000000000000000001512461377556325500245630ustar00rootroot00000000000000\documentclass[12pt,fleqn]{article} \setlength{\textwidth}{16.0cm} \setlength{\textheight}{22cm} \setlength{\topmargin}{-1cm} \setlength{\oddsidemargin}{0cm} \setlength{\evensidemargin}{\oddsidemargin} \setlength{\marginparwidth}{0.0cm} \setlength{\marginparsep}{0.0cm} \usepackage{url} \def\UrlFont{\tt} \usepackage{xspace} \usepackage{hyperref} \usepackage{pdfpages} \usepackage{listings} \lstset{aboveskip=1.5ex, belowskip=1.5ex, showstringspaces=false, % no special string space mathescape=true, basewidth=0.5em, basicstyle=\small\ttfamily,% backgroundcolor=\color[rgb]{0.9,0.9,0.9}} \lstset{literate={->}{{$\rightarrow{}\!\!\!$}}3 {unknown}{{\char95}}1 } \lstnewenvironment{lcurry}{\lstset{firstline=2}}{} \lstnewenvironment{curry}{}{} \lstnewenvironment{xmldoc}{\lstset{backgroundcolor=\color{white}}}{} \newcommand{\listline}{\vrule width0pt depth1.75ex} \newcommand{\code}[1]{\texttt{#1}} \newcommand{\ccode}[1]{``\code{#1}''} \newcommand{\bs}{\char92\xspace} % backslash \newcommand{\us}{\char95\xspace} % underscore \newcommand{\funset}{\ensuremath{_{\cal S}}} \begin{document} \pagestyle{plain} \date{\small Technical Report 1103, March 2011} \sloppy %\includepdf[nup=1x1,pages=-]{cover.pdf} \setcounter{page}{1} \title{Declarative Processing of\\ Semistructured Web Data} \author{Michael Hanus\\[1ex] \small Institut f\"ur Informatik, CAU Kiel, D-24098 Kiel, Germany. \\ \small{\tt mh@informatik.uni-kiel.de} } \maketitle \begin{abstract} In order to give application programs access to data stored in the web in semistructured formats, in particular, in XML format, we propose a domain-specific language for declarative processing such data. Our language is embedded in the functional logic programming language Curry and offers powerful matching constructs that enable a declarative description of accessing and transforming XML data. We exploit advanced features of functional logic programming to provide a high-level and maintainable implementation of our language. Actually, this paper contains the complete code of our implementation so that the source text of this paper is an executable implementation of our language. \end{abstract} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Motivation} \label{sec:motivation} Nowadays, huge amounts of information are available in the world-wide web. Much of this information is also available in semistructured formats so that it can be automatically accessed by application programs. The extensible markup language (XML) is often used as an exchange format for such data. Since data in XML format are basically term structures, XML data can be (in principle) easily processed with functional or logic programming languages: one has to define a term representation of XML data in the programming language, implement a parser from the textual XML representation into such terms, and exploit pattern matching to implement the specific processing task. In practice, such an implementation causes some difficulties due to the fact that the concrete data formats are complex or evolve over time: \begin{itemize} \item For many application areas, concrete XML languages are defined. However, they are often quite complex so that it is difficult or tedious to deal with all details when one is interested in extracting only some parts of the given data. \item For more specialized areas without standardized XML languages, the XML format might be incompletely specified or evolves over time. Thus, application programs with standard pattern matching must be adapted if the data format changes. \end{itemize} % \begin{figure} \centering \begin{xmldoc} Hanus Michael +49-431-8807271 mh@informatik.uni-kiel.de hanus@acm.org Smith William Bill +1-987-742-9388 \end{xmldoc} \caption{A simple XML document} \label{fig:xml-contacts} \end{figure} % For instance, consider the XML document shown in Figure~\ref{fig:xml-contacts} which represents the data of a small address book. As one can see, the two entries have different information fields: the first entry contains two email addresses but no nickname whereas the second entry contains no email address but a nickname. Such data, which is not uncommon in practice, is also called ``semistructured'' \cite{AbiteboulBunemanSuciu00}. Semistructured data causes difficulties when it should be processed with a declarative programming language by mapping the XML structures into data terms of the implementation language. Therefore, various distinguished languages for processing XML data have been proposed. For instance, the language XPath\footnote{\url{http://www.w3.org/TR/xpath}} provides powerful path expressions to select sub-documents in XML documents. Although path expressions allow flexible retrievals by the use of wildcards, regular path expressions, stepping to father and sibling nodes etc, they are oriented towards following a path through the document from the root to the selected sub-documents. This gives them a more imperative rather than a descriptive or declarative flavor. The same is true for query and transformation languages like XQuery\footnote{\url{http://www.w3.org/XML/Query/}} or XSLT\footnote{\url{http://www.w3.org/TR/xslt}} which are based on the XPath-oriented style to select the required sub-documents. As an alternative to path-oriented processing languages, the language Xcerpt \cite{BrySchaffert02,BrySchaffertSchroeder05} is a proposal to exploit ideas from logic programming in order to provide a declarative method to select and transform semistructured data in XML format. In contrast to pure logic programming, Xcerpt proposes matching with partial term structures for which a specialized unification procedure, called ``simulation unification'' \cite{BrySchaffert02ICLP}, has been developed. Since matching with partial term structures is a powerful feature that avoids many problems related to the evolution of web data over time, we propose a language with similar features. However, our language is an embedded domain-specific language (eDSL). Due to the embedding into the functional logic programming language Curry \cite{Hanus06Curry}, our language for XML processing has the following features and advantages: \begin{itemize} \item The selection and transformation of incompletely specified XML data is supported. \item Due to the embedding into a universal programming language, the selected or transformed data can be directly used in the application program. \item Due to the use of advanced functional logic programming features, the implementation is straightforward and can be easily extended with new features. Actually, this paper contains the complete source code of the implementation. \item The direct implementation in a declarative language results in immediate correctness proofs of the implementation. \end{itemize} In the following, we present our language for XML processing together with their implementation. Since the implementation exploits features of modern functional logic programming languages, we review them in the next section before presenting our eDSL. \section{Functional Logic Programming and Curry} Curry \cite{Hanus06Curry} is a declarative multi-paradigm language combining features from functional programming (demand-driven evaluation, parametric polymorphism, higher-order functions) and logic programming (computing with partial information, unification, constraints). Recent surveys are available in \cite{AntoyHanus10CACM,Hanus07ICLP}. The syntax of Curry is close to Haskell\footnote{% Variables and function names usually start with lowercase letters and the names of type and data constructors start with an uppercase letter. The application of $f$ to $e$ is denoted by juxtaposition (``$f~e$'').} \cite{PeytonJones03Haskell}. In addition, Curry allows free (logic) variables in conditions and right-hand sides of defining rules. The operational semantics is based on an optimal evaluation strategy \cite{AntoyEchahedHanus00JACM} which is a conservative extension of lazy functional programming and (concurrent) logic programming. A Curry program consists of the definition of data types and operations on these types. Note that in a functional logic language operations might yield more than one result on the same input due to the logic programming features. Thus, Curry operations are not functions in the classical mathematical sense so that they are sometimes called ``nondeterministic functions'' \cite{GonzalezEtAl99}. Nevertheless, a Curry program has a purely declarative semantics where nondeterministic operations are modeled as set-valued functions (to be more precise, down-closed partially ordered sets are used as target domains in order to cover non-strictness, see \cite{GonzalezEtAl99} for a detailed account of this model-theoretic semantics). For instance, Curry contains a \emph{choice} operation defined by: % \begin{curry} x ? _ = x _ ? y = y \end{curry} % Thus, the expression \ccode{0$~$?$~$1} has two values: \code{0} and \code{1}. If expressions have more than one value, one wants to select intended values according to some constraints, typically in conditions of program rules. A \emph{rule} has the form \ccode{$f~t_1\ldots{}t_n$ | $c$ = $e$} where the (optional) condition $c$ is a \emph{constraint}, i.e., an expression of the built-in type \code{Success}. For instance, the trivial constraint \code{success} is a value of type \code{Success} that denotes the always satisfiable constraint. Thus, we say that a constraint $c$ is \emph{satisfied} if it can be evaluated to \code{success}. An \emph{equational constraint} $e_1 \,\code{=:=}\, e_2$ is satisfiable if both sides $e_1$ and $e_2$ are reducible to unifiable values. Furthermore, if $c_1$ and $c_2$ are constraints, \code{$c_1\,$\&$\,\,c_2$} denotes their concurrent conjunction (i.e., both argument constraints are concurrently evaluated). As a simple example, consider the following Curry program which defines a polymorphic data type for lists and operations to compute the concatenation of lists and the last element of a list:\footnote{Note that lists are a built-in data type with a more convenient syntax, e.g., one can write \code{[x,y,z]} instead of \code{x:y:z:[]} and \code{[a]} instead of the list type \ccode{List a}.} % \begin{curry} data List a = [] | a : List a --[a] denotes "List a" -- "++" is a right-associative infix operator (++) :: [a] -> [a] -> [a] [] ++ ys = ys (x:xs) ++ ys = x : (xs ++ ys) last :: [a] -> a last xs | (ys ++ [z]) =:= xs = z where ys,z free \end{curry} % Logic programming is supported by admitting function calls with free variables (e.g., \code{(ys++[z])} in the rule defining \code{last}) and constraints in the condition of a defining rule. In contrast to Prolog, free variables need to be declared explicitly to make their scopes clear (e.g., \ccode{where ys,z free} in the example). A conditional rule is applicable if its condition is satisfiable. Thus, the rule defining \code{last} states in its condition that \code{z} is the last element of a given list \code{xs} if there exists a list \code{ys} such that the concatenation of \code{ys} and the one-element list \code{[z]} is equal to the given list \code{xs}. The combination of functional and logic programming features has led to new design patterns \cite{AntoyHanus02FLOPS} and better abstractions for application programming, e.g., as shown for programming with databases \cite{BrasselHanusMueller08PADL,Fischer05}, GUI programming \cite{Hanus00PADL}, web programming \cite{Hanus01PADL,Hanus06PPDP,HanusKoschnicke10PADL}, or string parsing \cite{CaballeroLopez99}. In this paper, we show how to exploit these combined features to implement an eDSL for XML processing. To make this implementation as simple as possible, we exploit two more recent features described in the following: functional patterns \cite{AntoyHanus05LOPSTR} and set functions \cite{AntoyHanus09}. A fundamental requirement in functional as well as logic languages is that patterns in the left-hand sides of program rules contain only variables and data constructors. This excludes rules like \begin{curry} (xs ++ ys) ++ zs = xs ++ (ys ++ zs) \end{curry} stating the associativity property of list concatenation. This restriction is the key to construct efficient evaluation strategies \cite{Hanus07ICLP}. However, in a functional logic language one can relax this requirement and allow expressions containing defined operations in patterns as an abbreviation for a (potentially infinite) set of ``standard'' patterns. A pattern containing defined operations is called \emph{functional pattern}. For instance, \begin{curry} last (xs ++ [e]) = e \end{curry} is a rule with the functional pattern \code{(xs++[e])} stating that \code{last} is reducible to \code{e} provided that the argument can be matched against some value of \code{(xs++[e])} where \code{xs} and \code{e} are free variables. By instantiating \code{xs} to arbitrary lists, the value of \code{(xs++[e])} is any list having \code{e} as its last element. The semantics of functional patterns can be defined in terms of standard pattern by interpreting a functional pattern as the set of all constructor terms that is the result of evaluating (by narrowing \cite{AntoyEchahedHanus00JACM}) the functional pattern. Thus, the above rule abbreviates the following (infinite) set of rules: \begin{curry} last [e] = e last [x1,e] = e last [x1,x2,e] = e $\ldots$ \end{curry} As we will see in this paper, functional patterns are a powerful feature to express arbitrary selections in term structures. In order to assign a reasonable semantics to functional patterns, one need syntactic conditions (like stratification) to ensure meaningful definitions (e.g., the above rule stating associativity of \ccode{++} is not allowed). Detailed requirements and a constructive implementation of functional patterns by a demand-driven unification procedure can be found in \cite{AntoyHanus05LOPSTR}. If nondeterministic programming techniques are applied, it is sometimes useful to collect all the values of some expression, e.g., to accumulate all results of a query. A ``set-of-values'' operation applied to an arbitrary argument might depend on the degree of evaluation of the argument, which is difficult to grasp in a non-strict language. Hence, \emph{set functions} \cite{AntoyHanus09} have been proposed to encapsulate nondeterministic computations in non-strict functional logic languages. For each defined function $f$, $f\funset$ denotes the corresponding set function. In order to be independent of the evaluation order, $f\funset$ encapsulates only the nondeterminism caused by evaluating $f$ except for the nondeterminism caused by evaluating the arguments to which $f$ is applied. For instance, consider the operation \code{decOrInc} defined by \begin{curry} decOrInc x = (x-1) ? (x+1) \end{curry} Then \ccode{decOrInc$\funset$ 3} evaluates to (an abstract representation of) the set $\{\code{2},\code{4}\}$, i.e., the nondeterminism caused by \code{decOrInc} is encapsulated into a set. However, \ccode{decOrInc$\funset$ (2?5)} evaluates to two different sets $\{\code{1},\code{3}\}$ and $\{\code{4},\code{6}\}$ due to its nondeterministic argument, i.e., the nondeterminism caused by the argument is not encapsulated. As already mentioned, this paper contains the complete source code of our implementation. Actually, it is a literate program \cite{Knuth84}, i.e., the paper's source text is directly executable. In a literate Curry program, all real program code starts with the special character \ccode{>}. Curry code not starting with \ccode{>}, e.g., the example code shown so far, is like a comment and not required to run the program. To give an example of executable code, we show the declaration of the module \code{XCuery} for XML processing in Curry developed in this paper: \begin{lcurry} > module XCuery where > > import XML \end{lcurry} % Thus, we import the system module \code{XML} which contains an XML parser and the definition of XML structures in Curry that are explained in the next section. \section{XML Documents} There are two basic methods to represent XML documents in a programming language: a type-based or a generic representation \cite{WallaceRunciman99}. In a type-based representation, each tagged XML structure (like \code{contacts}, \code{entry}, \code{name} etc) is represented as a record structure of appropriate type according to the XML schema. The advantage of this approach is that schema-correct XML structures correspond to type-correct record structures. On the negative side, this representation depends on the given XML schema. Thus, it is hardly applicable if the schema is not completely known. Moreover, if the schema evolves, the data types representing the XML structure must be adapted. Due to these reasons, we prefer a generic representation where any XML document is represented with one generic structure. Since any XML document is either a structure with a tag, attributes and embedded XML documents (also call \emph{child nodes} of the document), or a text string, one can define the following datatype to represent XML documents:\footnote{% For the sake of simplicity, we ignore other specific elements like comments.} \begin{curry} data XmlExp = XText String | XElem String [(String,String)] [XmlExp] \end{curry} For instance, the second \code{entry} structure of the XML document shown in Figure~\ref{fig:xml-contacts} can be represented by the data term \begin{curry} XElem "entry" [] [XElem "name" [] [XText "Smith"], XElem "first" [] [XText "William"], XElem "nickname" [] [XText "Bill"], XElem "phone" [] [XText "+1-987-742-9388"]] \end{curry} % Since it could be tedious to write XML documents with these basic data constructors, one can define some useful abstractions for XML documents: \begin{curry} xtxt :: String -> XmlExp xtxt s = XText s xml :: String -> [XmlExp] -> XmlExp xml t xs = XElem t [] xs \end{curry} % Thus, we can specify the previous document a bit more compact: \begin{curry} xml "entry" [xml "name" [xtxt "Smith"], xml "first" [xtxt "William"], xml "nickname" [xtxt "Bill"], xml "phone" [xtxt "+1-987-742-9388"]] \end{curry} % These definitions together with operations to parse and pretty-print XML documents are contained in the system module \code{XML} of the PAKCS programming environment for Curry \cite{Hanus10PAKCS}. In principle, these definitions are sufficient for XML processing, i.e., to select and transform XML documents. For instance, one can extract the name and phone number of an \code{entry} structure consisting of a name, first name and phone number by the following operation: \begin{curry} getNamePhone (XElem "entry" [] [XElem "name" [] [XText name], _, XElem "phone" [] [XText phone]]) = name++": "++phone \end{curry} This can be also implemented in a similar way in other functional or logic programming languages. However, functional logic languages support a nicer way to write such matchings. Whereas typical functional or logic languages require the use of data constructors in patterns, functional patterns allow also to use already defined abstractions in patterns so that we can define the previous operation also in the following form: \begin{curry} getNamePhone (xml "entry" [xml "name" [xtxt name], _, xml "phone" [xtxt phone]]) = name++": "++phone \end{curry} This shows how functional patterns improves the readability of pattern matching by reusing already defined abstractions also in patterns and not only to construct new data in right-hand sides of program rules. Apart from these advantages, XML processing operations as defined above have several disadvantages: \begin{itemize} \item The exact structure of the XML document must be known in advance. For instance, the operation \code{getNamePhone} matches only entries with three components, i.e., it fails on both entries shown in Figure~\ref{fig:xml-contacts}. \item In large XML documents, many parts are often irrelevant if one wants to select only some specific information entities. However, one has to define an operation to match the complete document. \item If the structure of the XML document changes (e.g., due to the evolution of the web services providing these documents), one has to update all patterns in the matching operations which could be tedious and error prone for large documents. \end{itemize} % As a solution to these problems, we propose in the next section appropriate abstractions that can be used in patterns of operations for XML processing. \section{Abstractions for XML Processing} In order to define reasonable abstractions for XML processing, we start with a wish list. Since we have seen that exact matchings are not desirable to process semistructured data, we want to develop a language supporting the following features for pattern matching: \begin{itemize} \item \emph{Partial patterns:} allow patterns where only some child nodes are known. \item \emph{Unordered patterns:} allow patterns where child nodes can appear in any order. \item \emph{Patterns at arbitrary depth:} allow patterns that are matched at an arbitrary position in an XML document. \item \emph{Negation of patterns:} allow patterns defined by the absence of tags or provide default values for tags that are not present in the given XML document. \item \emph{Transformation:} generate new structures from matched patterns. \item \emph{Collect matchings:} accumulate results in a newly generated structure. \end{itemize} In the following, we show how these features can be supported by the use of carefully defined abstractions as functional patterns and other features of functional logic programming. \subsection{Partial Patterns} As we have seen in the example operation \code{getNamePhone} above, one would like to select some child nodes in a document independent of the availability of further components. Thus, instead of enumerating the list of \emph{all} child nodes as in the definition above, it would be preferable to enumerate only the relevant child nodes. We support this by putting the operator \ccode{with} in front of the list of child nodes: \begin{curry} getNamePhone (xml "entry" (with [xml "name" [xtxt name], xml "phone" [xtxt phone]])) = name++": "++phone \end{curry} The intended meaning of \ccode{with} is that the given child nodes must be present but in between any number of other elements can also occur. We can directly implement this operator as follows:\footnote{% The symbol ``\lstinline{unknown}'' denotes an anonymous variable, i.e., each occurrence of ``\lstinline{unknown}'' in the right-hand side of a rule denotes a fresh logic variable.} \begin{lcurry} > with :: Data a => [a] -> [a] > with [] = unknown > with (x:xs) = unknown ++ x : with xs \end{lcurry} Thus, an expression like \ccode{with [1,2]} reduces to any list of the form \begin{curry} $x_1$:$\ldots$:$x_m$:1:$y_1$:$\ldots$:$y_n$:2:$zs$ \end{curry} where the variables $x_i,y_j,zs$ are fresh logic variables. Due to the semantics of functional patterns, the definition of \code{getNamePhone} above matches any \code{entry} structure containing a \code{name} and a \code{phone} element as children. Hence, the use of the operation \code{with} in patterns avoids the exact enumeration of all children and makes the program robust against the addition of further information elements in a structure. A disadvantage of a definition like \code{getNamePhone} above is the fact that it matches only XML structures with an empty attribute list due to the definition of the operation \code{xml}. In order to support more flexible matchings that are independent of the given attributes (which are ignored if present), we define the operation \label{sec:xmlprime} \begin{lcurry} > xml' :: String -> [XmlExp] -> XmlExp > xml' t xs = XElem t unknown xs \end{lcurry} For instance, the operation \code{getName} defined by \begin{curry} getName (xml' "entry" (with [xml' "name" [xtxt n]])) = n \end{curry} returns the name of an \code{entry} structure independent of the fact whether the given document contains attributes in the \code{entry} or \code{name} structures. \subsection{Unordered Patterns} If the structure of data evolves over time, it might happen that the order of elements changes over time. Moreover, even in some given XML schema, the order of relevant elements can vary. In order to make the matching independent of a particular order, we can specify that the required child nodes can appear in any order by putting the operator \ccode{anyorder} in front of the list of child nodes: \begin{curry} getNamePhone (xml "entry" (with (anyorder [xml "phone" [xtxt phone], xml "name" [xtxt name]]))) = name++": "++phone \end{curry} Obviously, the operation \code{anyorder} should compute any permutation of its argument list. In a functional logic language, it can be easily defined as a nondeterministic operation by inserting the first element of a list at an arbitrary position in the permutation of the remaining elements: \begin{lcurry} > anyorder :: [a] -> [a] > anyorder [] = [] > anyorder (x:xs) = insert (anyorder xs) > where insert [] = [x] > insert (y:ys) = x:y:ys ? y : insert ys \end{lcurry} % Thus, the previous definition of \code{getNamePhone} matches both \code{entry} structures shown in Figure~\ref{fig:xml-contacts}. \subsection{Patterns at Arbitrary Depths} \label{sec:deepxml} If one wants to select some information in deeply nested documents, it would be tedious to define the exact matching from the root to the required elements. Instead, it is preferable to allow matchings at an arbitrary depth in a document. Such matchings are also supported in other languages like XPath since they ease the implementation of queries in complex structures and support flexibility of the implementation w.r.t.\ to future structural changes of the given documents. We support this feature by an operation \ccode{deepXml}: if \code{deepXml} is used instead of \code{xml} in a pattern, this structure can occur at an arbitrary position in the given document. For instance, if we define \begin{curry} getNamePhone (deepXml "entry" (with [xml "name" [xtxt name], xml "phone" [xtxt phone]])) = name++": "++phone \end{curry} and apply \code{getNamePhone} to the complete document shown in Figure~\ref{fig:xml-contacts}, two results are (nondeterministically) computed (methods to collect all those results are discussed later). The implementation of \code{deepXml} is similar to \code{with} by specifying that \code{deepXml} reduces to a structure where the node is at the root or at some nested child node: \begin{lcurry} > deepXml :: String -> [XmlExp] -> XmlExp > deepXml tag elems = xml tag elems > deepXml tag elems = xml' unknown (unknown ++ [deepXml tag elems] ++ unknown) \end{lcurry} Thus, an expression like \ccode{deepXml $t$ $cs$} reduces to \ccode{xml $t$ $cs$} or to a structure containing this element at some inner position. \subsection{Negation of Patterns} As mentioned above, in semistructured data some information might not be present in a given structure, like the email address in the second entry of Figure~\ref{fig:xml-contacts}. Instead of failing on missing information pieces, one wants to have a constructive behavior in application programs. For instance, one could select all entries with a missing email address or one puts a default nickname in the output if the nickname is missing. In order to implement such behaviors, one could try to negate matchings. Since negation is a non-trivial subject in functional logic programming, we propose a much simpler but practically reasonable solution. We provide an operation \ccode{withOthers} which is similar to \ccode{with} but has a second argument that contains the child nodes that are present but not part of the first argument. Thus, one can use this operation to denote the ``unmatched'' part of a document in order to put arbitrary conditions on it. For instance, if we want to get the name and phone number of an entry that has no email address, we can specify this as follows: \begin{curry} getNamePhoneWithoutEmail (deepXml "entry" (withOthers [xml "name" [xtxt name], xml "phone" [xtxt phone]] others)) | "email" `noTagOf` others = name++": "++phone \end{curry} The useful predicate \code{noTagOf} returns true if the given tag is not a tag of all argument documents (the operation \code{tagOf} returns the tag of an XML document): \begin{lcurry} > noTagOf :: String -> [XmlExp] -> Bool > noTagOf tag = all ((/=tag) . tagOf) \end{lcurry} % Hence, the application of \code{getNamePhoneWithoutEmail} to the document in Figure~\ref{fig:xml-contacts} returns a single value. The implementation of \code{withOthers} is slightly different from \code{with} since we have to accumulate the remaining elements that are not part of the first arguments in the second argument: \begin{lcurry} > withOthers :: Data a => [a] -> [a] -> [a] > withOthers ys zs = withAcc [] ys zs > where -- Accumulate remaining elements: > withAcc prevs [] others | others=:=prevs++suffix = suffix > where suffix free > withAcc prevs (x:xs) others = > prefix ++ x : withAcc (prevs++prefix) xs others > where prefix free \end{lcurry} Thus, an expression like \ccode{withOthers [1,2] $os$} reduces to any list of the form \begin{curry} $x_1$:$\ldots$:$x_m$:1:$y_1$:$\ldots$:$y_n$:2:$zs$ \end{curry} where \code{$os$ $=$ $x_1$:$\ldots$:$x_m$:$y_1$:$\ldots$:$y_n$:$zs$}. If we use this expression as a pattern, the semantics of functional patterns ensures that this pattern matches any list containing the elements \code{1} and \code{2} where the variable $os$ is bound to the list of the remaining elements. \subsection{Transformation of Documents} Apart from the inclusion of data selected in XML documents in the application program, one also wants to implement transformations on documents, e.g., transform an XML document into a corresponding HTML document. Such transformation tasks are almost trivial to implement in declarative languages supporting pattern matching by using a scheme like \[ \mathit{transform}~pattern~=~newdoc \] and applying the $\mathit{transform}$ operation to the given document. For instance, we can transform an \code{entry} document into another XML structure containing the phone number and full name of the person by \label{ex:transphone} \begin{curry} transPhone (deepXml "entry" (with [xml "name" [xtxt n], xml "first" [xtxt f], xml "phone" phone])) = xml "phonename" [xml "phone" phone, xml "fullname" [xtxt (f++' ':n)]] \end{curry} If we apply \code{transPhone} to the document of Figure~\ref{fig:xml-contacts}, we nondeterministically obtain two new XML documents corresponding to the two entries contained in this document. \subsection{Collect Matchings} If we want to collect all matchings in a given document in a single new document, we have to encapsulate the nondeterministic computations performed on the input document. For this purpose, we can exploit set functions described above. Since set functions return an unordered set of values, we have to transform this value set into an ordered list structure that can be printed or embedded in another document. This can be done by the predefined operation \code{sortValues}. Thus, if $c$ denotes the XML document shown in Figure~\ref{fig:xml-contacts}, we can use our previous transformation operation to create a complete table of all pairs of phone numbers and full names by evaluating the expression\footnote{% In the implementation of set functions in the PAKCS environment \cite{Hanus10PAKCS}, one has to write \code{(set$n$ $f$)} for the set function corresponding to the $n$-ary operation $f$.} \begin{curry} xml "table" (sortValues (transPhone$\funset$ $c$)) \end{curry} which yields the representation of the XML document \begin{xmldoc} +1-987-742-9388 William Smith +49-431-8807271 Michael Hanus
\end{xmldoc} Similarly, one can also transform XML documents into HTML documents by exploiting the HTML library of Curry \cite{Hanus01PADL}. Furthermore, one can also nest set functions to accumulate intermediate information. As an example, we want to compute a list of all persons together with the number of their email addresses. For this purpose, we define a matching rule for an \code{entry} document that returns the number of email addresses in this document by a set function \code{emailOf$\funset$}: \begin{curry} getEmails (deepXml "entry" (withOthers [xml "name" [xtxt name]] os)) = (name, length (sortValues (emailOf$\funset$ os))) where emailOf (with [xml "email" email]) = email \end{curry} In order to compute a complete list of all entries matched in a document $c$, we apply the set function \code{getEmails$\funset$} to collect all results in a list structure: \begin{curry} sortValues (getEmails$\funset$ $c$) \end{curry} For our example document, this evaluates to \code{[("Hanus",2),("Smith",0)]}. \subsection{Attribute Matchings} So far we have only defined matchings of XML structures where the attributes are not taken into account. If we want to match on attribute values, we can also use the generic matching operators like \code{with}, \code{anyorder}, or \code{withOthers} for this purpose. For instance, if the \code{first} structure of an XML document contains an attribute \code{sex} to indicate the gender, we can select all male first names by the operation \label{ex:getMaleFirstNames} \begin{curry} getMaleFirstNames (deepXml "entry" (with [XElem "first" (with [("sex","male")]) [xtxt f]])) = f \end{curry} Here, we use the pattern \code{(with [("sex","male")])} for the attribute list in order to match on any occurrence of the attribute \code{sex} with value \code{male}. \section{Properties of the Implementation} \subsection{Correctness} As shown in the previous section, the matching operations are quite powerful and can be directly implemented in a functional logic language. This has the advantage that the correctness of the implemented matching operations is a direct consequence of the correctness results for functional logic programming. We demonstrate this reasoning by a simple example. Consider the following operation to select a name in an \code{entry} document: \begin{curry} getName (xml "entry" (with [xml "name" [xtxt n]])) = n \end{curry} In order to show the correctness of this operation, we have to show the following property ($\to^*$ denotes the evaluation relation): \paragraph{\textbf{Proposition:}} If $xdoc = \code{xml "entry" [\ldots,xml "name" [xtxt $n$],\ldots]}$, then \code{getName $x$ $\to^*$ $n$}. \medskip Since the formal definition of the semantics of functional logic programming is outside the scope of this paper, we provide only a proof sketch. The definition of \code{with} implies that the expression \code{(with [xml "name" [xtxt n]])} evaluates to \begin{curry} x$_1$:$\ldots$:x$_m$:xml "name" [xtxt n]:ys \end{curry} for any $m \geq 0$. Hence, by the semantics of functional patterns, \begin{curry} getName (xml "entry" (x$_1$:$\ldots$:x$_m$:xml "name" [xtxt n]:ys)) = n \end{curry} is a rule defining \code{getName} for any $m \geq 0$ (more precisely, we must also evaluate the operations \code{xml} and \code{xtxt}, but we omit this detail here). Thus, \begin{curry} getName $xdoc$ $~\to^*~$ $n$ \end{curry} is a valid rewrite step. \subsection{Termination} A functional pattern like \code{(with [xml "name" [xtxt n]])} denotes an infinite set of constructor patterns, i.e., it denotes all constructor patterns of the form \begin{curry} x$_1$:$\ldots$:x$_m$:xml "name" [xtxt n]:ys \end{curry} for any $m \geq 0$. Thus, it is not obvious that a search for all possible matchings, which is usually performed by set functions in order to collect all results, will ever terminate. In principle, general termination criteria for functional logic programs with functional patterns are not yet known. However, it should be noted that the set of constructor patterns represented by a functional patterns is not blindly enumerated. Actually, the corresponding constructor patterns are generated in a demand-driven manner, i.e., new constructor patterns are computed only if they are demanded to match the actual argument. Thus, the structure of the actual argument determines how far the operations in the functional patterns are evaluated (see \cite{AntoyHanus05LOPSTR} for more details about the demand-driven unification procedure). Hence, the finite size of the actual arguments (i.e., the XML documents) implies the finiteness of the set of constructor patterns that are computed to match the actual argument.\footnote{% Obviously, this need not be the case for general functional patterns. For instance, if the pattern contains a non-terminating operation like \ccode{loop = loop}, the functional pattern unification will not terminate. However, our operations have the property that a data constructor is produced around each recursive call. Thus, an infinite recursion results in constructor terms of infinite size.} Therefore, the search space is finite in all our examples. \subsection{Performance} Our implementation heavily exploits nondeterministic computations, e.g., when matching partially specified or deep structures, a nondeterministic guessing of appropriate patterns takes place. This raises the question whether this approach can be used in practice. Since our main emphasis is on expressiveness (i.e., we want to be able to express selections and transformations in a declarative rather than navigational manner), we do not intend to compete in performance with specialized languages for XML processing. For our purpose it is sufficient, to be practically useful, that there is a reasonable relation between the time to read an XML document and the time to process it, because each XML document must be read from a file or network connection before processing it. Our first practical experiments (using the PAKCS environment \cite{Hanus10PAKCS} which compiles Curry programs into Prolog programs that are executed by SICStus-Prolog) indicate that the processing time to select or transform documents is almost equal or smaller than the parsing time. Since the XML parser is implemented by deterministic operations without any nondeterministic steps, this shows that the nondeterminism used to implement our matching operators does not hinder the practical application of our implementation. \section{Related Work} Since the processing of semistructured data is a relevant issue in current application systems, there are many proposals for specialized languages or embedding languages in multi-purpose programming languages. We discuss some related approaches in this section. We have already mentioned in the beginning the languages XPath, XQuery, and XSLT for XML processing supported by the W3C. These languages provide a different XML-oriented syntax and use a navigational approach to select information rather than the pattern-oriented approach we proposed. Since these are separate languages, it is more difficult to use them in application programs written in a general purpose language where one wants to process data available in the web. The same is true for the language Xcerpt \cite{BrySchaffert02,BrySchaffertSchroeder05}. It is also a separate XML processing language without a close connection to a multi-purpose programming language. In contrast to XPath, Xcerpt proposes the use of powerful matching constructs to select information in semistructured documents. Xcerpt supports similar features as our embedded language but provide a more compact syntax due to its independence of a concrete base language. In contrast to our approach, Xcerpt requires a dedicated implementation based on a specialized unification procedure \cite{BrySchaffert02ICLP}. The disadvantages of such separate developments become obvious if one tries to access the implementation of Xcerpt (which failed at the time of this writing due to inaccessible web pages and incompatible compiler versions). HaXML \cite{WallaceRunciman99} is a language for XML processing embedded in the functional language Haskell. It provides a rich set of combinators based on \emph{content filters}, i.e., functions that map XML data into collections of XML data. This allows an elegant description of many XML transformations, whereas our rule-based approach is not limited to such transformations since we have no restrictions on the type of data constructed from successful matchings. Caballero et al.\ \cite{CaballeroEtAl10} proposed the embedding of XPath into the functional logic language Toy that has many similarities to Curry. Similarly to our approach, they also exploit nondeterministic evaluation for path selection. Due to the use of a functional logic language allowing inverse computations, they also support the generation of test cases for path expressions, i.e., the generation of documents to which a path expression can be applied. Nevertheless, their approach is limited to the navigational processing of XPath rather than a rule-based approach as in our case. The same holds for FnQuery \cite{SeipelBaumeisterHopfner05}, a domain-specific language embedded in Prolog for the querying and transformation of XML data. \section{Conclusions} We have presented a rule-based language for processing semistructured data that is implemented and embedded in the functional logic language Curry. The language supports a declarative description to query and transform such data. It is based on providing operations to describe partial matchings in the data and exploits functional patterns and set functions for the programming tasks. Due to its embedding into a general-purpose programming language, it can be used to further process the selected data in application systems or one can combine semistructured data from different sources. Moreover, it is easy to extend our language with new features without adapting a complex implementation. The simplicity of our implementation together with the expressiveness of our language demonstrate the general advantages of high-level declarative programming languages. In order to check the usability of our language, we applied it to extract information provided by our university information system\footnote{\url{http://univis.uni-kiel.de/}} in XML format into a curricula and module information system% \footnote{\url{http://www-ps.informatik.uni-kiel.de/~mh/studiengaenge/}} that is implemented in Curry. In this application it was quite useful to specify only partial patterns so that most of the huge amount of information contained in the XML document could be ignored. For future work, we intend to apply our language to more examples in order to enrich the set of useful pattern combinators. Moreover, it would be interesting to generate more efficient implementations by specializing functional patterns (e.g., by partial evaluation w.r.t.\ the given definitions, or by exploiting the XML schema if it is precisely known in advance). \begin{thebibliography}{10} \bibitem{AbiteboulBunemanSuciu00} S.~Abiteboul, P.~Buneman, and D.~Suciu. \newblock {\em Data on the Web: From Relations to Semistructured Data and XML}. \newblock Morgan Kaufmann, 2000. \bibitem{AntoyEchahedHanus00JACM} S.~Antoy, R.~Echahed, and M.~Hanus. \newblock A Needed Narrowing Strategy. \newblock {\em Journal of the ACM}, Vol.~47, No.~4, pp. 776--822, 2000. \bibitem{AntoyHanus02FLOPS} S.~Antoy and M.~Hanus. \newblock Functional Logic Design Patterns. \newblock In {\em Proc.\ of the 6th International Symposium on Functional and Logic Programming (FLOPS 2002)}, pp. 67--87. Springer LNCS 2441, 2002. \bibitem{AntoyHanus05LOPSTR} S.~Antoy and M.~Hanus. \newblock Declarative Programming with Function Patterns. \newblock In {\em Proceedings of the International Symposium on Logic-based Program Synthesis and Transformation (LOPSTR'05)}, pp. 6--22. Springer LNCS 3901, 2005. \bibitem{AntoyHanus09} S.~Antoy and M.~Hanus. \newblock Set Functions for Functional Logic Programming. \newblock In {\em Proceedings of the 11th ACM SIGPLAN International Conference on Principles and Practice of Declarative Programming (PPDP'09)}, pp. 73--82. ACM Press, 2009. \bibitem{AntoyHanus10CACM} S.~Antoy and M.~Hanus. \newblock Functional Logic Programming. \newblock {\em Communications of the ACM}, Vol.~53, No.~4, pp. 74--85, 2010. \bibitem{BrasselHanusMueller08PADL} B.~Bra{\ss}el, M.~Hanus, and M.~M{\"u}ller. \newblock High-Level Database Programming in {Curry}. \newblock In {\em Proc. of the Tenth International Symposium on Practical Aspects of Declarative Languages (PADL'08)}, pp. 316--332. Springer LNCS 4902, 2008. \bibitem{BrySchaffert02} F.~Bry and S.~Schaffert. \newblock A gentle introduction to {Xcerpt}, a rule-based query and transformation language for {XML}. \newblock In {\em Proceedings of the International Workshop on Rule Markup Languages for Business Rules on the Semantic Web (RuleML'02)}, 2002. \bibitem{BrySchaffert02ICLP} F.~Bry and S.~Schaffert. \newblock Towards a Declarative Query and Transformation Language for {XML} and Semistructured Data: Simulation Unification. \newblock In {\em Proceedings of the International Conference on Logic Programming (ICLP'02)}, pp. 255--270. Springer LNCS 2401, 2002. \bibitem{BrySchaffertSchroeder05} F.~Bry, S.~Schaffert, and A.~Schroeder. \newblock A Contribution to the Semantics of {Xcerpt}, a Web Query and Transformation Language. \newblock In {\em Applications of Declarative Programming and Knowledge Management (INAP/WLP 2004)}, pp. 258--268. Springer LNCS 3392, 2005. \bibitem{CaballeroEtAl10} R.~Caballero, Y.~Garc{\'\i}a-Ruiz, and F.~S{\'a}enz-P{\'e}rez. \newblock Integrating {XPath} with the Functional-Logic Language {Toy}. \newblock Technical Report SIC-05-10, Univ. Complutense de Madrid, 2010. \bibitem{CaballeroLopez99} R.~Caballero and F.J. L{\'o}pez-Fraguas. \newblock A Functional-Logic Perspective of Parsing. \newblock In {\em Proc. 4th Fuji International Symposium on Functional and Logic Programming (FLOPS'99)}, pp. 85--99. Springer LNCS 1722, 1999. \bibitem{Fischer05} S.~Fischer. \newblock A Functional Logic Database Library. \newblock In {\em Proc. of the ACM SIGPLAN 2005 Workshop on Curry and Functional Logic Programming (WCFLP 2005)}, pp. 54--59. ACM Press, 2005. \bibitem{GonzalezEtAl99} J.C. Gonz{\'a}lez-Moreno, M.T. Hortal{\'a}-Gonz{\'a}lez, F.J. L{\'o}pez-Fraguas, and M.~Rodr{\'\i}guez-Artalejo. \newblock An approach to declarative programming based on a rewriting logic. \newblock {\em Journal of Logic Programming}, Vol.~40, pp. 47--87, 1999. \bibitem{Hanus00PADL} M.~Hanus. \newblock A Functional Logic Programming Approach to Graphical User Interfaces. \newblock In {\em International Workshop on Practical Aspects of Declarative Languages (PADL'00)}, pp. 47--62. Springer LNCS 1753, 2000. \bibitem{Hanus01PADL} M.~Hanus. \newblock High-Level Server Side Web Scripting in {Curry}. \newblock In {\em Proc.\ of the Third International Symposium on Practical Aspects of Declarative Languages (PADL'01)}, pp. 76--92. Springer LNCS 1990, 2001. \bibitem{Hanus06PPDP} M.~Hanus. \newblock Type-Oriented Construction of Web User Interfaces. \newblock In {\em Proceedings of the 8th ACM SIGPLAN International Conference on Principles and Practice of Declarative Programming (PPDP'06)}, pp. 27--38. ACM Press, 2006. \bibitem{Hanus07ICLP} M.~Hanus. \newblock Multi-paradigm Declarative Languages. \newblock In {\em Proceedings of the International Conference on Logic Programming (ICLP 2007)}, pp. 45--75. Springer LNCS 4670, 2007. \bibitem{Hanus10PAKCS} M.~Hanus, S.~Antoy, B.~Bra{\ss}el, M.~Engelke, K.~H{\"o}ppner, J.~Koj, P.~Niederau, R.~Sadre, and F.~Steiner. \newblock {PAKCS}: The {P}ortland {A}achen {K}iel {C}urry {S}ystem. \newblock Available at \url{http://www.informatik.uni-kiel.de/~pakcs/}, 2010. \bibitem{HanusKoschnicke10PADL} M.~Hanus and S.~Koschnicke. \newblock An {ER-based} Framework for Declarative Web Programming. \newblock In {\em Proc. of the 12th International Symposium on Practical Aspects of Declarative Languages (PADL 2010)}, pp. 201--216. Springer LNCS 5937, 2010. \bibitem{Hanus06Curry} M.~Hanus~(ed.). \newblock Curry: An Integrated Functional Logic Language (Vers.\ 0.8.2). \newblock Available at \url{http://www.curry-language.org}, 2006. \bibitem{Knuth84} D.E. Knuth. \newblock Literate Programming. \newblock {\em The Computer Journal}, Vol.~27, No.~2, pp. 97--111, 1984. \bibitem{PeytonJones03Haskell} S.~Peyton~Jones, editor. \newblock {\em Haskell 98 Language and Libraries---The Revised Report}. \newblock Cambridge University Press, 2003. \bibitem{SeipelBaumeisterHopfner05} D.~Seipel, J.~Baumeister, and M.~Hopfner. \newblock Declaratively Querying and Visualizing Knowledge Bases in {XML}. \newblock In {\em Applications of Declarative Programming and Knowledge Management (INAP/WLP 2004)}, pp. 16--31. Springer LNCS 3392, 2005. \bibitem{WallaceRunciman99} M.~Wallace and C.~Runciman. \newblock Haskell and {XML}: Generic Combinators or Type-Based Translation? \newblock In {\em Proc. of the ACM SIGPLAN International Conference on Functional Programming (ICFP'99)}, pp. 148--159. ACM Press, 1999. \end{thebibliography} \newpage \appendix \section{Further Abstractions} This appendix contains some further abstractions that are not relevant for this paper but useful for XML processing. The operation \code{deepXml} defined in Section~\ref{sec:deepxml} can be used to match XML structures without attributes at an arbitrary position. In order to match structures with a possibly non-empty list of attributes, we provide (analogously to the definition of \code{xml'} in Section~\ref{sec:xmlprime}) the following operation: \begin{lcurry} > deepXml' :: String -> [XmlExp] -> XmlExp > deepXml' tag elems = xml' tag elems > deepXml' tag elems = xml' unknown (unknown ++ [deepXml' tag elems] ++ unknown) \end{lcurry} % If we are also interested to match the attributes of a deep XML structure, we can use the following operation: \begin{lcurry} > deepXElem :: String -> [(String,String)] -> [XmlExp] > -> XmlExp > deepXElem tag attrs elems = XElem tag attrs elems > deepXElem tag attrs elems = xml' unknown (unknown ++ [deepXElem tag attrs elems] ++ unknown) \end{lcurry} For instance, we can use this abstraction to provide a simpler and more general definition of the operation \code{getMaleFirstNames} shown in Section~\ref{ex:getMaleFirstNames}: \begin{curry} getMaleFirstNames (deepXElem "first" (with [("sex","male")]) [xtxt f]) = f \end{curry} % When dealing with semistructured data, it could be the case that one wants to use a default value if some element is not present. For this purpose, we define an operation \code{optXml} such that \ccode{optXml $t$ $xs$ $ys$} evaluates to \ccode{xml $t$ $xs$} if there is no element with tag $t$ in $ys$, otherwise the first element of $ys$ with tag $t$ is returned: \begin{lcurry} > optXml :: String -> [XmlExp] -> [XmlExp] -> XmlExp > optXml tag elems [] = xml tag elems > optXml tag elems (x:xs) = > if tag == tagOf x then x else optXml tag elems xs \end{lcurry} % One can apply this operation in combination with the matching operator \code{withOthers} to check optional occurrences in the remaining elements. As an example, we transform the entries of Figure~\ref{fig:xml-contacts} into \code{nickphone} structures consisting of a nickname and a phone number. The definition is similar to \code{transPhone} (see Section~\ref{ex:transphone}) with the difference that the nickname is assumed to be optional: if it is not present in the given \code{entry} structure, it is generated by concatenating the given names: \begin{curry} transNickPhone (deepXml "entry" (withOthers [xml "name" [xtxt n], xml "first" [xtxt f], xml "phone" phone] others)) = xml "nickphone" [optXml "nickname" [xtxt (f++n)] others, xml "phone" phone] \end{curry} Thus, if $c$ denotes the XML document of Figure~\ref{fig:xml-contacts}, the evaluation of \begin{curry} xml "table" (sortValues (transNickPhone$\funset$ $c$)) \end{curry} yields the representation of the XML document \begin{xmldoc} Bill +1-987-742-9388 MichaelHanus +49-431-8807271
\end{xmldoc} \end{document} % LocalWords: Curry evaluable XML HTML Xcerpt XPath %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% curry-tools-v3.3.0/optimize/.cpm/packages/xml/src/XML.curry000066400000000000000000000373231377556325500236270ustar00rootroot00000000000000------------------------------------------------------------------------------ --- Library for processing XML data. --- --- Warning: the structure of this library is not stable and --- might be changed in the future! --- --- @author Michael Hanus --- @version June 2018 ------------------------------------------------------------------------------ module XML(XmlExp(..),Encoding(..),XmlDocParams(..), tagOf,elemsOf,textOf,textOfXml,xtxt,xml, showXmlDoc,showXmlDocWithParams, writeXmlFile,writeXmlFileWithParams,parseXmlString,readXmlFile, readUnsafeXmlFile,readFileWithXmlDocs,updateXmlFile) where import Data.Char import Data.List (intersperse) import Numeric ------------------------------------------------------------------------------ --- The data type for representing XML expressions. --- @cons XText - a text string (PCDATA) --- @cons XElem - an XML element with tag field, attributes, and a list --- of XML elements as contents data XmlExp = XText String -- text string (PCDATA) | XElem String [(String,String)] [XmlExp] -- (tag attrs contents) deriving (Eq,Ord,Show) ------------------------------------------------------------------------------ --- The data type for encodings used in the XML document. data Encoding = StandardEnc | Iso88591Enc -- Transform an encoding into its XML-attribute form encoding2Attribute :: Encoding -> String encoding2Attribute StandardEnc = "" encoding2Attribute Iso88591Enc = "encoding=\"iso-8859-1\" " -- Transform an encoding into its encoding-function encoding2EncFunc :: Encoding -> String -> String encoding2EncFunc StandardEnc = standardEncoding encoding2EncFunc Iso88591Enc = iso88591Encoding ------------------------------------------------------------------------------ -- List of encoding maps ------------------------------------------------------------------------------ -- standard encoding map standardEncoding :: String -> String standardEncoding [] = [] standardEncoding (c:cs) | c=='<' = "<" ++ standardEncoding cs | c=='>' = ">" ++ standardEncoding cs | c=='&' = "&" ++ standardEncoding cs | c=='"' = """ ++ standardEncoding cs | c=='\'' = "'" ++ standardEncoding cs | ord c < 32 = "&#" ++ show (ord c) ++ ";" ++ standardEncoding cs | ord c > 127 = "&#" ++ show (ord c) ++ ";" ++ standardEncoding cs | otherwise = c : standardEncoding cs -- iso-8859-1 iso88591Encoding :: String -> String iso88591Encoding [] = [] iso88591Encoding (c:cs) = if ord c `elem` iso88591list then c : iso88591Encoding cs else standardEncoding [c] ++ iso88591Encoding cs -- iso-8859-1-list -- not yet completed... iso88591list :: [Int] iso88591list = [192,193,194,195,196,197,198,199,200,201,202,203,204,205,207, 208,209,210,211,212,214,216,217,218,219,220,221,224,225,228, 229,226,227,230,231,233,232,235,234,236,237,239,240,241,248, 246,242,243,244,245,250,249,252,251,253,255] ------------------------------------------------------------------------------ --- The data type for XML document parameters. --- @cons Enc - the encoding for a document --- @cons DtdUrl - the url of the DTD for a document data XmlDocParams = Enc Encoding | DtdUrl String -- get the right encoding (i.e., first or standard encoding if not present) -- from a list of XmlDocParams lookupEncoding :: [XmlDocParams] -> Encoding lookupEncoding (Enc f:_) = f lookupEncoding (DtdUrl _:l) = lookupEncoding l lookupEncoding [] = StandardEnc -- get the first DtdUrl from a list of XmlDocParams lookupDtdUrl :: [XmlDocParams] -> String lookupDtdUrl [] = "" lookupDtdUrl (Enc _ : l) = lookupDtdUrl l lookupDtdUrl (DtdUrl url : _) = url -- does a XmlDocParam include a DtdUrl? hasDtdUrl :: [XmlDocParams] -> Bool hasDtdUrl [] = False hasDtdUrl (DtdUrl _:_) = True hasDtdUrl (Enc _:l) = hasDtdUrl l ------------------------------------------------------------------------------ -- useful selectors: --- Returns the tag of an XML element (or empty for a textual element). tagOf :: XmlExp -> String tagOf (XElem tag _ _) = tag tagOf (XText _) = "" --- Returns the child elements an XML element. elemsOf :: XmlExp -> [XmlExp] elemsOf (XElem _ _ xexps) = xexps elemsOf (XText _) = [] --- Extracts the textual contents of a list of XML expressions. --- Useful auxiliary function when transforming XML expressions into --- other data structures. --- --- For instance, --- textOf [XText "xy", XElem "a" [] [], XText "bc"] == "xy bc" textOf :: [XmlExp] -> String textOf = unwords . filter (not . null) . map textOfXmlExp where textOfXmlExp (XText s) = s textOfXmlExp (XElem _ _ xs) = textOf xs --- Included for backward compatibility, better use textOf! textOfXml :: [XmlExp] -> String textOfXml = textOf ------------------------------------------------------------------------------ -- some useful abbreviations: --- Basic text (maybe containing special XML chars). xtxt :: String -> XmlExp xtxt s = XText s --- XML element without attributes. xml :: String -> [XmlExp] -> XmlExp xml t c = XElem t [] c ------------------------------------------------------------------------------ -- Pretty printer for XML documents ------------------------------------------------------------------------------ --- Writes a file with a given XML document. writeXmlFile :: String -> XmlExp -> IO () writeXmlFile file xexp = writeXmlFileWithParams file [Enc StandardEnc] xexp --- Writes a file with a given XML document and XML parameters. writeXmlFileWithParams :: String -> [XmlDocParams] -> XmlExp -> IO () writeXmlFileWithParams file ps xexp = writeFile file (showXmlDocWithParams ps xexp) ------------------------------------------------------------------------------ --- Show an XML document in indented format as a string. ------------------------------------------------------------------------------ showXmlDoc :: XmlExp -> String showXmlDoc xexp = showXmlDocWithParams [] xexp showXmlDocWithParams :: [XmlDocParams] -> XmlExp -> String showXmlDocWithParams ps (XElem root attrL xmlEL) = "\n\n" ++ (if hasDtdUrl ps then "\n\n" else "") ++ showXmlExp 0 (encoding2EncFunc (lookupEncoding ps)) (XElem root attrL xmlEL) showXmlDocWithParams _ (XText _) = error "XML.showXmlDocWithParams: document without tags" showXmlExp :: Int -> (String -> String) -> XmlExp -> String showXmlExp i encFun (XText s) = xtab i ++ (encFun s) ++ "\n" showXmlExp i encFun (XElem tag attrs xexps) = xtab i ++ showXmlOpenTag tag attrs encFun ++ if null xexps then " />\n" else if length xexps == 1 && isXText (head xexps) then let [XText s] = xexps in ">" ++ (encFun s) ++ "\n" else ">\n" ++ showXmlExps (i+2) xexps encFun ++ xtab i ++ "\n" xtab :: Int -> String xtab n = take n (repeat ' ') showXmlOpenTag :: String -> [(String, a)] -> (a -> String) -> String showXmlOpenTag tag attrs encFun = "<" ++ tag ++ concat (map ((" "++) . attr2string) attrs) where attr2string (attr,value) = attr ++ "=\"" ++ (encFun value) ++ "\"" showXmlExps :: Int -> [XmlExp] -> (String -> String) -> String showXmlExps encFun xexps i = concatMap (showXmlExp encFun i) xexps isXText :: XmlExp -> Bool isXText (XText _) = True isXText (XElem _ _ _) = False -- unquote special characters (<,>,&,',") in an XML string: xmlUnquoteSpecials :: String -> String xmlUnquoteSpecials [] = [] xmlUnquoteSpecials (c:cs) | c=='&' = let (special,rest) = splitAtChar ';' cs in xmlUnquoteSpecial special rest | otherwise = c : xmlUnquoteSpecials cs xmlUnquoteSpecial :: String -> String -> String xmlUnquoteSpecial special cs | special=="lt" = '<' : xmlUnquoteSpecials cs | special=="gt" = '>' : xmlUnquoteSpecials cs | special=="amp" = '&' : xmlUnquoteSpecials cs | special=="quot" = '"' : xmlUnquoteSpecials cs | special=="apos" = '\'' : xmlUnquoteSpecials cs | special=="auml" = '\228' : xmlUnquoteSpecials cs | special=="ouml" = '\246' : xmlUnquoteSpecials cs | special=="uuml" = '\252' : xmlUnquoteSpecials cs | special=="Auml" = '\196' : xmlUnquoteSpecials cs | special=="Ouml" = '\214' : xmlUnquoteSpecials cs | special=="Uuml" = '\220' : xmlUnquoteSpecials cs | special=="szlig"= '\223' : xmlUnquoteSpecials cs | otherwise = unquoteUnicode special ++ xmlUnquoteSpecials cs unquoteUnicode :: String -> String unquoteUnicode [] = [] unquoteUnicode (c:cs) | c=='#' = case cs of 'x':cs' -> [chr (extr (readHex cs'))] cs' -> [chr (extr (readInt cs'))] | otherwise = '&':(c:cs) ++ ";" where extr [(a,"")] = a ------------------------------------------------------------------------------ -- Parser for XML documents ------------------------------------------------------------------------------ --- Reads a file with an XML document and returns --- the corresponding XML expression. readXmlFile :: String -> IO XmlExp readXmlFile file = do xmlstring <- readFile file let xexps = parseXmlString xmlstring if null xexps then error ("File "++file++" contains no XML document!") else if null (tail xexps) then return (head xexps) else error ("File "++file++" contains more than one XML document!") --- Tries to read a file with an XML document and returns --- the corresponding XML expression, if possible. --- If file or parse errors occur, Nothing is returned. readUnsafeXmlFile :: String -> IO (Maybe XmlExp) readUnsafeXmlFile file = catch (readXmlFile file >>= return . Just) (\_ -> return Nothing) --- Pretty prints the contents of an XML file. showXmlFile :: String -> IO () showXmlFile file = readXmlFile file >>= putStr . showXmlDoc --- Reads a file with an arbitrary sequence of XML documents and --- returns the list of corresponding XML expressions. readFileWithXmlDocs :: String -> IO [XmlExp] readFileWithXmlDocs file = readFile file >>= return . parseXmlString ------------------------------------------------------------------------------ --- Transforms an XML string into a list of XML expressions. --- If the XML string is a well structured document, the list --- of XML expressions should contain exactly one element. parseXmlString :: String -> [XmlExp] parseXmlString s = fst (parseXmlTokens (scanXmlString s) Nothing) -- parse a list of XML tokens into list of XML expressions: -- parseXmlTokens tokens stoptoken = (xml_expressions, remaining_tokens) parseXmlTokens :: [XmlExp] -> Maybe String -> ([XmlExp],[XmlExp]) parseXmlTokens [] Nothing = ([],[]) parseXmlTokens [] (Just _) = error "XML.parseXmlTokens: incomplete parse" parseXmlTokens (XText s : xtokens) stop = let (xexps, rem_xtokens) = parseXmlTokens xtokens stop in (XText (xmlUnquoteSpecials s) : xexps, rem_xtokens) parseXmlTokens (XElem (t:ts) args cont : xtokens) stop | t == '<' && head ts /= '/' = let (xexps1, xtokens1) = parseXmlTokens xtokens (Just ts) (xexps, rem_xtokens) = parseXmlTokens xtokens1 stop in (XElem ts args xexps1 : xexps, rem_xtokens) | t == '<' && head ts == '/' = if maybe False (==(tail ts)) stop then ([], xtokens) -- stop this parser if appropriate stop token reached else let (xexps, rem_xtokens) = parseXmlTokens xtokens stop in (XElem ts args cont : xexps, rem_xtokens) | otherwise = let (xexps, rem_xtokens) = parseXmlTokens xtokens stop in (XElem (t:ts) args cont : xexps, rem_xtokens) parseXmlTokens (XElem [] _ _ : _) _ = error "XML.parseXmlTokens: incomplete parse" -- scan an XML string into list of XML tokens: -- here we reuse XML expressions for representing XML tokens: -- single open or closing tags are returned by the scanner -- as an XElem with no contents and first character '<' added to the tag field scanXmlString :: String -> [XmlExp] scanXmlString s = scanXml (dropBlanks s) where scanXml [] = [] scanXml (c:cs) = if c=='<' then scanXmlElem cs else let (initxt,remtag) = scanXmlText (c:cs) in XText initxt : scanXml remtag -- scan an XML text until next tag and remove superflous blanks: scanXmlText :: String -> (String,String) --original definition: --scanXmlText s = let (s1,s2) = break (=='<') s -- in (concat (intersperse " " (words s1)), s2) --this implementation is more efficient: scanXmlText [] = ([],[]) scanXmlText (c:cs) | c=='<' = ([],c:cs) | isSpace c = let (txt,rem) = scanXmlText (dropBlanks cs) in (if null txt then txt else ' ':txt, rem) | otherwise = let (txt,rem) = scanXmlText cs in (c:txt,rem) -- scan an XML element: scanXmlElem :: String -> [XmlExp] scanXmlElem [] = [] scanXmlElem (c:cs) | c=='!' = if take 2 cs == "--" then scanXmlComment (drop 2 cs) else scanXmlCData cs | c=='?' = scanXmlProcInstr cs | otherwise = scanXmlElemName [c] cs scanXmlElemName :: String -> String -> [XmlExp] scanXmlElemName ct [] = [XElem ('<':ct) [] []] scanXmlElemName ct (c:cs) | c=='>' = XElem ('<':ct) [] [] : scanXmlString cs | isSpace c = let (attrs,rest) = parseAttrs (dropBlanks cs) in if (head rest)=='/' then XElem ct attrs [] : scanXmlString (drop 2 rest) else XElem ('<':ct) attrs [] : scanXmlString (tail rest) | c=='/' && head cs == '>' = XElem ct [] [] : scanXmlString (tail cs) | otherwise = scanXmlElemName (ct++[c]) cs -- scan (and drop) an XML comment: scanXmlComment :: String -> [XmlExp] scanXmlComment [] = [] scanXmlComment (c:cs) = if c=='-' && take 2 cs == "->" then scanXmlString (drop 2 cs) else scanXmlComment cs -- scan (and drop) an XML CDATA element (simplified version): scanXmlCData :: String -> [XmlExp] scanXmlCData cs = let rest = dropCData cs in if head rest == '>' then scanXmlString (tail rest) else scanXmlCData rest dropCData :: String -> String dropCData [] = [] dropCData (c:cs) | c=='[' = tail (dropWhile (/=']') cs) -- must be improved | c=='>' = c:cs | otherwise = dropCData cs -- scan (and drop) an XML processing instructions: scanXmlProcInstr :: String -> [XmlExp] scanXmlProcInstr [] = [] scanXmlProcInstr (c:cs) = if c=='?' && head cs == '>' then scanXmlString (tail cs) else scanXmlProcInstr cs -- parse a string as an attribute list: parseAttrs :: String -> ([(String,String)],String) parseAttrs [] = ([],[]) parseAttrs (c:cs) | isAlpha c = let (name,rest1) = splitAtChar '=' (c:cs) (value,rest2) = splitAtChar '"' (tail rest1) (rem_attrs,rem_inp) = parseAttrs (dropBlanks rest2) in ((name,xmlUnquoteSpecials value):rem_attrs, rem_inp) | otherwise = ([],c:cs) -- drop blanks in input string: dropBlanks :: String -> String dropBlanks = dropWhile isSpace -- split string at particular character, if possible: splitAtChar :: Char -> String -> (String, String) splitAtChar _ [] = ([],[]) splitAtChar char (c:cs) = if c==char then ([],cs) else let (first,rest) = splitAtChar char cs in (c:first,rest) ------------------------------------------------------------------------------ --- An action that updates the contents of an XML file by some transformation --- on the XML document. --- @param f - the function to transform the XML document in the file --- @param file - the name of the XML file updateXmlFile :: (XmlExp -> XmlExp) -> String -> IO () updateXmlFile xmltrans filename = do xdoc <- readXmlFile filename writeXmlFile filename $!! (xmltrans xdoc) -- end of XML library curry-tools-v3.3.0/optimize/.cpm/packages/xml/src/XmlConv.curry000066400000000000000000000756121377556325500245600ustar00rootroot00000000000000--- Provides type-based combinators to construct XML converters. --- Arbitrary XML data can be represented as algebraic datatypes and vice versa. --- See --- here for a description of this library. --- --- @author Sebastian Fischer (with changes by Michael Hanus) --- @version February 2015 {-# OPTIONS_CYMAKE -Wno-incomplete-patterns -Wno-overlapping #-} module XmlConv ( -- converter types XElemConv, XAttrConv, XPrimConv, XOptConv, XRepConv, -- Reads and Shows types for XML trees XmlReads, XmlShows, -- read and show functions xmlRead, xmlShow, xmlReads, xmlShows, -- converter for primitive values int, float, char, string, -- combinators for complex XML data (!), element, empty, attr, adapt, opt, rep, -- attribute converter for primitive values and booleans aInt, aFloat, aChar, aString, aBool, -- element converter eInt, eFloat, eChar, eString, eBool, eEmpty, eOpt, eRep, -- converter for sequences seq1, seq2, seq3, seq4, seq5, seq6, -- converter for repeated sequences repSeq1, repSeq2, repSeq3, repSeq4, repSeq5, repSeq6, -- element converter for sequences eSeq1, eSeq2, eSeq3, eSeq4, eSeq5, eSeq6, -- element converter for repeated sequences eRepSeq1, eRepSeq2, eRepSeq3, eRepSeq4, eRepSeq5, eRepSeq6 ) where import XML import ReadShowTerm ( readQTerm ) infixr 0 ! infixl 1 />= --- Phantom type for XML data that may be part of a repetition data Repeatable = Repeatable --- Phantom type for XML data that must not be part of a repetition data NotRepeatable = NotRepeatable --- Phantom type for single elements data Elem = Elem --- Phantom type for primitive values, multiple elements and/or attributes data NoElem = NoElem type Attrs = [(String,String)] type Childs = (Attrs,[XmlExp]) --- Type of functions that consume some XML data to compute a result type XmlReads a = Childs -> (a,Childs) --- Type of functions that extend XML data corresponding to a given value type XmlShows a = a -> Childs -> Childs data XmlConv _ _ a = Conv (XmlReads a) (XmlShows a) type ValConv a = (String -> a,a -> String) --- Type of converters for XML elements type XElemConv a = XmlConv Repeatable Elem a --- Type of converters for attributes type XAttrConv a = XmlConv NotRepeatable NoElem a --- Type of converters for primitive values type XPrimConv a = XmlConv NotRepeatable NoElem a --- Type of converters for optional values type XOptConv a = XmlConv NotRepeatable NoElem a --- Type of converters for repetitions type XRepConv a = XmlConv NotRepeatable NoElem a --- Type of converters for sequences type XSeqConv a = XmlConv NotRepeatable NoElem a -- Monadic bind for XML parser (/>=) :: XmlReads a -> (a -> XmlReads b) -> XmlReads b rd />= f = \childs -> case rd childs of (a,childs') -> f a childs' -- Monadic return for XML parser ret :: a -> XmlReads a ret x y = (x,y) --- Takes an XML converter and returns a function that consumes XML data --- and returns the remaining data along with the result. --- --- @param conv XML converter --- @return XmlReads function xmlReads :: XmlConv _ _ a -> XmlReads a xmlReads (Conv rd _) = rd --- Takes an XML converter and returns a function that extends XML data --- with the representation of a given value. --- --- @param conv XML converter --- @return XmlShows function xmlShows :: XmlConv _ _ a -> XmlShows a xmlShows (Conv _ sh) = sh --- Takes an XML converter and an XML expression and returns a --- corresponding Curry value. --- --- @param conv XML converter --- @return XML read function xmlRead :: XmlConv _ Elem a -> XmlExp -> a xmlRead xa x = a where (a,([],[])) = xmlReads xa ([],[x]) --- Takes an XML converter and a value and returns a corresponding --- XML expression. --- --- @param conv XML converter --- @return XML show function xmlShow :: XmlConv _ Elem a -> a -> XmlExp xmlShow xa a = x where ([],[x]) = xmlShows xa a ([],[]) int_ :: ValConv Int int_ = (read,show) float_ :: ValConv Float float_ = (readQTerm,show) char_ :: ValConv Char char_ = (head,(:[])) string_ :: ValConv String string_ = (id,id) bool_ :: String -> String -> ValConv Bool bool_ true false = (readBool,showBool) where fromJust (Just x) = x readBool s = fromJust (lookup s [(true,True),(false,False)]) showBool b = if b then true else false val_ :: ValConv a -> XPrimConv a val_ (rda,sha) = Conv rd sh where rd childs = (rda a,(attrs,elems)) where (attrs,XText a : elems) = childs sh a childs = (attrs,XText (sha a) : elems) where (attrs,elems) = childs --- Creates an XML converter for integer values. Integer values must not be --- used in repetitions and do not represent XML elements. --- --- @return Int converter int :: XPrimConv Int int = val_ int_ --- Creates an XML converter for float values. Float values must not be --- used in repetitions and do not represent XML elements. --- --- @return Float converter float :: XPrimConv Float float = val_ float_ --- Creates an XML converter for character values. Character values must not be --- used in repetitions and do not represent XML elements. --- --- @return Char converter char :: XPrimConv Char char = val_ char_ --- Creates an XML converter for string values. String values must not be --- used in repetitions and do not represent XML elements. --- --- @return String converter string :: XPrimConv String string = Conv rd sh where rd childs = ("",childs) ? case elems of XText s : elems' -> (s,(attrs,elems')) where (attrs,elems) = childs sh "" childs = childs sh s@(_:_) childs = (attrs,XText s : elems) where (attrs,elems) = childs --- Parallel composition of XML converters. --- --- @return Nondeterministic choice of XML converters (!) :: XmlConv rep elem a -> XmlConv rep elem a -> XmlConv rep elem a (Conv rd1 sh1) ! (Conv rd2 sh2) = Conv rd sh where rd childs = rd1 childs ? rd2 childs sh x = sh1 x ? sh2 x --- Takes an arbitrary XML converter and returns a converter representing --- an XML element that contains the corresponding data. XML elements may be --- used in repetitions. --- --- @param name Tag name of the XML element --- @param conv XML converter for the childs of the XML element --- @return XML converter representing an XML element element :: String -> XmlConv _ _ a -> XElemConv a element name xa = Conv rd sh where rd childs | myName==name = case xmlReads xa (myAttrs,myElems) of (a,([],[])) -> (a,(attrs,elems)) where (attrs,XElem myName myAttrs myElems : elems) = childs sh a childs = case xmlShows xa a ([],[]) of (myAttrs,myElems) -> (attrs,XElem name myAttrs myElems : elems) where (attrs,elems) = childs --- Takes a value and returns an XML converter for this value which is not --- represented as XML data. Empty XML data must not be used in repetitions --- and does not represent an XML element. --- --- @param val Value without an XML representation --- @return Empty XML converter empty :: Data a => a -> XPrimConv a empty val = Conv rd sh where rd = ret val sh v childs | v=:=val = childs --- Takes a name and string conversion functions and returns an XML converter --- that represents an attribute. Attributes must not be used in repetitions --- and do not represent an XML element. --- --- @param name Attribute name --- @param readShow functions that convert between values and strings --- @return Attribute converter attr :: String -> ValConv a -> XAttrConv a attr name (rda,sha) = Conv rd sh where rd childs = (rda value,(attrs',elems)) where (attrs,elems) = childs ((_,value),attrs') = exposeBy ((name==) . fst) attrs sh a childs = ((name,sha a) : attrs,elems) where (attrs,elems) = childs -- Fetch a list element that satisfies a given predicate. exposeBy :: (a -> Bool) -> [a] -> (a,[a]) exposeBy p (x:xs) = if p x then (x,xs) else (y,x:ys) where (y,ys) = exposeBy p xs --- Converts between arbitrary XML converters for different types. --- --- @param a2b_b2a functions that convert between values of types a and b --- @param conv XML converter for type a --- @return XML converter for type b adapt :: (a -> b,b -> a) -> XmlConv rep e a -> XmlConv rep e b adapt (a2b,b2a) (Conv rda sha) = Conv rd sh where rd = rda />= ret . a2b sh = sha . b2a --- Creates a converter for arbitrary optional XML data. Optional XML data --- must not be used in repetitions and does not represent an XML element. --- --- @param conv XML converter --- @return XML converter for optional data represented by the given converter opt :: XmlConv _ _ a -> XOptConv (Maybe a) opt xa = Conv rd sh where rd childs = ret Nothing childs ? (xmlReads xa />= ret . Just) childs sh Nothing = id sh (Just a) = xmlShows xa a --- Takes an XML converter representing repeatable data and returns an --- XML converter that represents repetitions of this data. Repetitions --- must not be used in other repetitions and do not represent XML elements. --- --- @param conv XML converter representing repeatable data --- @return XML converter representing repetitions rep :: XmlConv Repeatable _ a -> XRepConv [a] rep xa = Conv rd sh where rd childs = ret [] childs ? ( xmlReads xa />= \x -> rd />= \xs -> ret (x:xs)) childs sh = foldr (.) id . map (xmlShows xa) --- Creates an XML converter for integer attributes. Integer attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @return Int attribute converter aInt :: String -> XAttrConv Int aInt name = attr name int_ --- Creates an XML converter for float attributes. Float attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @return Float attribute converter aFloat :: String -> XAttrConv Float aFloat name = attr name float_ --- Creates an XML converter for character attributes. Character attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @return Char attribute converter aChar :: String -> XAttrConv Char aChar name = attr name char_ --- Creates an XML converter for string attributes. String attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @return String attribute converter aString :: String -> XAttrConv String aString name = attr name string_ --- Creates an XML converter for boolean attributes. Boolean attributes --- must not be used in repetitions and do not represent XML elements. --- --- @param name Attribute name --- @param true String representing True --- @param false String representing False --- @return Bool attribute converter aBool :: String -> String -> String -> XAttrConv Bool aBool name true false = attr name (bool_ true false) --- Creates an XML converter for integer elements. Integer elements may be --- used in repetitions. --- --- @param name Tag name of the XML element containing the integer value --- @return Int element converter eInt :: String -> XElemConv Int eInt name = element name int --- Creates an XML converter for float elements. Float elements may be --- used in repetitions. --- --- @param name Tag name of the XML element containing the float value --- @return Float element converter eFloat :: String -> XElemConv Float eFloat name = element name float --- Creates an XML converter for character elements. Character elements may be --- used in repetitions. --- --- @param name Tag name of the XML element containing the character value --- @return Char element converter eChar :: String -> XElemConv Char eChar name = element name char --- Creates an XML converter for string elements. String elements may be --- used in repetitions. --- --- @param name Tag name of the XML element containing the string value --- @return String element converter eString :: String -> XElemConv String eString name = element name string --- Creates an XML converter for boolean elements. Boolean elements may be --- used in repetitions. --- --- @param true Tag name of the XML element representing True --- @param false Tag name of the XML element representing False --- @return Bool element converter eBool :: String -> String -> XElemConv Bool eBool true false = eEmpty true True ! eEmpty false False --- Takes a name and a value and creates an empty XML element that represents --- the given value. The created element may be used in repetitions. --- --- @param name Tag name of the empty element --- @param val Value represented by the empty element --- @return XML converter representing an empty XML element eEmpty :: Data a => String -> a -> XElemConv a eEmpty name a = element name (empty a) --- Creates an XML converter that represents an element containing --- optional XML data. The created element may be used in repetitions. --- --- @param name Tag name of the element containing optional XML data --- @return XML converter for an element enclosing optional XML data eOpt :: String -> XmlConv _ _ a -> XElemConv (Maybe a) eOpt name xa = element name (opt xa) --- Creates an XML converter that represents an element containing --- repeated XML data. The created element may be used in repetitions. --- --- @param name Tag name of the element containing repeated XML data --- @return XML converter for an element enclosing repeated XML data eRep :: String -> XmlConv Repeatable _ a -> XElemConv [a] eRep name xa = element name (rep xa) --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq1 :: (Data a, Data b) => (a -> b) -> XmlConv rep _ a -> XmlConv rep NoElem b seq1 cons xa = Conv rd sh where rd = xmlReads xa />= ret . cons sh arg | cons a =:<= arg = xmlShows xa a where a free --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions but does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq1 :: (Data a, Data b) => (a -> b) -> XmlConv Repeatable _ a -> XRepConv [b] repSeq1 cons xa = rep (seq1 cons xa) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq1 :: (Data a, Data b) => String -> (a -> b) -> XmlConv _ _ a -> XElemConv b eSeq1 name cons xa = element name (seq1 cons xa) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq1 :: (Data a, Data b) => String -> (a -> b) -> XmlConv Repeatable _ a -> XElemConv [b] eRepSeq1 name cons xa = element name (repSeq1 cons xa) seq2_ :: (Data a, Data b, Data c) => (a -> b -> c) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ NoElem c seq2_ cons xa xb = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> ret (cons a b) sh arg | cons a b =:<= arg = xmlShows xa a . xmlShows xb b where a,b free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq2 :: (Data a, Data b, Data c) => (a -> b -> c) -> XmlConv _ _ a -> XmlConv _ _ b -> XSeqConv c seq2 = seq2_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq2 :: (Data a, Data b, Data c) => (a -> b -> c) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XRepConv [c] repSeq2 cons xa xb = rep (seq2_ cons xa xb) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq2 :: (Data a, Data b, Data c) => String -> (a -> b -> c) -> XmlConv _ _ a -> XmlConv _ _ b -> XElemConv c eSeq2 name cons xa xb = element name (seq2 cons xa xb) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq2 :: (Data a, Data b, Data c) => String -> (a -> b -> c) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XElemConv [c] eRepSeq2 name cons xa xb = element name (repSeq2 cons xa xb) seq3_ :: (Data a, Data b, Data c, Data d) => (a -> b -> c -> d) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ NoElem d seq3_ cons xa xb xc = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> xmlReads xc />= \c -> ret (cons a b c) sh arg | (cons a b c) =:<= arg = xmlShows xa a . xmlShows xb b . xmlShows xc c where a,b,c free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq3 :: (Data a, Data b, Data c, Data d) => (a -> b -> c -> d) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XSeqConv d seq3 = seq3_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq3 :: (Data a, Data b, Data c, Data d) => (a -> b -> c -> d) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XRepConv [d] repSeq3 cons xa xb xc = rep (seq3_ cons xa xb xc) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq3 :: (Data a, Data b, Data c, Data d) => String -> (a -> b -> c -> d) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XElemConv d eSeq3 name cons xa xb xc = element name (seq3 cons xa xb xc) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq3 :: (Data a, Data b, Data c, Data d) => String -> (a -> b -> c -> d) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XElemConv [d] eRepSeq3 name cons xa xb xc = element name (repSeq3 cons xa xb xc) seq4_ :: (Data a, Data b, Data c, Data d, Data e) => (a -> b -> c -> d -> e) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ NoElem e seq4_ cons xa xb xc xd = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> xmlReads xc />= \c -> xmlReads xd />= \d -> ret (cons a b c d) sh arg | (cons a b c d) =:<= arg = xmlShows xa a . xmlShows xb b . xmlShows xc c . xmlShows xd d where a,b,c,d free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq4 :: (Data a, Data b, Data c, Data d, Data e) => (a -> b -> c -> d -> e) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XSeqConv e seq4 = seq4_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq4 :: (Data a, Data b, Data c, Data d, Data e) => (a -> b -> c -> d -> e) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XRepConv [e] repSeq4 cons xa xb xc xd = rep (seq4_ cons xa xb xc xd) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq4 :: (Data a, Data b, Data c, Data d, Data e) => String -> (a -> b -> c -> d -> e) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XElemConv e eSeq4 name cons xa xb xc xd = element name (seq4 cons xa xb xc xd) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq4 :: (Data a, Data b, Data c, Data d, Data e) => String -> (a -> b -> c -> d -> e) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XElemConv [e] eRepSeq4 name cons xa xb xc xd = element name (repSeq4 cons xa xb xc xd) seq5_ :: (Data a, Data b, Data c, Data d, Data e, Data f) => (a -> b -> c -> d -> e -> f) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XmlConv _ NoElem f seq5_ cons xa xb xc xd xe = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> xmlReads xc />= \c -> xmlReads xd />= \d -> xmlReads xe />= \e -> ret (cons a b c d e) sh arg | (cons a b c d e) =:<= arg = xmlShows xa a . xmlShows xb b . xmlShows xc c . xmlShows xd d . xmlShows xe e where a,b,c,d,e free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq5 :: (Data a, Data b, Data c, Data d, Data e, Data f) => (a -> b -> c -> d -> e -> f) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XSeqConv f seq5 = seq5_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq5 :: (Data a, Data b, Data c, Data d, Data e, Data f) => (a -> b -> c -> d -> e -> f) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XmlConv Repeatable _ e -> XRepConv [f] repSeq5 cons xa xb xc xd xe = rep (seq5_ cons xa xb xc xd xe) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq5 :: (Data a, Data b, Data c, Data d, Data e, Data f) => String -> (a -> b -> c -> d -> e -> f) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XElemConv f eSeq5 name cons xa xb xc xd xe = element name (seq5 cons xa xb xc xd xe) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq5 :: (Data a, Data b, Data c, Data d, Data e, Data f) => String -> (a -> b -> c -> d -> e -> f) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XmlConv Repeatable _ e -> XElemConv [f] eRepSeq5 name cons xa xb xc xd xe = element name (repSeq5 cons xa xb xc xd xe) seq6_ :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => (a -> b -> c -> d -> e -> f -> g) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XmlConv _ _ f -> XmlConv _ NoElem g seq6_ cons xa xb xc xd xe xf = Conv rd sh where rd = xmlReads xa />= \a -> xmlReads xb />= \b -> xmlReads xc />= \c -> xmlReads xd />= \d -> xmlReads xe />= \e -> xmlReads xf />= \f -> ret (cons a b c d e f) sh arg | (cons a b c d e f) =:<= arg = xmlShows xa a . xmlShows xb b . xmlShows xc c . xmlShows xd d . xmlShows xe e . xmlShows xf f where a,b,c,d,e,f free --- Creates an XML converter representing a sequence of arbitrary XML data. --- The sequence must not be used in repetitions and does not represent an --- XML element. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a sequence seq6 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => (a -> b -> c -> d -> e -> f -> g) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XmlConv _ _ f -> XSeqConv g seq6 = seq6_ --- Creates an XML converter that represents a repetition of a sequence --- of repeatable XML data. The repetition may be used in other --- repetitions and does not represent an XML element. This combinator is --- provided because converters for repeatable sequences cannot be --- constructed by the seq combinators. --- --- @param f Invertable function (constructor) that combines the sequence --- @param conv(s) XML converter for the data contained in the sequence --- @return XML converter representing a repetition of a sequence repSeq6 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => (a -> b -> c -> d -> e -> f -> g) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XmlConv Repeatable _ e -> XmlConv Repeatable _ f -> XRepConv [g] repSeq6 cons xa xb xc xd xe xf = rep (seq6_ cons xa xb xc xd xe xf) --- Creates an XML converter for compound values represented as an --- XML element with children that correspond to the values components. --- The element can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the compound value --- @param conv(s) XML converter for the components --- @return XML element converter for a compound value eSeq6 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => String -> (a -> b -> c -> d -> e -> f -> g) -> XmlConv _ _ a -> XmlConv _ _ b -> XmlConv _ _ c -> XmlConv _ _ d -> XmlConv _ _ e -> XmlConv _ _ f -> XElemConv g eSeq6 name cons xa xb xc xd xe xf = element name (seq6 cons xa xb xc xd xe xf) --- Creates an XML converter for repetitions of sequences represented as an --- XML element that can be used in repetitions. --- --- @param name Tag name of the element --- @param cons constructor of the sequence --- @param conv(s) XML converter for the components --- @return XML element converter for a repeated sequence eRepSeq6 :: (Data a, Data b, Data c, Data d, Data e, Data f, Data g) => String -> (a -> b -> c -> d -> e -> f -> g) -> XmlConv Repeatable _ a -> XmlConv Repeatable _ b -> XmlConv Repeatable _ c -> XmlConv Repeatable _ d -> XmlConv Repeatable _ e -> XmlConv Repeatable _ f -> XElemConv [g] eRepSeq6 name cons xa xb xc xd xe xf = element name (repSeq6 cons xa xb xc xd xe xf) curry-tools-v3.3.0/optimize/Makefile000066400000000000000000000016361377556325500175350ustar00rootroot00000000000000# Makefile for binding optimizer: # replacement stuff empty := space := $(empty) $(empty) # The load path of the application: LOADPATH = src:$(subst $(space),:,$(wildcard .cpm/packages/*/src)) # Source modules: DEPS = .cpm/packages/*/src/*/*curry src/BindingOpt.curry .PHONY: all all: install .PHONY: install install: compile .PHONY: compile compile: BindingOpt # Load the application into the interactive Curry system: .PHONY: load load: $(REPL) -Dbindingoptimization=no --nocypm $(REPL_OPTS) :set path $(LOADPATH) :l BindingOpt # Compile and create an executable of the binding optimizer: BindingOpt: $(DEPS) $(REPL) -Dbindingoptimization=no --nocypm $(REPL_OPTS) :set path $(LOADPATH) :l BindingOpt :save :q # Clean intermediate files: .PHONY: clean clean: $(CLEANCURRY) -r .PHONY: uninstall uninstall: clean rm -f BindingOpt # run the test suite runtest: $(BINDIR)/cypm -d curry_bin=$(REPL) test curry-tools-v3.3.0/optimize/README.txt000066400000000000000000000016221377556325500175660ustar00rootroot00000000000000This package contains the implementation of a transformation tool that replaces Boolean equalities by equational constraints in FlatCurry programs. The tool is integrated into the compilation chain of PAKCS/KiCS2. The motivation and ideas of this tool are described in the following paper: Antoy, S., Hanus, M.: From Boolean Equalities to Constraints Proceedings of the 25th International Symposium on Logic-based Program Synthesis and Transformation (LOPSTR 2015), Springer LNCS 9527, 2015, 73-88 http://dx.doi.org/10.1007/978-3-319-27436-2_5 Statistics about the number of transformations are shown with increased verbosity levels. For instance, if one sets the option "v2" in PAKCS/KiCS2, a summary of the number of transformation is shown, with option "v3" more details (analysis infos, timings, and functions where transformations are applied) are shown and a CSV file with this information is generated. curry-tools-v3.3.0/optimize/docs/000077500000000000000000000000001377556325500170175ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/docs/README.txt000066400000000000000000000002371377556325500205170ustar00rootroot00000000000000This directory contains some documention for the Curry optimizer: manual.tex: A short description to be included in the main manual of the Curry system. curry-tools-v3.3.0/optimize/docs/manual.tex000066400000000000000000000061041377556325500210170ustar00rootroot00000000000000\section{Optimization of Curry Programs} After the invocation of the Curry front end, which parses a Curry program and translates it into the intermediate FlatCurry representation, \CYS applies a transformation to optimize Boolean equalities occurring in the Curry program. The ideas and details of this optimization are described in \cite{AntoyHanus15LOPSTR}. Therefore, we sketch only some basic ideas and options to influence this optimization. Consider the following definition of the operation \code{last} to extract the last element in list: % \begin{curry} last :: Data a => [a] -> a last xs | xs === _ ++ [x] = x where x free \end{curry} % In order to evaluate the condition \ccode{xs === \us{}++[x]}, the Boolean equality is evaluated to \code{True} or \code{False} by instantiating the free variables \code{\us} and \code{x}. However, since we know that a condition must be evaluated to \code{True} only and all evaluations to \code{False} can be ignored, we can use the constrained equality to obtain a more efficient program: % \begin{curry} last :: Data a => [a] -> a last xs | xs =:= _++[x] = x where x free \end{curry} % Since the selection of the appropriate equality operator is not obvious and might be tedious, \CYS encourages programmers to use only the Boolean equality operator \ccode{===} in programs. The constraint equality operator \ccode{=:=} can be considered as an optimization of \ccode{===} if it is ensured that only positive results are required, e.g., in conditions of program rules. To support this programming style, \CYS has a built-in optimization phase on FlatCurry files. For this purpose, the optimizer analyzes the FlatCurry programs for occurrences of \ccode{===} and replaces them by \ccode{=:=} whenever the result \code{False} is not required.\footnote{The current optimizer also replaces occurrences of \texttt{(==)} although this transformation is valid only if the corresponding \texttt{Eq} instances define equality rather than equivalence.} The usage of the optimizer can be influenced by setting the property flag \code{bindingoptimization} in the configuration file \code{\curryrc}. The following values are recognized for this flag: \begin{description} \item[\code{no}:] Do not apply this transformation. \item[\code{fast}:] This is the default value. The transformation is based on pre-computed values for the prelude operations in order to decide whether the value \code{False} is not required as a result of a Boolean equality. Hence, the transformation can be efficiently performed without any complex analysis. \item[\code{full}:] Perform a complete ``required values'' analysis of the program (see \cite{AntoyHanus15LOPSTR}) and use this information to optimize programs. In most cases, this does not yield better results so that the \code{fast} mode is sufficient. \end{description} % Hence, to turn off this optimization, one can either modify the flag \code{bindingoptimization} in the configuration file \code{\curryrc} or dynamically pass this change to the invocation of \CYS by \begin{quote} \ldots{} \code{-Dbindingoptimization=no} \ldots \end{quote} curry-tools-v3.3.0/optimize/examples/000077500000000000000000000000001377556325500177055ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/examples/Expressions.curry000066400000000000000000000042021377556325500233130ustar00rootroot00000000000000-------------------------------------------------------------- -- ExpVarFunPats -------------------------------------------------------------- import Test.Prop data Peano = O | S Peano deriving (Eq,Show) data Exp = Num Peano | Var VarName | Add Exp Exp | Mul Exp Exp deriving (Eq,Show) data VarName = X1 | X2 | X3 deriving (Eq,Show) data Position = Lt | Rt evalTo e = Add (Num O) e ? Add e (Num O) ? Mul (Num (S O)) e ? Mul e (Num (S O)) replace :: Exp -> [Position] -> Exp -> Exp replace _ [] x = x replace (Add l r) (Lt:p) x = Add (replace l p x) r replace (Add l r) (Rt:p) x = Add l (replace r p x) replace (Mul l r) (Lt:p) x = Mul (replace l p x) r replace (Mul l r) (Rt:p) x = Mul l (replace r p x) genExpWithVar :: Int -> Exp genExpWithVar n = if n==0 then Add (Var X1) (Num O) else Mul (Num (S O)) (genExpWithVar (n-1)) genExpWithVar' :: Int -> Exp genExpWithVar' n = if n==0 then Add (Var X1) (Num O) else Mul (genExpWithVar' (n-1)) (Num (S O)) -- return some variable occurring in an expression: varInExp :: Exp -> VarName varInExp exp | replace x y (Var v) === exp = v where x, y, v free -- find a variable in an expression having 203 nodes main1 :: VarName main1 = varInExp (genExpWithVar' 100) test_varInExp = varInExp (genExpWithVar' 100) -=- X1 ---------------------------------------------------------------- -- Simplify ---------------------------------------------------------------- simplify :: Exp -> Exp simplify exp | replace c p (evalTo x) === exp = replace c p x where c, p, x free genExpWithMult1 :: Int -> Exp genExpWithMult1 n = if n==0 then Mul (Num (S O)) (Var X1) else Mul (Num (S (S O))) (genExpWithMult1 (n-1)) expSize :: Exp -> Int expSize (Num _) = 1 expSize (Var _) = 1 expSize (Add e1 e2) = expSize e1 + expSize e2 + 1 expSize (Mul e1 e2) = expSize e1 + expSize e2 + 1 -- make a single simplification step in an expression having 4003 nodes main2 :: Int main2 = expSize (simplify (genExpWithMult1 2000)) test_simplify = expSize (simplify (genExpWithMult1 2000)) -=- 4001 curry-tools-v3.3.0/optimize/examples/Grep.curry000066400000000000000000000017661377556325500217020ustar00rootroot00000000000000--------------------------------------------------------------- -- grep --------------------------------------------------------------- import Test.Prop -- Representation of regular expression: data RE a = Lit a | Alt (RE a) (RE a) | Conc (RE a) (RE a) | Star (RE a) -- My characters: data Chr = A | B | C | D | E deriving (Eq,Show) -- Example: regular expression (ab*) abstar :: RE Chr abstar = Conc (Lit A) (Star (Lit B)) -- Example: regular expression (ab*c) abstarc :: RE Chr abstarc = Conc abstar (Lit C) -- Semantics of regular expressions sem :: RE a -> [a] sem (Lit c) = [c] sem (Alt a b) = sem a ? sem b sem (Conc a b) = sem a ++ sem b sem (Star a) = [] ? sem (Conc a (Star a)) grep :: Data a => RE a -> [a] -> Bool grep r s | _ ++ sem r ++ _ === s = True bigABABC :: Int -> [Chr] bigABABC n = take n (concatMap (\i -> A : take i (repeat B)) [1..]) ++ [A,B,C] main :: Bool main = grep abstarc (bigABABC 50) test_grep = always $ grep abstarc (bigABABC 50) curry-tools-v3.3.0/optimize/examples/Half.curry000066400000000000000000000007601377556325500216500ustar00rootroot00000000000000-- Half of a natural number: import Test.Prop data Peano = O | S Peano deriving (Eq,Show) toPeano :: Int -> Peano toPeano n = if n==0 then O else S (toPeano (n-1)) fromPeano :: Peano -> Int fromPeano O = 0 fromPeano (S p) = 1 + fromPeano p add :: Peano -> Peano -> Peano add O p = p add (S p) q = S (add p q) half :: Peano -> Peano half y | add x x === y = x where x free main :: Int main = fromPeano (half (toPeano 100)) test_half = fromPeano (half (toPeano 100)) -=- 50 curry-tools-v3.3.0/optimize/examples/Last.curry000066400000000000000000000003041377556325500216730ustar00rootroot00000000000000-- The classical last element of a list: import Test.Prop last :: Data a => [a] -> a last xs | _ ++ [x] === xs = x where x free main :: Int main = last [1,2,3] test_last = last [1,2,3] -=- 3 curry-tools-v3.3.0/optimize/examples/Various.curry000066400000000000000000000003211377556325500224170ustar00rootroot00000000000000-- Various test functions import Test.Prop f :: Data a => [a] -> [a] -> a f xs ys | xs === _ ++ [x] && ys === _ ++ [x] ++ _ = x where x free main :: Int main = f [1,2] [2,1] test_f = f [1,2] [2,1] -=- 2 curry-tools-v3.3.0/optimize/package.json000066400000000000000000000013671377556325500203640ustar00rootroot00000000000000{ "name": "transbooleq", "version": "3.0.0", "author": "Michael Hanus ", "synopsis": "A transformation tool to replace Boolean equalities by equational constraints", "category": [ "Analysis", "Optimization" ], "dependencies": { }, "compilerCompatibility": { "pakcs": ">= 3.0.0, < 4.0.0", "kics2": ">= 3.0.0, < 4.0.0" }, "executable": { "name": "curry-transbooleq", "main": "BindingOpt" }, "testsuite": { "src-dir": "examples", "modules": [ "Expressions", "Grep", "Half", "Last", "Various" ] }, "source": { "git": "https://git.ps.informatik.uni-kiel.de/curry-packages/transbooleq.git", "tag": "$version" } } curry-tools-v3.3.0/optimize/src/000077500000000000000000000000001377556325500166565ustar00rootroot00000000000000curry-tools-v3.3.0/optimize/src/BindingOpt.curry000066400000000000000000000535151377556325500220120ustar00rootroot00000000000000------------------------------------------------------------------------- --- Implementation of a transformation to replace Boolean equalities --- by equational constraints (which binds variables). --- --- @author Michael Hanus --- @version January 2020 ------------------------------------------------------------------------- module BindingOpt (main, transformFlatProg) where import Control.Monad ( when, unless ) import Curry.Compiler.Distribution ( installDir, curryCompiler ) import Data.List import Data.Maybe ( fromJust, isJust ) import System.Environment ( getArgs ) import System.CPUTime ( getCPUTime ) import FlatCurry.Types hiding (Cons) import FlatCurry.Files import FlatCurry.Goodies import System.CurryPath ( runModuleAction ) import System.Directory ( renameFile ) import System.FilePath ( (), (<.>), normalise, pathSeparator , takeExtension, dropExtension ) import System.Process ( system, exitWith ) import Analysis.Types import Analysis.ProgInfo import Analysis.RequiredValues import CASS.Server ( analyzeGeneric, analyzePublic, analyzeInterface ) import System.CurryPath ( currySubdir, addCurrySubdir, splitModuleFileName ) import Text.CSV ------------------------------------------------------------------------------ -- The options for the transformation. data Options = Options { verbosity :: Int -- verbosity , withAnalysis :: Bool -- use analysis? , eqvTrans :: Bool -- transform also (==)? , loadProg :: Bool -- load transformed program? } defaultOptions :: Options defaultOptions = Options 1 True True False systemBanner :: String systemBanner = let bannerText = "Curry Binding Optimizer (version of 07/01/2021)" bannerLine = take (length bannerText) (repeat '=') in bannerLine ++ "\n" ++ bannerText ++ "\n" ++ bannerLine usageComment :: String usageComment = unlines [ "Usage: curry-transbooleq [option] ... [module or FlatCurry file] ..." , " -v : set verbosity level (n=0|1|2|3)" , " -f : fast transformation without analysis" , " (uses only information about the standard prelude)" , " -s : transform only (===) but not (==)" , " -l : load optimized module into Curry system" , " -h, -? : show this help text" ] ------------------------------------------------------------------------------ -- main function to call the optimizer: main :: IO () main = getArgs >>= checkArgs defaultOptions mainCallError :: [String] -> IO () mainCallError args = do putStrLn $ systemBanner ++ "\nIllegal arguments: " ++ unwords args ++ "\n" ++ usageComment exitWith 1 checkArgs :: Options -> [String] -> IO () checkArgs opts args = case args of [] -> mainCallError [] ('-':'v':d:[]):margs -> let v = ord d - ord '0' in if v >= 0 && v < 4 then checkArgs opts { verbosity = v } margs else mainCallError args "-f" : margs -> checkArgs opts { withAnalysis = False } margs "-s" : margs -> checkArgs opts { eqvTrans = False } margs "-l" : margs -> checkArgs opts { loadProg = True } margs "-h" : _ -> putStr (systemBanner++'\n':usageComment) "-?" : _ -> putStr (systemBanner++'\n':usageComment) mods -> do printVerbose opts 1 systemBanner mapM_ (transformBoolEq opts) mods -- Verbosity level: -- 0 : show nothing -- 1 : show summary of optimizations performed -- 2 : show analysis infos and details of optimizations including timings -- 3 : show analysis infos also of imported modules -- Output a string w.r.t. verbosity level printVerbose :: Options -> Int -> String -> IO () printVerbose opts printlevel message = unless (null message || verbosity opts < printlevel) $ putStrLn message transformBoolEq :: Options -> String -> IO () transformBoolEq opts name = do if takeExtension name == ".fcy" then do prog <- readFlatCurryFile name let modname = modNameOfFcyName (normalise (dropExtension name)) transformAndStoreFlatProg opts modname name prog else runModuleAction (\mn -> readFlatCurry mn >>= transformAndStoreFlatProg opts mn (flatCurryFileName mn)) name -- Extracts the module name from a given FlatCurry file name: modNameOfFcyName :: String -> String modNameOfFcyName name = let wosuffix = normalise (dropExtension name) [dir,wosubdir] = splitOn (currySubdir ++ [pathSeparator]) wosuffix in -- construct hierarchical module name: dir intercalate "." (split (==pathSeparator) wosubdir) transformAndStoreFlatProg :: Options -> String -> String -> Prog -> IO () transformAndStoreFlatProg opts modname fcyfile prog = do printVerbose opts 1 $ "Reading and analyzing module '" ++ modname ++ "'..." starttime <- getCPUTime (newprog, transformed) <- transformFlatProg opts modname prog let optfcyfile = fcyfile ++ "_OPT" when transformed $ writeFCY optfcyfile newprog stoptime <- getCPUTime printVerbose opts 2 $ "Transformation time for " ++ modname ++ ": " ++ show (stoptime-starttime) ++ " msecs" when transformed $ do printVerbose opts 2 $ "Transformed program stored in " ++ optfcyfile renameFile optfcyfile fcyfile printVerbose opts 2 $ " ...and moved to " ++ fcyfile when (loadProg opts) $ do system $ curryComp ++ " -Dbindingoptimization=no :l " ++ modname return () where curryComp = installDir "bin" curryCompiler -- Perform the binding optimization on a FlatCurry program. -- Return the new FlatCurry program and a flag indicating whether -- something has been changed. transformFlatProg :: Options -> String -> Prog -> IO (Prog, Bool) transformFlatProg opts modname (Prog mname imports tdecls fdecls opdecls)= do lookupreqinfo <- if withAnalysis opts then do (mreqinfo,reqinfo) <- loadAnalysisWithImports reqValueAnalysis modname imports printVerbose opts 2 $ "\nResult of \"RequiredValue\" analysis:\n" ++ showInfos (showAFType AText) (if verbosity opts == 3 then reqinfo else mreqinfo) return (flip lookupProgInfo reqinfo) else return (flip lookup preludeBoolReqValues) let (stats,newfdecls) = unzip (map (transformFuncDecl opts lookupreqinfo) fdecls) numtranseqs = totalTransEqs stats numtranseqv = totalTransEqv stats numbeqs = totalBEqs stats csvfname = mname ++ "_BOPTSTATS.csv" printVerbose opts 2 $ statSummary stats printVerbose opts 1 $ "Total number of transformed (dis)equalities: " ++ show numtranseqs ++ " (===) " ++ (if eqvTrans opts then " and " ++ show numtranseqv ++ " (==)" else "") ++ " (out of " ++ show numbeqs ++ ")" unless (verbosity opts < 2) $ do writeCSVFile csvfname (stats2csv stats) putStrLn ("Detailed statistics written to '" ++ csvfname ++"'") return ( Prog mname imports tdecls newfdecls opdecls , numtranseqs + numtranseqv > 0) loadAnalysisWithImports :: (Read a, Show a) => Analysis a -> String -> [String] -> IO (ProgInfo a,ProgInfo a) loadAnalysisWithImports analysis modname imports = do maininfo <- analyzeGeneric analysis modname >>= return . either id error impinfos <- mapM (\m -> analyzePublic analysis m >>= return . either id error) imports return $ (maininfo, foldr1 combineProgInfo (maininfo:impinfos)) showInfos :: (a -> String) -> ProgInfo a -> String showInfos showi = unlines . map (\ (qn,i) -> snd qn ++ ": " ++ showi i) . (\p -> fst p ++ snd p) . progInfo2Lists -- Transform a function declaration. -- Some statistical information and the new function declaration are returned. transformFuncDecl :: Options -> (QName -> Maybe AFType) -> FuncDecl -> (TransStat, FuncDecl) transformFuncDecl opts lookupreqinfo fdecl@(Func qf@(_,fn) ar vis texp rule) = if containsBeqRule opts rule then let (tst,trule) = transformRule opts lookupreqinfo (initTState qf) rule in ( TransStat fn beqs (numTransEqs tst) (numTransEqv tst) , Func qf ar vis texp trule ) else (TransStat fn 0 0 0, fdecl) where beqs = numberBeqRule opts rule ------------------------------------------------------------------------- -- State threaded through the program transformer: -- * name of current function -- * number of occurrences of (===) that are replaced by (=:=) -- * number of occurrences of (==) that are replaced by (=:=) data TState = TState { currFunc :: QName , numTransEqs :: Int , numTransEqv :: Int } initTState :: QName -> TState initTState qf = TState qf 0 0 -- Increment number of transformed equalities. incNumEqs :: TState -> TState incNumEqs tst = tst { numTransEqs = numTransEqs tst + 1 } -- Increment number of transformed equivalences. incNumEqv :: TState -> TState incNumEqv tst = tst { numTransEqv = numTransEqv tst + 1 } ------------------------------------------------------------------------- --- Transform a FlatCurry program rule w.r.t. information about required --- values. If there is an occurrence of `(e1===e2)` where the value `True` --- is required, then this occurrence is replaced by --- --- (Prelude.constrEq e1 e2) --- --- Similarly, `(e1/==e2)` with required value `False` is replaced by --- --- (not (Prelude.constrEq e1 e2)) transformRule :: Options -> (QName -> Maybe AFType) -> TState -> Rule -> (TState,Rule) transformRule _ _ tst (External s) = (tst, External s) transformRule opts lookupreqinfo tstr (Rule args rhs) = let (te,tste) = transformExp tstr rhs Any in (tste, Rule args te) where -- transform an expression w.r.t. a required value transformExp tst (Var i) _ = (Var i, tst) transformExp tst (Lit v) _ = (Lit v, tst) transformExp tst0 exp@(Comb ct qf es) reqval | reqval == aTrue && isBoolEqualCall opts True exp = case checkBoolEqualCall opts True (Comb ct qf tes) of Just (eqs,targs) -> ( Comb FuncCall (pre "constrEq") targs , (if eqs then incNumEqs else incNumEqv) tst1 ) Nothing -> error "Internal error: Nothing in transfromExp" | reqval == aFalse && isBoolEqualCall opts False exp = case checkBoolEqualCall opts False (Comb ct qf tes) of Just (eqs,targs) -> ( Comb FuncCall (pre "not") [Comb FuncCall (pre "constrEq") targs] , (if eqs then incNumEqs else incNumEqv) tst1 ) Nothing -> error "Internal error: Nothing in transfromExp" | qf == pre "$" && length es == 2 && (isFuncPartCall (head es) || isConsPartCall (head es)) = transformExp tst0 (reduceDollar es) reqval | otherwise = (Comb ct qf tes, tst1) where reqargtypes = argumentTypesFor (lookupreqinfo qf) reqval (tes,tst1) = transformExps tst0 (zip es reqargtypes) transformExp tst0 (Free vars e) reqval = let (te,tst1) = transformExp tst0 e reqval in (Free vars te, tst1) transformExp tst0 (Or e1 e2) reqval = let (te1,tst1) = transformExp tst0 e1 reqval (te2,tst2) = transformExp tst1 e2 reqval in (Or te1 te2, tst2) transformExp tst0 (Typed e t) reqval = let (te,tst1) = transformExp tst0 e reqval in (Typed te t, tst1) transformExp tst0 (Case ct e bs) reqval = let (te ,tst1) = transformExp tst0 e (caseArgType bs) (tbs,tst2) = transformBranches tst1 bs reqval in (Case ct te tbs, tst2) transformExp tst0 (Let bs e) reqval = let (tbes,tst1) = transformExps tst0 (zip (map snd bs) (repeat Any)) (te,tst2) = transformExp tst1 e reqval in (Let (zip (map fst bs) tbes) te, tst2) transformExps tst [] = ([],tst) transformExps tst ((exp,rv):exps) = let (te, tste ) = transformExp tst exp rv (tes,tstes) = transformExps tste exps in (te:tes, tstes) transformBranches tst [] _ = ([],tst) transformBranches tst (br:brs) reqval = let (tbr,tst1) = transformBranch tst br reqval (tbrs,tst2) = transformBranches tst1 brs reqval in (tbr:tbrs, tst2) transformBranch tst (Branch pat be) reqval = let (tbe,tstb) = transformExp tst be reqval in (Branch pat tbe, tstb) ------------------------------------------------------------------------- -- Check whether the expression argument is a call to a Boolean (dis)equality. -- If this is the case, return a flag indicating whether it is a `(===)` call -- and the actual arguments of the call. -- Otherwise, return `Nothing`. -- If the first argument is `True`, we check equalities ("===" or "=="), -- otherwise we check disequalities ("/="). -- Since the equalities are defined in type classes, -- a Boolean (dis)equality call can be -- * an instance (dis)equality call: "_impl#==#Prelude.Eq#..." ... e1 e2 -- (where there can be additional arguments for other Eq dicts) -- * a class (dis)equality call: apply (apply ("==" [dict]) e1) e2 -- (where dict is a dictionary parameter) -- * a default instance (dis)equality call: -- apply (apply ("_impl#==#Prelude.Eq#..." []) e1) e2 checkBoolEqualCall :: Options -> Bool -> Expr -> Maybe (Bool, [Expr]) checkBoolEqualCall opts eq exp = case exp of Comb FuncCall qf es -> if isEqNameOrInst qf && length es > 1 then Just (isEqsNameOrInst qf, -- drop possible Eq dictionary arguments: drop (length es - 2) es) else if qf == pre "apply" then case es of [Comb FuncCall qfa [Comb FuncCall qfe [_],e1],e2] -> if qfa == pre "apply" && isEqNameOrInst qfe then Just (isEqsNameOrInst qfe, [e1,e2]) else Nothing [Comb FuncCall qfa [Comb FuncCall qfe [],e1],e2] -> if qfa == pre "apply" && isEqNameOrInst qfe then Just (isEqsNameOrInst qfe, [e1,e2]) else Nothing _ -> Nothing else Nothing _ -> Nothing where isEqNameOrInst qf = isEqsNameOrInst qf || isEqvNameOrInst qf isEqsNameOrInst qf@(_,f) = if eq then qf == pre "===" || "_impl#===#Prelude.Data#" `isPrefixOf` f else qf == pre "/==" isEqvNameOrInst qf@(_,f) = eqvTrans opts && -- should we also transform (==)? if eq then qf == pre "==" || "_impl#==#Prelude.Eq#" `isPrefixOf` f else qf == pre "/=" || "_impl#/=#Prelude.Eq#" `isPrefixOf` f -- Is this a call to a Boolean equality? -- If the first argument is `True`, it must be an equality call, -- otherwise an disequality call. isBoolEqualCall :: Options -> Bool -> Expr -> Bool isBoolEqualCall opts eq exp = isJust (checkBoolEqualCall opts eq exp) ------------------------------------------------------------------------- --- Reduce an application of Prelude.$ to a combination: reduceDollar :: [Expr] -> Expr reduceDollar args = case args of [Comb (FuncPartCall n) qf es, arg2] -> Comb (if n==1 then FuncCall else (FuncPartCall (n-1))) qf (es++[arg2]) [Comb (ConsPartCall n) qf es, arg2] -> Comb (if n==1 then ConsCall else (ConsPartCall (n-1))) qf (es++[arg2]) _ -> error "reduceDollar" --- Try to compute the required value of a case argument expression. --- If one branch of the case expression is "False -> failed", --- then the required value is `True` (this is due to the specific --- translation of Boolean conditional rules of the front end). --- If the case expression has one non-failing branch, the constructor --- of this branch is chosen, otherwise it is `Any`. caseArgType :: [BranchExpr] -> AType caseArgType branches | not (null (tail branches)) && branches!!1 == Branch (Pattern (pre "False") []) failedFC = aCons (pre "True") | length nfbranches /= 1 = Any | otherwise = getPatCons (head nfbranches) where failedFC = Comb FuncCall (pre "failed") [] nfbranches = filter (\ (Branch _ be) -> be /= failedFC) branches getPatCons (Branch (Pattern qc _) _) = aCons qc getPatCons (Branch (LPattern _) _) = Any --- Compute the argument types for a given abstract function type --- and required value. argumentTypesFor :: Maybe AFType -> AType -> [AType] argumentTypesFor Nothing _ = repeat Any argumentTypesFor (Just EmptyFunc) _ = repeat Any argumentTypesFor (Just (AFType rtypes)) reqval = maybe (-- no exactly matching type, look for Any type: maybe (-- no Any type: if reqtype==Any, try lub of all other types: if (reqval==Any || reqval==AnyC) && not (null rtypes) then foldr1 lubArgs (map fst rtypes) else repeat Any) fst (find ((`elem` [AnyC,Any]) . snd) rtypes)) fst (find ((==reqval) . snd) rtypes) where lubArgs xs ys = map (uncurry lubAType) (zip xs ys) -- Does `Prelude.===` or `Prelude.==` occur in a rule? containsBeqRule :: Options -> Rule -> Bool containsBeqRule _ (External _) = False containsBeqRule opts (Rule _ rhs) = containsBeqExp rhs where -- containsBeq an expression w.r.t. a required value containsBeqExp (Var _) = False containsBeqExp (Lit _) = False containsBeqExp exp@(Comb _ _ es) = isBoolEqualCall opts True exp || isBoolEqualCall opts False exp || any containsBeqExp es containsBeqExp (Free _ e ) = containsBeqExp e containsBeqExp (Or e1 e2 ) = containsBeqExp e1 || containsBeqExp e2 containsBeqExp (Typed e _ ) = containsBeqExp e containsBeqExp (Case _ e bs) = containsBeqExp e || any containsBeqBranch bs containsBeqExp (Let bs e ) = containsBeqExp e || any containsBeqExp (map snd bs) containsBeqBranch (Branch _ be) = containsBeqExp be -- Number of occurrences of `Prelude.===` or `Prelude./==` occurring in a rule: numberBeqRule :: Options -> Rule -> Int numberBeqRule _ (External _) = 0 numberBeqRule opts (Rule _ rhs) = numberBeqExp rhs where -- numberBeq an expression w.r.t. a required value numberBeqExp (Var _) = 0 numberBeqExp (Lit _) = 0 numberBeqExp exp@(Comb _ _ es) = case checkBoolEqualCall opts True exp of Just (_,targs) -> 1 + sum (map numberBeqExp targs) Nothing -> case checkBoolEqualCall opts False exp of Just (_,fargs) -> 1 + sum (map numberBeqExp fargs) Nothing -> sum (map numberBeqExp es) numberBeqExp (Free _ e) = numberBeqExp e numberBeqExp (Or e1 e2) = numberBeqExp e1 + numberBeqExp e2 numberBeqExp (Typed e _) = numberBeqExp e numberBeqExp (Case _ e bs) = numberBeqExp e + sum (map numberBeqBranch bs) numberBeqExp (Let bs e) = numberBeqExp e + sum (map numberBeqExp (map snd bs)) numberBeqBranch (Branch _ be) = numberBeqExp be pre :: String -> QName pre n = ("Prelude", n) ------------------------------------------------------------------------- -- Loading prelude analysis result: loadPreludeBoolReqValues :: IO [(QName, AFType)] loadPreludeBoolReqValues = do maininfo <- analyzeInterface reqValueAnalysis "Prelude" >>= return . either id error return (filter (hasBoolReqValue . snd) maininfo) where hasBoolReqValue EmptyFunc = False hasBoolReqValue (AFType rtypes) = maybe False (const True) (find (isBoolReqValue . snd) rtypes) isBoolReqValue rt = rt == aFalse || rt == aTrue -- Current relevant Boolean functions of the prelude: preludeBoolReqValues :: [(QName, AFType)] preludeBoolReqValues = [(pre "&&", AFType [([Any,Any],aFalse), ([aTrue,aTrue],aTrue)]) ,(pre "not", AFType [([aTrue],aFalse), ([aFalse],aTrue)]) ,(pre "||", AFType [([aFalse,aFalse],aFalse), ([Any,Any],aTrue)]) ,(pre "&", AFType [([aTrue,aTrue],aTrue)]) ,(pre "solve", AFType [([aTrue],aTrue)]) ,(pre "&&>", AFType [([aTrue,Any],AnyC)]) ] --- Map a constructor into an abstract value representing this constructor: aCons :: QName -> AType aCons qn = Cons [qn] --- Abstract `False` value aFalse :: AType aFalse = aCons (pre "False") --- Abstract `True` value aTrue :: AType aTrue = aCons (pre "True") ------------------------------------------------------------------------- --- Statistical information (e.g., for benchmarking the tool): --- * function name --- * number of Boolean (dis)equalities/equivalences in the rule --- * number of transformed (dis)equalities in the rule --- * number of transformed (dis)equivalences in the rule data TransStat = TransStat String Int Int Int --- Number of all (===) transformations: totalTransEqs :: [TransStat] -> Int totalTransEqs = sum . map (\ (TransStat _ _ teqs _) -> teqs) --- Number of all (==) transformations: totalTransEqv :: [TransStat] -> Int totalTransEqv = sum . map (\ (TransStat _ _ _ teqv) -> teqv) --- Number of all Boolean (dis)equalities: totalBEqs :: [TransStat] -> Int totalBEqs = sum . map (\ (TransStat _ beqs _ _) -> beqs) --- Show a summary of the actual transformations: statSummary :: [TransStat] -> String statSummary = concatMap showSum where showSum (TransStat fn _ teqs teqv) = if teqs + teqv == 0 then "" else (if teqs > 0 then showFun fn ++ showNOccs teqs ++ " of (===) transformed into (=:=)\n" else "") ++ (if teqv > 0 then showFun fn ++ showNOccs teqv ++ " of (==) transformed into (=:=)\n" else "") showFun fn = "Function " ++ fn ++ ": " showNOccs n = if n==1 then "one occurrence" else show n ++ " occurrences" --- Translate statistics into CSV format: stats2csv :: [TransStat] -> [[String]] stats2csv stats = ["Function","Boolean equalities", "Transformed equalities", "Transformed equivalences"] : map (\ (TransStat fn beqs teqs teqv) -> fn : map show [beqs, teqs, teqv]) stats -------------------------------------------------------------------------